From 798a0811b70edd7720a63d8ebbc5394cd26477a9 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel <> Date: Mon, 24 Aug 2020 23:18:35 +0200 Subject: [PATCH] refactor(schedule-week): refactor types and reorganize --- src/Utils/Schedule/Types.hs | 11 ++++-- src/Utils/Schedule/Week.hs | 71 +++++++++++++++++++------------------ 2 files changed, 45 insertions(+), 37 deletions(-) diff --git a/src/Utils/Schedule/Types.hs b/src/Utils/Schedule/Types.hs index a8a3c549c..e3f50f581 100644 --- a/src/Utils/Schedule/Types.hs +++ b/src/Utils/Schedule/Types.hs @@ -1,5 +1,8 @@ module Utils.Schedule.Types - ( ScheduleCourseEventInfo, ScheduleTutorialInfo, ScheduleExamOccurrenceInfo + ( ScheduleCourseEventInfo + , ScheduleTutorialInfo + , ScheduleExamOccurrenceInfo + , ScheduleExamOccurrenceJoinedInfo , ScheduleEntry(..) ) where @@ -7,9 +10,11 @@ import Import type ScheduleCourseEventInfo = (Entity Course, Entity CourseEvent) -type ScheduleTutorialInfo = (Entity Course, Entity Tutorial) -type ScheduleExamOccurrenceInfo = (Entity Course, Entity Exam, Entity ExamOccurrence) +type ScheduleTutorialInfo = (Entity Course, Entity Tutorial) + +type ScheduleExamOccurrenceInfo = (Entity Course, Entity Exam, Entity ExamOccurrence) +type ScheduleExamOccurrenceJoinedInfo = (Entity Course, Entity Exam, NonEmpty (Entity ExamOccurrence)) data ScheduleEntry = ScheduleCourseEvent { sceCourse :: Entity Course -- TODO: just course? diff --git a/src/Utils/Schedule/Week.hs b/src/Utils/Schedule/Week.hs index 0b2ea543d..fd218a9e8 100644 --- a/src/Utils/Schedule/Week.hs +++ b/src/Utils/Schedule/Week.hs @@ -37,7 +37,7 @@ weekSchedule uid dayOffset = do examOccurrences <- liftHandler . runDB $ fetchExamOccurrences (Just uid) ata now let - courseEventToScheduleEntries :: (Entity Course, Entity CourseEvent) -> [ScheduleEntry] + courseEventToScheduleEntries :: ScheduleCourseEventInfo -> [ScheduleEntry] courseEventToScheduleEntries (sceCourse@(Entity _ Course{..}), Entity _ CourseEvent{courseEventType=sceType,courseEventRoom=sceRoom,courseEventTime=Occurrences{..}}) = let scheduleds -- omit regular occurrences if the course term is not currently active @@ -48,7 +48,7 @@ weekSchedule uid dayOffset = do let sceOccurrence = Left exception in ScheduleCourseEvent{..} in scheduleds <> exceptions - tutorialToScheduleEntries :: (Entity Course, Entity Tutorial) -> [ScheduleEntry] + tutorialToScheduleEntries :: ScheduleTutorialInfo -> [ScheduleEntry] tutorialToScheduleEntries (stCourse@(Entity _ Course{..}), Entity _ Tutorial{tutorialName=stName,tutorialType=stType,tutorialRoom=stRoom,tutorialTime=Occurrences{..}}) = let scheduleds -- omit regular occurrences if the course term is not currently active @@ -60,7 +60,7 @@ weekSchedule uid dayOffset = do in scheduleds <> exceptions -- 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 :: [ScheduleExamOccurrenceInfo] -> [ScheduleExamOccurrenceJoinedInfo] joinParallelExamOccurrences = go [] where go acc [] = acc go acc (examOcc@(course, exam, occ):examOccs) = @@ -70,63 +70,37 @@ weekSchedule uid dayOffset = do cid == cid' && eid == eid' && examOccurrenceStart occ == examOccurrenceStart occ' && examOccurrenceEnd occ == examOccurrenceEnd occ' - examOccurrenceToScheduleEntry :: (Entity Course, Entity Exam, NonEmpty (Entity ExamOccurrence)) -> ScheduleEntry + examOccurrenceToScheduleEntry :: ScheduleExamOccurrenceJoinedInfo -> ScheduleEntry examOccurrenceToScheduleEntry (seoCourse@(Entity _ Course{}), Entity _ Exam{examName=seoExamName}, examOccs@((Entity _ occ):|_)) = let seoRooms = (examOccurrenceRoom . entityVal) <$> 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{..} - seIsInSlot :: Day -> TimeSlot -> ScheduleEntry -> Bool - seIsInSlot day slot = - let occurrenceIsInSlot occurrence = occDay == day && occTime `isInTimeSlot` slot where - (occDay, occTime) = case occurrence of - Right ScheduleWeekly{..} -> (scheduleDayOfWeek `dayOfWeekToDayWith` dayNowOffset, scheduleStart) - Left ExceptOccur{..} -> (exceptDay, exceptStart) - Left ExceptNoOccur{exceptTime=LocalTime{..}} -> (localDay, localTimeOfDay) - in \case - ScheduleCourseEvent{sceOccurrence} -> occurrenceIsInSlot sceOccurrence - ScheduleTutorial{stOccurrence} -> occurrenceIsInSlot stOccurrence - ScheduleExamOccurrence{seoStart} -> let (slotTime,nextSlotTime) = timeSlotToUTCTime tz day slot - in slotTime <= seoStart - && seoStart < nextSlotTime - events' :: Map Day (Map TimeSlot [ScheduleEntry]) events' = Map.fromList $ week <&> \day -> ( day , Map.fromList $ timeSlotsToDisplay <&> \slot -> ( slot - , filter (seIsInSlot day slot) $ join $ + , filter (seIsInSlot tz day slot) $ join $ (courseEventToScheduleEntries <$> courseEvents) <> (tutorialToScheduleEntries <$> tutorials) <> pure (examOccurrenceToScheduleEntry <$> (joinParallelExamOccurrences examOccurrences)) ) ) - getRegulars :: [ScheduleEntry] -> [OccurrenceSchedule] - getRegulars = catMaybes . (goRegular <$>) where - goRegular ScheduleCourseEvent{sceOccurrence=Right schedule} = Just schedule - goRegular ScheduleTutorial{stOccurrence=Right schedule} = Just schedule - goRegular _ = Nothing - - getNoOccurs :: [ScheduleEntry] -> [OccurrenceException] - getNoOccurs = catMaybes . (goNoOccur <$>) where - goNoOccur ScheduleCourseEvent{sceOccurrence=Left noOccur} = Just noOccur - goNoOccur ScheduleTutorial{stOccurrence=Left noOccur} = Just noOccur - goNoOccur _ = Nothing - events :: Map Day (Map TimeSlot [ScheduleEntry]) events = events' <&> \slotsPerDay -> slotsPerDay <&> \occurrencesInSlot -> let isRegularWithoutException :: ScheduleEntry -> Bool isRegularWithoutException = let -- remove regular occurrences if there is a NoOccur exception for the occurrence of this week - goPrune (Right ScheduleWeekly{..}) = not $ ExceptNoOccur (LocalTime (scheduleDayOfWeek `dayOfWeekToDayWith` dayNowOffset) scheduleStart) `elem` (getNoOccurs occurrencesInSlot) + goPrune (Right ScheduleWeekly{..}) = not $ ExceptNoOccur (LocalTime (scheduleDayOfWeek `dayOfWeekToDayWith` dayNowOffset) scheduleStart) `elem` (catMaybes $ scheduleEntryToNoOccur <$> occurrencesInSlot) -- remove NoOccur exceptions if there is no regular occurrence to override goPrune (Left ExceptNoOccur{exceptTime=LocalTime{..}}) = any (\ScheduleWeekly{..} -> scheduleDayOfWeek `dayOfWeekToDayWith` dayNowOffset == localDay && scheduleStart == localTimeOfDay - ) (getRegulars occurrencesInSlot) + ) (catMaybes $ scheduleEntryToRegular <$> occurrencesInSlot) goPrune _ = True -- TODO: maybe filter NoOccur exceptions in general? (Should NoOccur exceptions be displayed?) in \case ScheduleCourseEvent{sceOccurrence} -> goPrune sceOccurrence @@ -143,7 +117,7 @@ weekSchedule uid dayOffset = do | otherwise = go $ pred day firstDay = toEnum $ fromEnum Monday + fromInteger (fromMaybe 0 dayOffset) - -- TODO: make configurable + -- TODO: make this configurable timeSlotsToDisplay :: [TimeSlot] timeSlotsToDisplay = timeSlot <$> [8,10..18] @@ -152,6 +126,35 @@ weekSchedule uid dayOffset = do -- Local helper functions +-- | Check whether a given ScheduleEntry lies in a given TimeSlot +seIsInSlot :: TimeZone -> Day -> TimeSlot -> ScheduleEntry -> Bool +seIsInSlot tz day slot = + let occurrenceIsInSlot occurrence = occDay == day && occTime `isInTimeSlot` slot where + (occDay, occTime) = case occurrence of + Right ScheduleWeekly{..} -> (scheduleDayOfWeek `dayOfWeekToDayWith` day, scheduleStart) + Left ExceptOccur{..} -> (exceptDay, exceptStart) + Left ExceptNoOccur{exceptTime=LocalTime{..}} -> (localDay, localTimeOfDay) + in \case + ScheduleCourseEvent{sceOccurrence} -> occurrenceIsInSlot sceOccurrence + ScheduleTutorial{stOccurrence} -> occurrenceIsInSlot stOccurrence + ScheduleExamOccurrence{seoStart} -> let (slotTime,nextSlotTime) = timeSlotToUTCTime tz day slot + in slotTime <= seoStart + && seoStart < nextSlotTime + +-- | Maybe get the OccurrenceSchedule of a given ScheduleEntry +scheduleEntryToRegular :: ScheduleEntry -> Maybe OccurrenceSchedule +scheduleEntryToRegular = \case + ScheduleCourseEvent{sceOccurrence=Right schedule} -> Just schedule + ScheduleTutorial{stOccurrence=Right schedule} -> Just schedule + _ -> Nothing + +-- | Maybe get an ExceptNoOccur OccurrenceException of a given ScheduleEntry +scheduleEntryToNoOccur :: ScheduleEntry -> Maybe OccurrenceException +scheduleEntryToNoOccur = \case + ScheduleCourseEvent{sceOccurrence=Left noOccur@ExceptNoOccur{}} -> Just noOccur + ScheduleTutorial{stOccurrence=Left noOccur@ExceptNoOccur{}} -> Just noOccur + _ -> Nothing + -- | To which route should each schedule entry link to? scheduleEntryToHref :: ScheduleEntry -> Route UniWorX scheduleEntryToHref = \case