193 lines
9.9 KiB
Haskell
193 lines
9.9 KiB
Haskell
module Utils.Schedule.Week
|
|
( weekSchedule
|
|
) where
|
|
|
|
import Import
|
|
|
|
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)
|
|
|
|
import Utils.Schedule
|
|
import Utils.Schedule.Types
|
|
import Utils.Schedule.Week.TimeSlot
|
|
|
|
|
|
weekSchedule :: Entity User -> ScheduleOffset -> Widget
|
|
weekSchedule (Entity uid User{userWeekStart}) scheduleOffset = do
|
|
now <- liftIO getCurrentTime
|
|
tz <- liftIO getCurrentTimeZone
|
|
ata <- getSessionActiveAuthTags
|
|
|
|
let
|
|
dayOffset = case scheduleOffset of
|
|
ScheduleOffsetNone -> 0
|
|
ScheduleOffsetDays d -> d
|
|
dayNowOffset = toInteger dayOffset `addDays` utctDay now
|
|
|
|
-- TODO: single runDB for all fetches below?
|
|
|
|
activeTerms <- liftHandler $ runDB fetchActiveTerms
|
|
|
|
-- TODO: fetch course events for this week only?
|
|
courseEvents <- liftHandler $ runDB $ fetchCourseEvents (Just uid) ata now
|
|
tutorials <- liftHandler $ runDB $ fetchTutorials (Just uid) ata now
|
|
-- TODO: this makes the exam table partly redundant => maybe remove?
|
|
examOccurrences <- liftHandler . runDB $ fetchExamOccurrences (Just uid) ata now
|
|
|
|
let
|
|
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
|
|
| not (courseTerm `elem` (E.unValue <$> activeTerms)) = mempty
|
|
| otherwise = Set.toList occurrencesScheduled <&> \scheduled ->
|
|
let sceOccurrence = Right scheduled in ScheduleCourseEvent{..}
|
|
exceptions = Set.toList occurrencesExceptions <&> \exception ->
|
|
let sceOccurrence = Left exception in ScheduleCourseEvent{..}
|
|
in scheduleds <> exceptions
|
|
|
|
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
|
|
| not (courseTerm `elem` (E.unValue <$> activeTerms)) = mempty
|
|
| otherwise = Set.toList occurrencesScheduled <&> \scheduled ->
|
|
let stOccurrence = Right scheduled in ScheduleTutorial{..}
|
|
exceptions = Set.toList occurrencesExceptions <&> \exception ->
|
|
let stOccurrence = Left exception in ScheduleTutorial{..}
|
|
in scheduleds <> exceptions
|
|
|
|
-- TODO: introduce type synonym for (Entity Course, Entity Exam, Entity ExamOccurrence)?
|
|
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') =
|
|
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
|
|
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{..}
|
|
|
|
events' :: Map Day (Map TimeSlot [ScheduleEntry])
|
|
events' = Map.fromList $ week <&> \d ->
|
|
( d
|
|
, Map.fromList $ allTimeSlots <&> \slot ->
|
|
( slot
|
|
, filter (seIsInSlot tz d slot) scheduleEntries
|
|
)
|
|
) where
|
|
scheduleEntries = join $ (courseEventToScheduleEntries <$> courseEvents)
|
|
<> (tutorialToScheduleEntries <$> tutorials)
|
|
<> pure (examOccurrenceToScheduleEntry <$> (joinParallelExamOccurrences examOccurrences))
|
|
|
|
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` (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
|
|
) (catMaybes $ scheduleEntryToRegular <$> occurrencesInSlot)
|
|
goPrune _ = True -- TODO: maybe filter NoOccur exceptions in general? (Should NoOccur exceptions be displayed?)
|
|
in \case
|
|
ScheduleCourseEvent{sceOccurrence} -> goPrune sceOccurrence
|
|
ScheduleTutorial{stOccurrence} -> goPrune stOccurrence
|
|
_ -> True
|
|
in filter isRegularWithoutException occurrencesInSlot
|
|
|
|
-- TODO: auto-hide saturday and sunday (if there are no events scheduled)?
|
|
week :: [Day]
|
|
week = go dayNowOffset
|
|
where go d
|
|
| dayOfWeek d == firstDay = [d .. toEnum (fromEnum d + 6)]
|
|
| otherwise = go $ pred d
|
|
firstDay = toEnum $ fromEnum userWeekStart + dayOffset
|
|
|
|
-- TODO: make this configurable
|
|
timeSlotsDefaultDisplay :: Set TimeSlot
|
|
timeSlotsDefaultDisplay = Set.fromList $ timeSlotsFromTo 8 18
|
|
|
|
allTimeSlots :: [TimeSlot]
|
|
allTimeSlots = timeSlotsFromTo 0 22
|
|
|
|
timeSlotIsEmpty :: TimeSlot -> Bool
|
|
timeSlotIsEmpty slot = foldr (\d acc -> acc && maybe True null (d Map.!? slot)) True events
|
|
|
|
$(widgetFile "schedule/week")
|
|
|
|
|
|
-- Local helper functions
|
|
|
|
-- | Check whether a given ScheduleEntry lies in a given TimeSlot
|
|
seIsInSlot :: TimeZone -> Day -> TimeSlot -> ScheduleEntry -> Bool
|
|
seIsInSlot tz d slot =
|
|
let occurrenceIsInSlot occurrence = occDay == d && occTime `isInTimeSlot` slot where
|
|
(occDay, occTime) = case occurrence of
|
|
Right ScheduleWeekly{..} -> (scheduleDayOfWeek `dayOfWeekToDayWith` d, 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 d 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
|
|
ScheduleCourseEvent{sceCourse=(Entity _ Course{..})} -> CourseR courseTerm courseSchool courseShorthand CShowR -- TODO: link to events table? (currently has no id)
|
|
ScheduleTutorial{stCourse=(Entity _ Course{..})} -> CourseR courseTerm courseSchool courseShorthand CShowR -- TODO: link to table with id "tutorials"?
|
|
ScheduleExamOccurrence{seoCourse=(Entity _ Course{..}),seoExamName} -> CExamR courseTerm courseSchool courseShorthand seoExamName EShowR
|
|
|
|
-- | Calls formatTimeRangeW with the correct arguments and prepends an occurrence descriptor based on the occurrence type
|
|
formatEitherOccurrenceW :: Either OccurrenceException OccurrenceSchedule -> Widget
|
|
formatEitherOccurrenceW = \case
|
|
Right ScheduleWeekly{..} -> [whamlet| _{MsgScheduleTime}: |] <> formatTimeRangeW SelFormatTime scheduleStart (Just scheduleEnd)
|
|
Left ExceptOccur{..} -> [whamlet| _{MsgScheduleOccur}: |] <> formatTimeRangeW SelFormatTime (LocalTime exceptDay exceptStart) (Just $ LocalTime exceptDay exceptEnd)
|
|
Left ExceptNoOccur{} -> [whamlet| _{MsgScheduleNoOccur} |] -- <> formatTimeW SelFormatDateTime exceptTime
|
|
|
|
-- | Uniquely identify each day as table head
|
|
-- | This avoids constantly hiding e.g. some DayOfWeek (which would interfere with day offsets)
|
|
dayTableHeadIdent :: Day -> Text
|
|
dayTableHeadIdent = tshow . toModifiedJulianDay
|
|
|
|
-- | Convert from DayOfWeek to Day of this week using the current day
|
|
dayOfWeekToDayWith :: DayOfWeek -> Day -> Day
|
|
dayOfWeekToDayWith weekDay = go where
|
|
go d | weekDay' == weekDay = d
|
|
| weekDay' > weekDay = go $ pred d
|
|
| otherwise = go $ succ d
|
|
where weekDay' = dayOfWeek d
|