|
|
|
|
@ -11,13 +11,40 @@ import qualified Data.Set as Set
|
|
|
|
|
|
|
|
|
|
import qualified Database.Esqueleto as E
|
|
|
|
|
|
|
|
|
|
import Handler.Utils.DateTime (formatTimeRangeW, formatTimeW, utcToLocalTime)
|
|
|
|
|
import Handler.Utils.DateTime (formatTimeRangeW, formatTimeW, utcToLocalTime, localTimeToUTCSimple)
|
|
|
|
|
|
|
|
|
|
import Utils.Schedule
|
|
|
|
|
import Utils.Schedule.Types
|
|
|
|
|
import Utils.Schedule.Week.TimeSlot
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
data SlotAssociation
|
|
|
|
|
= SlotIntersects -- ^ Slot is true subset of event
|
|
|
|
|
| SlotEnds -- ^ Event ends in slot, but does not begin within
|
|
|
|
|
| SlotBegins -- ^ Event begins in slot, but does not end within
|
|
|
|
|
| SlotContained -- ^ Event starts and ends within slot
|
|
|
|
|
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
|
|
|
|
deriving anyclass (Universe, Finite)
|
|
|
|
|
nullaryPathPiece ''SlotAssociation $ camelToPathPiece' 1
|
|
|
|
|
|
|
|
|
|
_SlotAssociation :: Iso' SlotAssociation (Bool, Bool)
|
|
|
|
|
_SlotAssociation = iso toBools fromBools
|
|
|
|
|
where
|
|
|
|
|
toBools = \case
|
|
|
|
|
SlotIntersects -> (False, False)
|
|
|
|
|
SlotEnds -> (False, True )
|
|
|
|
|
SlotBegins -> (True, False)
|
|
|
|
|
SlotContained -> (True, True )
|
|
|
|
|
fromBools = \case
|
|
|
|
|
(False, False) -> SlotIntersects
|
|
|
|
|
(False, True ) -> SlotEnds
|
|
|
|
|
(True, False) -> SlotBegins
|
|
|
|
|
(True, True ) -> SlotContained
|
|
|
|
|
|
|
|
|
|
slotAssocIsCont :: SlotAssociation -> Bool
|
|
|
|
|
slotAssocIsCont = views (_SlotAssociation . _1) not
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
weekOffsets :: UTCTime -> Entity User -> ScheduleOffset -> [ScheduleOffset]
|
|
|
|
|
weekOffsets now user@(Entity _ User{userScheduleWeekDays = ScheduleWeekDays userScheduleWeekDays}) scheduleOffset
|
|
|
|
|
= nub [ ScheduleOffsetDays (-7)
|
|
|
|
|
@ -59,14 +86,13 @@ weekSchedule now user@(Entity uid User{userScheduleWeekDays = ScheduleWeekDays u
|
|
|
|
|
week = weekDays now user scheduleOffset
|
|
|
|
|
|
|
|
|
|
-- TODO: single runDB for all fetches below?
|
|
|
|
|
|
|
|
|
|
activeTerms <- liftHandler $ runDB fetchActiveTerms
|
|
|
|
|
|
|
|
|
|
-- TODO: fetch course events for this week only?
|
|
|
|
|
courseEvents <- liftHandler $ runDB $ fetchCourseEventsScheduleInfo (Just uid) ata now
|
|
|
|
|
tutorials <- liftHandler $ runDB $ fetchTutorialsScheduleInfo (Just uid) ata now
|
|
|
|
|
-- TODO: this makes the exam table partly redundant => maybe remove?
|
|
|
|
|
examOccurrences <- liftHandler . runDB $ fetchExamOccurrencesScheduleInfo (Just uid) ata now
|
|
|
|
|
(activeTerms, courseEvents, tutorials, examOccurrences) <- liftHandler . runDB $ (,,,)
|
|
|
|
|
<$> fetchActiveTerms
|
|
|
|
|
-- TODO: fetch course events for this week only?
|
|
|
|
|
<*> fetchCourseEventsScheduleInfo (Just uid) ata now
|
|
|
|
|
<*> fetchTutorialsScheduleInfo (Just uid) ata now
|
|
|
|
|
-- TODO: this makes the exam table partly redundant => maybe remove?
|
|
|
|
|
<*> fetchExamOccurrencesScheduleInfo (Just uid) ata now
|
|
|
|
|
|
|
|
|
|
let
|
|
|
|
|
courseEventToScheduleEntries :: ScheduleCourseEventInfo -> [ScheduleEntry]
|
|
|
|
|
@ -78,6 +104,7 @@ weekSchedule now user@(Entity uid User{userScheduleWeekDays = ScheduleWeekDays u
|
|
|
|
|
let sceOccurrence = Right scheduled in ScheduleCourseEvent{..}
|
|
|
|
|
exceptions = Set.toList occurrencesExceptions <&> \exception ->
|
|
|
|
|
let sceOccurrence = Left exception in ScheduleCourseEvent{..}
|
|
|
|
|
sceNoOccur = setOf (folded . _ExceptNoOccur) occurrencesExceptions
|
|
|
|
|
in scheduleds <> exceptions
|
|
|
|
|
|
|
|
|
|
tutorialToScheduleEntries :: ScheduleTutorialInfo -> [ScheduleEntry]
|
|
|
|
|
@ -89,6 +116,7 @@ weekSchedule now user@(Entity uid User{userScheduleWeekDays = ScheduleWeekDays u
|
|
|
|
|
let stOccurrence = Right scheduled in ScheduleTutorial{..}
|
|
|
|
|
exceptions = Set.toList occurrencesExceptions <&> \exception ->
|
|
|
|
|
let stOccurrence = Left exception in ScheduleTutorial{..}
|
|
|
|
|
stNoOccur = setOf (folded . _ExceptNoOccur) occurrencesExceptions
|
|
|
|
|
in scheduleds <> exceptions
|
|
|
|
|
|
|
|
|
|
-- TODO: introduce type synonym for (Entity Course, Entity Exam, Entity ExamOccurrence)?
|
|
|
|
|
@ -109,39 +137,40 @@ weekSchedule now user@(Entity uid User{userScheduleWeekDays = ScheduleWeekDays u
|
|
|
|
|
seoEnd = examOccurrenceEnd occ -- so taking the timestamps of the first occurrence suffices
|
|
|
|
|
in ScheduleExamOccurrence{..}
|
|
|
|
|
|
|
|
|
|
events'' :: Map Day (Map TimeSlot [ScheduleEntry])
|
|
|
|
|
events'' :: Map Day (Map TimeSlot [(ScheduleEntry, SlotAssociation)])
|
|
|
|
|
events'' = Map.fromList $ week <&> \d ->
|
|
|
|
|
( d
|
|
|
|
|
, Map.fromList $ allTimeSlots <&> \slot ->
|
|
|
|
|
( slot
|
|
|
|
|
, filter (seIsInSlot d slot) scheduleEntries
|
|
|
|
|
, mapMaybe (\entry -> (entry, ) <$> seIsInSlot d slot entry) scheduleEntries
|
|
|
|
|
)
|
|
|
|
|
) where
|
|
|
|
|
scheduleEntries = join $ (courseEventToScheduleEntries <$> courseEvents)
|
|
|
|
|
<> (tutorialToScheduleEntries <$> tutorials)
|
|
|
|
|
<> pure (examOccurrenceToScheduleEntry <$> (joinParallelExamOccurrences examOccurrences))
|
|
|
|
|
|
|
|
|
|
events' :: Map Day (Map TimeSlot [ScheduleEntry])
|
|
|
|
|
events' = events'' <&> \slotsPerDay -> slotsPerDay <&> \occurrencesInSlot ->
|
|
|
|
|
events' :: Map Day (Map TimeSlot [(ScheduleEntry, SlotAssociation)])
|
|
|
|
|
events' = flip imap events'' $ \currentDay 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?)
|
|
|
|
|
goPrune noOccurs = \case
|
|
|
|
|
Right ScheduleWeekly{..} -> flip none noOccurs $
|
|
|
|
|
\needle -> let localDay = scheduleDayOfWeek `dayOfWeekToDayWith` dayNowOffset
|
|
|
|
|
in LocalTime{ localDay, localTimeOfDay = scheduleStart } <= needle
|
|
|
|
|
&& needle <= LocalTime{ localDay, localTimeOfDay = scheduleEnd }
|
|
|
|
|
Left ExceptOccur{} -> True
|
|
|
|
|
-- remove NoOccur exceptions
|
|
|
|
|
Left ExceptNoOccur{} -> False
|
|
|
|
|
in \case
|
|
|
|
|
ScheduleCourseEvent{sceOccurrence} -> goPrune sceOccurrence
|
|
|
|
|
ScheduleTutorial{stOccurrence} -> goPrune stOccurrence
|
|
|
|
|
ScheduleCourseEvent{..} -> goPrune sceNoOccur sceOccurrence
|
|
|
|
|
ScheduleTutorial{..} -> goPrune stNoOccur stOccurrence
|
|
|
|
|
_ -> True
|
|
|
|
|
in filter isRegularWithoutException occurrencesInSlot
|
|
|
|
|
in sortOn (views _1 $ scheduleEntryToStart currentDay) $ filter (views _1 isRegularWithoutException) occurrencesInSlot
|
|
|
|
|
|
|
|
|
|
-- TODO: perform this filtering asap, in DB fetch if possible
|
|
|
|
|
events :: Map Day (Map TimeSlot [ScheduleEntry])
|
|
|
|
|
events :: Map Day (Map TimeSlot [(ScheduleEntry, SlotAssociation)])
|
|
|
|
|
events = Map.filterWithKey shouldBeDisplayedOrHasEvents events' where
|
|
|
|
|
shouldBeDisplayedOrHasEvents d entries = dayOfWeek d `elem` userScheduleWeekDays || any (not . null) entries
|
|
|
|
|
|
|
|
|
|
@ -161,33 +190,31 @@ weekSchedule now user@(Entity uid User{userScheduleWeekDays = ScheduleWeekDays u
|
|
|
|
|
-- Local helper functions
|
|
|
|
|
|
|
|
|
|
-- | Check whether a given ScheduleEntry lies in a given TimeSlot
|
|
|
|
|
seIsInSlot :: Day -> TimeSlot -> ScheduleEntry -> Bool
|
|
|
|
|
seIsInSlot 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
|
|
|
|
|
seIsInSlot :: Day -> TimeSlot -> ScheduleEntry -> Maybe SlotAssociation
|
|
|
|
|
seIsInSlot d slot = \case
|
|
|
|
|
ScheduleCourseEvent{sceOccurrence} -> occurrenceIsInSlot sceOccurrence
|
|
|
|
|
ScheduleTutorial{stOccurrence} -> occurrenceIsInSlot stOccurrence
|
|
|
|
|
ScheduleExamOccurrence{seoStart} -> let (slotTime,nextSlotTime) = timeSlotToUTCTime 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
|
|
|
|
|
ScheduleExamOccurrence{seoStart, seoEnd = Nothing}
|
|
|
|
|
-> let associated = slotBegin <= seoStart && seoStart < slotEnd
|
|
|
|
|
in guardOn associated SlotBegins
|
|
|
|
|
ScheduleExamOccurrence{seoStart, seoEnd = Just seoEnd}
|
|
|
|
|
-> let associated = seoEnd > slotBegin && seoStart < slotEnd
|
|
|
|
|
in guardOn associated $ _SlotAssociation # ( slotBegin <= seoStart && seoStart < slotEnd
|
|
|
|
|
, slotBegin <= seoEnd && seoEnd <= slotEnd
|
|
|
|
|
)
|
|
|
|
|
where
|
|
|
|
|
(slotBegin, slotEnd) = timeSlotToUTCTime d slot
|
|
|
|
|
occurrenceIsInSlot occurrence = guardOn associated $ _SlotAssociation # ( slotBegin <= occStart && occStart < slotEnd
|
|
|
|
|
, slotBegin <= occEnd && occEnd <= slotEnd
|
|
|
|
|
)
|
|
|
|
|
where
|
|
|
|
|
associated = occEnd > slotBegin && occStart < slotEnd
|
|
|
|
|
occStart = localTimeToUTCSimple $ LocalTime occDay occStartTime
|
|
|
|
|
occEnd = localTimeToUTCSimple $ LocalTime occDay occEndTime
|
|
|
|
|
(occDay, occStartTime, occEndTime) = case occurrence of
|
|
|
|
|
Right ScheduleWeekly{..} -> (scheduleDayOfWeek `dayOfWeekToDayWith` d, scheduleStart, scheduleEnd)
|
|
|
|
|
Left ExceptOccur{..} -> (exceptDay, exceptStart, exceptEnd)
|
|
|
|
|
Left ExceptNoOccur{exceptTime=LocalTime{..}} -> (localDay, localTimeOfDay, localTimeOfDay)
|
|
|
|
|
|
|
|
|
|
-- | To which route should each schedule entry link to?
|
|
|
|
|
scheduleEntryToHref :: ScheduleEntry -> Route UniWorX
|
|
|
|
|
@ -196,6 +223,17 @@ scheduleEntryToHref = \case
|
|
|
|
|
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
|
|
|
|
|
|
|
|
|
|
scheduleEntryToStart :: Day -> ScheduleEntry -> UTCTime
|
|
|
|
|
scheduleEntryToStart currentDay = \case
|
|
|
|
|
ScheduleCourseEvent{sceOccurrence} -> occurrenceToStart sceOccurrence
|
|
|
|
|
ScheduleTutorial{stOccurrence} -> occurrenceToStart stOccurrence
|
|
|
|
|
ScheduleExamOccurrence{seoStart} -> seoStart
|
|
|
|
|
where
|
|
|
|
|
occurrenceToStart = \case
|
|
|
|
|
Left ExceptOccur{exceptDay, exceptStart} -> localTimeToUTCSimple $ LocalTime exceptDay exceptStart
|
|
|
|
|
Left ExceptNoOccur{exceptTime} -> localTimeToUTCSimple exceptTime
|
|
|
|
|
Right ScheduleWeekly{scheduleStart} -> localTimeToUTCSimple $ LocalTime currentDay scheduleStart
|
|
|
|
|
|
|
|
|
|
-- | Calls formatTimeRangeW with the correct arguments and prepends an occurrence descriptor based on the occurrence type
|
|
|
|
|
formatEitherOccurrenceW :: Either OccurrenceException OccurrenceSchedule -> Widget
|
|
|
|
|
formatEitherOccurrenceW = \case
|
|
|
|
|
|
Gregor Kleen