refactor(schedule-week): refactor types and reorganize
This commit is contained in:
Sarah Vaupel
parent
78de1d56ae
commit
798a0811b7
@ -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?
|
||||
|
||||
@ -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
|
||||
|
||||
Reference in New Issue
Block a user