From 280a19865c8d787c3ea512061efd16d163113565 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel <> Date: Sun, 23 Aug 2020 21:05:08 +0200 Subject: [PATCH] feat(schedule-week): join multiple parallel exam occurrences (WIP) --- messages/uniworx/de-de-formal.msg | 1 + messages/uniworx/en-eu.msg | 1 + src/Utils/Schedule/Types.hs | 6 +++-- src/Utils/Schedule/Week.hs | 31 +++++++++++++++++--------- templates/widgets/schedule/week.hamlet | 11 ++++++--- 5 files changed, 35 insertions(+), 15 deletions(-) diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index e9c1e2509..0bf71f76e 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -107,6 +107,7 @@ NewsHeadlineSchedule: Terminübersicht ScheduleTableHeadTime: Zeit ScheduleRoom: Raum +ScheduleRooms: Räume ScheduleTime: Zeit ScheduleOccur: Findet statt diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 98f3d0ae6..f9f70f91b 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -107,6 +107,7 @@ NewsHeadlineSchedule: Schedule ScheduleTableHeadTime: Time ScheduleRoom: Room +ScheduleRooms: Rooms ScheduleTime: Time ScheduleOccur: Does occur diff --git a/src/Utils/Schedule/Types.hs b/src/Utils/Schedule/Types.hs index d304b9d1d..9a55e2c7f 100644 --- a/src/Utils/Schedule/Types.hs +++ b/src/Utils/Schedule/Types.hs @@ -12,7 +12,9 @@ import Import data ScheduleEntry = ScheduleEntry { seCourse :: Entity Course -- TODO: just course?; TODO: Maybe? , seType :: ScheduleEntryType - , seRoom :: ScheduleEntryRoom + , seRooms :: [ScheduleEntryRoom] -- multiple rooms in case of multiple parallel exam occurrences, + -- no room in case of no room info (Nothing) for tutorials + -- TODO: encode in ScheduleEntryType instead , seOccurrence :: ScheduleEntryOccurrence } deriving (Generic, Typeable) @@ -26,7 +28,7 @@ data ScheduleEntryType = SETCourseEvent { setceType :: CI Text } deriving (Eq, Ord, Show, Read, Generic, Typeable) -type ScheduleEntryRoom = Maybe Text -- TODO: is Maybe Text okay for every ScheduleEntryType? +type ScheduleEntryRoom = Text -- TODO: maybe introduce sum new type instead type ScheduleEntryOccurrence = Either ScheduleEntryExamOccurrence (Either OccurrenceException OccurrenceSchedule) diff --git a/src/Utils/Schedule/Week.hs b/src/Utils/Schedule/Week.hs index 1577a3276..947269f46 100644 --- a/src/Utils/Schedule/Week.hs +++ b/src/Utils/Schedule/Week.hs @@ -76,7 +76,7 @@ weekSchedule uid dayOffset = do courseEventToScheduleEntries :: (Entity Course, Entity CourseEvent) -> [ScheduleEntry] courseEventToScheduleEntries (seCourse@(Entity _ Course{..}), Entity _ CourseEvent{courseEventType,courseEventRoom,courseEventTime=Occurrences{..}}) = let seType = SETCourseEvent { setceType = courseEventType } - seRoom = Just courseEventRoom + seRooms = pure $ courseEventRoom scheduleds -- omit regular occurrences if the course's term is not currently active | not (courseTerm `elem` (E.unValue <$> activeTerms)) = mempty @@ -89,7 +89,7 @@ weekSchedule uid dayOffset = do tutorialToScheduleEntries :: (Entity Course, Entity Tutorial) -> [ScheduleEntry] tutorialToScheduleEntries (seCourse@(Entity _ Course{..}), Entity _ Tutorial{tutorialType,tutorialName,tutorialRoom,tutorialTime=Occurrences{..}}) = let seType = SETTutorial { settType = tutorialType, settName = tutorialName } - seRoom = tutorialRoom + seRooms = maybe mempty pure tutorialRoom scheduleds -- omit regular occurrences if the course's term is not currently active | not (courseTerm `elem` (E.unValue <$> activeTerms)) = mempty @@ -99,15 +99,26 @@ weekSchedule uid dayOffset = do let seOccurrence = Right (Left exception) in ScheduleEntry{..} in scheduleds <> exceptions - examOccurrenceToScheduleEntry :: (Entity Course, Entity Exam, Entity ExamOccurrence) -> ScheduleEntry - examOccurrenceToScheduleEntry (seCourse@(Entity _ Course{}), Entity _ Exam{..}, Entity _ ExamOccurrence{..}) = - let seType = SETExamOccurrence + -- TODO: introduce type synonym for (Entity Course, Entity Exam, Entity ExamOccurrence)? + joinParallelExamOccurrences :: [(Entity Course, Entity Exam, Entity ExamOccurrence)] -> [(Entity Course, Entity Exam, NonEmpty (Entity ExamOccurrence))] + 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') = + cid == cid' && eid == eid' + && examOccurrenceStart occ == examOccurrenceStart occ' && examOccurrenceEnd occ == examOccurrenceEnd occ' + + examOccurrenceToScheduleEntry :: (Entity Course, Entity Exam, NonEmpty (Entity ExamOccurrence)) -> ScheduleEntry + examOccurrenceToScheduleEntry (seCourse@(Entity _ Course{}), Entity _ Exam{..}, examOccs@((Entity _ occ):|_)) = + let seType = SETExamOccurrence { seteoExamName = examName } - seRoom = Just examOccurrenceRoom - seOccurrence = Left $ ScheduleEntryExamOccurrence - { seeoStart = examOccurrenceStart - , seeoEnd = examOccurrenceEnd + seRooms = toList $ (examOccurrenceRoom . entityVal) <$> examOccs + seOccurrence = Left $ ScheduleEntryExamOccurrence -- multiple exam occurrences are joined on equality + { seeoStart = examOccurrenceStart occ -- of start and end, so taking the timstamps of the first + , seeoEnd = examOccurrenceEnd occ -- occurrence suffices } in ScheduleEntry{..} @@ -131,7 +142,7 @@ weekSchedule uid dayOffset = do , filter (seOccurrenceIsInSlot day slot . seOccurrence) $ join $ (courseEventToScheduleEntries <$> courseEvents) <> (tutorialToScheduleEntries <$> tutorials) - <> pure (examOccurrenceToScheduleEntry <$> examOccurrences) + <> pure (examOccurrenceToScheduleEntry <$> (joinParallelExamOccurrences examOccurrences)) ) ) diff --git a/templates/widgets/schedule/week.hamlet b/templates/widgets/schedule/week.hamlet index 06074ed0d..c9f690364 100644 --- a/templates/widgets/schedule/week.hamlet +++ b/templates/widgets/schedule/week.hamlet @@ -18,7 +18,7 @@ $newline never
$maybe dayEvents <- Map.lookup day events $maybe slotEvents <- Map.lookup slot dayEvents - $forall se@ScheduleEntry{seCourse=Entity _ Course{courseName},seType,seRoom,seOccurrence} <- slotEvents + $forall se@ScheduleEntry{seCourse=Entity _ Course{courseName},seType,seRooms,seOccurrence} <- slotEvents
#{CI.original courseName}: # @@ -32,7 +32,12 @@ $newline never #{seteoExamName} #
- $maybe room <- seRoom - _{MsgScheduleRoom}: #{room}
+ $case seRooms + $of [] + $of [room] + _{MsgScheduleRoom}: #{room} + $of rooms + _{MsgScheduleRooms}: #{intercalate ", " rooms} +
^{formatOccurrenceW seOccurrence}