fix(schedule): account for showRoom
This commit is contained in:
Sarah Vaupel
parent
f46f23785d
commit
6b8a140aca
@ -8,6 +8,10 @@ import Import
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
import Handler.Utils.Course (showCourseEventRoom)
|
||||
import Handler.Utils.Exam (showExamOccurrenceRoom)
|
||||
import Handler.Utils.Tutorial (showTutorialRoom)
|
||||
|
||||
import Utils.Course
|
||||
import Utils.Tutorial
|
||||
|
||||
@ -25,21 +29,27 @@ fetchCourseEventsScheduleInfo muid ata now = E.select $ E.from $ \(course `E.Inn
|
||||
E.on $ course E.^. CourseId E.==. courseEvent E.^. CourseEventCourse
|
||||
E.where_ $ courseEventShouldBeDisplayedInSchedule muid ata course courseEvent
|
||||
E.&&. mayViewCourse muid ata now course Nothing -- should not be necessary, but let's be on the safe side
|
||||
return (course, courseEvent)
|
||||
let showRoom = maybe E.false (flip showCourseEventRoom courseEvent . E.val) muid
|
||||
E.||. E.not_ (courseEvent E.^. CourseEventRoomHidden)
|
||||
return (course, courseEvent, showRoom)
|
||||
|
||||
fetchTutorialsScheduleInfo :: MonadHandler m => Maybe UserId -> AuthTagActive -> UTCTime -> ReaderT SqlBackend m [ScheduleTutorialInfo]
|
||||
fetchTutorialsScheduleInfo muid ata now = E.select $ E.from $ \(course `E.InnerJoin` tutorial) -> do
|
||||
E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
|
||||
E.where_ $ tutorialShouldBeDisplayedInSchedule muid ata course tutorial
|
||||
E.&&. mayViewCourse muid ata now course Nothing -- should not be necessary, but let's be on the safe side
|
||||
return (course, tutorial)
|
||||
let showRoom = maybe E.false (flip showTutorialRoom tutorial . E.val) muid
|
||||
E.||. E.not_ (tutorial E.^. TutorialRoomHidden)
|
||||
return (course, tutorial, showRoom)
|
||||
|
||||
fetchExamOccurrencesScheduleInfo :: MonadHandler m => Maybe UserId -> AuthTagActive -> UTCTime -> ReaderT SqlBackend m [ScheduleExamOccurrenceInfo]
|
||||
fetchExamOccurrencesScheduleInfo muid ata now = E.select $ E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examOccurrence) -> do
|
||||
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
||||
E.on $ exam E.^. ExamId E.==. examOccurrence E.^. ExamOccurrenceExam
|
||||
E.where_ $ examOccurrenceShouldBeDisplayedInSchedule muid ata now course exam examOccurrence
|
||||
return (course, exam, examOccurrence)
|
||||
let showRoom = maybe E.false (flip showExamOccurrenceRoom examOccurrence . E.val) muid
|
||||
E.||. E.not_ (examOccurrence E.^. ExamOccurrenceRoomHidden)
|
||||
return (course, exam, examOccurrence, showRoom)
|
||||
|
||||
|
||||
courseEventShouldBeDisplayedInSchedule :: Maybe UserId -> AuthTagActive -> E.SqlExpr (Entity Course) -> E.SqlExpr (Entity CourseEvent) -> E.SqlExpr (E.Value Bool)
|
||||
|
||||
@ -4,6 +4,8 @@ module Utils.Schedule.Types
|
||||
|
||||
import Import
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import Utils.Schedule.Types.ScheduleEntry as Utils.Schedule.Types
|
||||
import Utils.Schedule.Types.ScheduleView as Utils.Schedule.Types
|
||||
import Utils.Schedule.Types.ScheduleOffset as Utils.Schedule.Types
|
||||
@ -11,7 +13,25 @@ import Utils.Schedule.Types.ScheduleOptions as Utils.Schedule.Types
|
||||
|
||||
|
||||
-- TODO: replace Info types with one joined type and fetch info in one single runDB
|
||||
type ScheduleCourseEventInfo = (Entity Course, Entity CourseEvent)
|
||||
type ScheduleTutorialInfo = (Entity Course, Entity Tutorial)
|
||||
type ScheduleExamOccurrenceInfo = (Entity Course, Entity Exam, Entity ExamOccurrence)
|
||||
type ScheduleExamOccurrenceJoinedInfo = (Entity Course, Entity Exam, NonEmpty (Entity ExamOccurrence))
|
||||
|
||||
type ScheduleCourseEventInfo = ( Entity Course
|
||||
, Entity CourseEvent
|
||||
, E.Value Bool -- showRoom
|
||||
)
|
||||
|
||||
type ScheduleTutorialInfo = ( Entity Course
|
||||
, Entity Tutorial
|
||||
, E.Value Bool -- showRoom
|
||||
)
|
||||
|
||||
type ScheduleExamOccurrenceInfo = ( Entity Course
|
||||
, Entity Exam
|
||||
, Entity ExamOccurrence
|
||||
, E.Value Bool -- showRoom
|
||||
)
|
||||
type ScheduleExamOccurrenceJoinedInfo = ( Entity Course
|
||||
, Entity Exam
|
||||
, NonEmpty ( Entity ExamOccurrence
|
||||
, E.Value Bool -- showRoom
|
||||
)
|
||||
)
|
||||
|
||||
@ -9,7 +9,7 @@ data ScheduleEntry = ScheduleCourseEvent
|
||||
{ sceCourse :: Entity Course
|
||||
, sceType :: CourseEventType
|
||||
, sceRoom :: Maybe RoomReference
|
||||
, sceRoomHidden :: Bool
|
||||
, sceShowRoom :: Bool
|
||||
, sceOccurrence :: Either OccurrenceException OccurrenceSchedule
|
||||
, sceNoOccur :: Set LocalTime
|
||||
, sceTerm :: Entity Term
|
||||
@ -19,7 +19,7 @@ data ScheduleEntry = ScheduleCourseEvent
|
||||
, stName :: TutorialName
|
||||
, stType :: TutorialType
|
||||
, stRoom :: Maybe RoomReference
|
||||
, stRoomHidden :: Bool
|
||||
, stShowRoom :: Bool
|
||||
, stOccurrence :: Either OccurrenceException OccurrenceSchedule
|
||||
, stNoOccur :: Set LocalTime
|
||||
, stTerm :: Entity Term
|
||||
@ -27,7 +27,7 @@ data ScheduleEntry = ScheduleCourseEvent
|
||||
| ScheduleExamOccurrence
|
||||
{ seoCourse :: Entity Course
|
||||
, seoExamName :: ExamName
|
||||
, seoRooms :: NonEmpty (Maybe RoomReference) -- TODO: remove Nothing values and use NonEmpty RoomReference instead -- TODO: NonEmpty (RoomReference, Bool) for hidden
|
||||
, seoRooms :: NonEmpty (Maybe RoomReference, Bool) -- TODO: remove Nothing values and use NonEmpty (RoomReference, Bool) instead?
|
||||
, seoStart :: UTCTime
|
||||
, seoEnd :: Maybe UTCTime
|
||||
}
|
||||
|
||||
@ -9,6 +9,8 @@ import qualified Data.CaseInsensitive as CI
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import Handler.Utils.DateTime (formatTimeRangeW, formatTimeW, utcToLocalTime, localTimeToUTCSimple)
|
||||
import Handler.Utils.Widgets (roomReferenceWidget)
|
||||
|
||||
@ -101,7 +103,7 @@ weekSchedule now user@(Entity uid User{userScheduleWeekDays = ScheduleWeekDays u
|
||||
holidays = concatMap (termHolidays . entityVal) activeTerms
|
||||
|
||||
courseEventToScheduleEntries :: ScheduleCourseEventInfo -> [ScheduleEntry]
|
||||
courseEventToScheduleEntries (sceCourse@(Entity _ Course{..}), Entity _ CourseEvent{courseEventType=sceType,courseEventRoom=sceRoom,courseEventRoomHidden=sceRoomHidden,courseEventTime=Occurrences{..}})
|
||||
courseEventToScheduleEntries (sceCourse@(Entity _ Course{..}), Entity _ CourseEvent{courseEventType=sceType,courseEventRoom=sceRoom,courseEventTime=Occurrences{..}}, E.Value sceShowRoom)
|
||||
| [sceTerm] <- filter ((== courseTerm) . entityKey) activeTerms
|
||||
, termActive $ entityVal sceTerm
|
||||
= let scheduleds
|
||||
@ -115,7 +117,7 @@ weekSchedule now user@(Entity uid User{userScheduleWeekDays = ScheduleWeekDays u
|
||||
| otherwise = mempty
|
||||
|
||||
tutorialToScheduleEntries :: ScheduleTutorialInfo -> [ScheduleEntry]
|
||||
tutorialToScheduleEntries (stCourse@(Entity _ Course{..}), Entity _ Tutorial{tutorialName=stName,tutorialType=stType,tutorialRoom=stRoom,tutorialRoomHidden=stRoomHidden,tutorialTime=Occurrences{..}})
|
||||
tutorialToScheduleEntries (stCourse@(Entity _ Course{..}), Entity _ Tutorial{tutorialName=stName,tutorialType=stType,tutorialRoom=stRoom,tutorialTime=Occurrences{..}}, E.Value stShowRoom)
|
||||
| [stTerm] <- filter ((== courseTerm) . entityKey) activeTerms
|
||||
, termActive $ entityVal stTerm
|
||||
= let scheduleds
|
||||
@ -133,16 +135,16 @@ weekSchedule now user@(Entity uid User{userScheduleWeekDays = ScheduleWeekDays u
|
||||
joinParallelExamOccurrences :: [ScheduleExamOccurrenceInfo] -> [ScheduleExamOccurrenceJoinedInfo]
|
||||
joinParallelExamOccurrences = go [] where
|
||||
go acc [] = acc
|
||||
go acc (examOcc@(course, exam, occ):examOccs) =
|
||||
let ((((view _3) <$>) -> parallel), other) = partition (examOcc `isParallelTo`) examOccs
|
||||
in go ((course, exam, occ:|parallel):acc) other
|
||||
(Entity cid _, Entity eid _, Entity _ occ) `isParallelTo` (Entity cid' _, Entity eid' _, Entity _ occ') =
|
||||
go acc (examOcc@(course, exam, occ, showRoom):examOccs) =
|
||||
let ((((\(_,_,o,s) -> (o,s)) <$>) -> parallel), other) = partition (examOcc `isParallelTo`) examOccs
|
||||
in go ((course, exam, (occ,showRoom):|parallel):acc) other
|
||||
(Entity cid _, Entity eid _, Entity _ occ, _) `isParallelTo` (Entity cid' _, Entity eid' _, Entity _ occ', _) =
|
||||
cid == cid' && eid == eid'
|
||||
&& examOccurrenceStart occ == examOccurrenceStart occ' && examOccurrenceEnd occ == examOccurrenceEnd occ'
|
||||
|
||||
examOccurrenceToScheduleEntry :: ScheduleExamOccurrenceJoinedInfo -> ScheduleEntry
|
||||
examOccurrenceToScheduleEntry (seoCourse@(Entity _ Course{}), Entity _ Exam{examName=seoExamName}, examOccs@((Entity _ occ):|_)) =
|
||||
let seoRooms = (examOccurrenceRoom . entityVal) <$> examOccs
|
||||
examOccurrenceToScheduleEntry (seoCourse@(Entity _ Course{}), Entity _ Exam{examName=seoExamName}, examOccs@((Entity _ occ, _):|_)) =
|
||||
let seoRooms = (\(Entity _ ExamOccurrence{examOccurrenceRoom}, E.Value showRoom) -> (examOccurrenceRoom, showRoom)) <$> examOccs
|
||||
seoStart = examOccurrenceStart occ -- multiple exam occurrences are joined on equality of start and end,
|
||||
seoEnd = examOccurrenceEnd occ -- so taking the timestamps of the first occurrence suffices
|
||||
in ScheduleExamOccurrence{..}
|
||||
|
||||
@ -26,19 +26,20 @@ $newline never
|
||||
<a href=@{scheduleEntryToHref scheduleEntry} .schedule--entry-link>
|
||||
<div .schedule--entry .schedule--entry__#{toPathPiece slotAssociation} :slotAssocIsCont slotAssociation:.schedule--entry__continuation>
|
||||
$case scheduleEntry
|
||||
$of ScheduleCourseEvent{sceCourse=Entity _ Course{courseName},sceType,sceRoom,sceRoomHidden,sceOccurrence}
|
||||
$of ScheduleCourseEvent{sceCourse=Entity _ Course{courseName},sceType,sceRoom,sceShowRoom,sceOccurrence}
|
||||
#{CI.original courseName}: #{CI.original sceType} #
|
||||
$if slotAssocIsCont slotAssociation
|
||||
(_{MsgScheduleWeekSlotIsCont})
|
||||
<br>
|
||||
$if (not sceRoomHidden)
|
||||
$if sceShowRoom
|
||||
_{MsgScheduleRoom}: #
|
||||
$maybe room <- sceRoom
|
||||
_{MsgScheduleRoom}: ^{roomReferenceWidget room}
|
||||
^{roomReferenceWidget room}
|
||||
$nothing
|
||||
_{MsgCourseEventRoomIsUnset}
|
||||
<br>
|
||||
^{formatEitherOccurrenceW sceOccurrence}
|
||||
$of ScheduleTutorial{stCourse=Entity _ Course{courseName},stName,stType,stRoom,stRoomHidden,stOccurrence}
|
||||
$of ScheduleTutorial{stCourse=Entity _ Course{courseName},stName,stType,stRoom,stShowRoom,stOccurrence}
|
||||
#{CI.original courseName}: #{stName} #
|
||||
(
|
||||
#{CI.original stType}
|
||||
@ -46,9 +47,10 @@ $newline never
|
||||
, _{MsgScheduleWeekSlotIsCont}
|
||||
)
|
||||
<br>
|
||||
$if (not stRoomHidden)
|
||||
$if stShowRoom
|
||||
_{MsgScheduleRoom}: #
|
||||
$maybe room <- stRoom
|
||||
_{MsgScheduleRoom}: ^{roomReferenceWidget room}
|
||||
^{roomReferenceWidget room}
|
||||
$nothing
|
||||
_{MsgTutorialRoomIsUnset}
|
||||
<br>
|
||||
@ -58,16 +60,17 @@ $newline never
|
||||
$if slotAssocIsCont slotAssociation
|
||||
(_{MsgScheduleWeekSlotIsCont})
|
||||
<br>
|
||||
$case catMaybes (toList seoRooms)
|
||||
$of [room]
|
||||
_{MsgScheduleRoom}: ^{roomReferenceWidget room}
|
||||
<br>
|
||||
$case toList seoRooms
|
||||
$of [(mRoom,showRoom)]
|
||||
$if showRoom
|
||||
_{MsgScheduleRoom}: ^{maybe mempty roomReferenceWidget mRoom}
|
||||
<br>
|
||||
$of more
|
||||
_{MsgScheduleRooms}: #
|
||||
$forall room <- more
|
||||
^{roomReferenceWidget room}
|
||||
$forall (mRoom,showRoom) <- more
|
||||
$if showRoom
|
||||
^{maybe mempty roomReferenceWidget mRoom}
|
||||
<br>
|
||||
$of []
|
||||
_{MsgScheduleOccur}: #
|
||||
$if Just (utctDay seoStart) == fmap utctDay seoEnd
|
||||
^{formatTimeRangeW SelFormatTime seoStart seoEnd}
|
||||
|
||||
Reference in New Issue
Block a user