From 3416e63f6fb07a40e1aab7005860ab867d6571a3 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel <> Date: Thu, 20 Aug 2020 22:27:59 +0200 Subject: [PATCH] feat(schedule): include exam occurrences (WIP) --- src/Utils/Schedule.hs | 183 +-------------- src/Utils/Schedule/Types.hs | 24 +- src/Utils/Schedule/Week.hs | 214 ++++++++++++++++++ .../occurrence/cell/except-no-occurr.hamlet | 2 - .../occurrence/cell/except-occurr.hamlet | 2 - templates/widgets/schedule/week.hamlet | 5 +- 6 files changed, 238 insertions(+), 192 deletions(-) create mode 100644 src/Utils/Schedule/Week.hs delete mode 100644 templates/widgets/occurrence/cell/except-no-occurr.hamlet delete mode 100644 templates/widgets/occurrence/cell/except-occurr.hamlet diff --git a/src/Utils/Schedule.hs b/src/Utils/Schedule.hs index c1fc1812b..7c21ef789 100644 --- a/src/Utils/Schedule.hs +++ b/src/Utils/Schedule.hs @@ -1,184 +1,5 @@ module Utils.Schedule - ( weekSchedule + ( module Utils.Schedule ) 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.Types -import Utils.Course (mayViewCourse) - - --- TODO: very temporary slot representation -type TimeSlot = Int -firstSlot, lastSlot, slotStep :: Int -firstSlot = 8 -lastSlot = 20 -slotStep = 2 - -slotsToDisplay :: [TimeSlot] -slotsToDisplay = [firstSlot,firstSlot+slotStep..lastSlot] - -slotToDisplayTime :: TimeSlot -> Widget -slotToDisplayTime t = formatTimeRangeW SelFormatTime (TimeOfDay t 0 0) $ Just $ TimeOfDay (t + slotStep) 0 0 - - --- TODO: implement weekOffset -weekSchedule :: UserId -> Maybe Int -> Widget -weekSchedule uid _weekOffset = do - now <- liftIO getCurrentTime - ata <- getSessionActiveAuthTags - - -- TODO: single runDB for all fetches below? - - activeTerms <- liftHandler . runDB $ E.select $ E.from $ \term -> do - E.where_ $ term E.^. TermActive - return $ term E.^. TermId - - -- TODO: fetch course events for this week only? - courseEvents <- liftHandler . runDB $ E.select $ E.from $ \(course `E.InnerJoin` courseEvent) -> do - E.on $ course E.^. CourseId E.==. courseEvent E.^. CourseEventCourse - E.where_ $ (E.exists $ E.from $ \courseParticipant -> E.where_ $ - courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId - E.&&. courseParticipant E.^. CourseParticipantUser E.==. E.val uid - E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive - E.&&. mayViewCourse (Just uid) ata now course Nothing - ) E.||. (E.exists $ E.from $ \lecturer -> E.where_ $ - lecturer E.^. LecturerCourse E.==. course E.^. CourseId - E.&&. lecturer E.^. LecturerUser E.==. E.val uid - ) - return (course, courseEvent) - - tutorials <- liftHandler . runDB $ E.select $ E.from $ \(course `E.InnerJoin` tutorial) -> do - E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse - E.where_ $ (E.exists $ E.from $ \tutorialParticipant -> E.where_ $ - tutorialParticipant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId - E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. E.val uid - ) E.||. (E.exists $ E.from $ \tutor -> E.where_ $ - tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId - E.&&. tutor E.^. TutorUser E.==. E.val uid - ) - return (course, tutorial) - - -- TODO: fetch exam occurrences for exam participants and lecturers? - - let - courseEventToScheduleEntries :: (Entity Course, Entity CourseEvent) -> [ScheduleEntry] - courseEventToScheduleEntries (seCourse@(Entity _ Course{..}), Entity _ CourseEvent{courseEventType,courseEventRoom,courseEventTime=Occurrences{..}}) = - let seType = SETCourseEvent { setceType = courseEventType } - seRoom = Just courseEventRoom - scheduleds - -- omit regular occurrences if the course's term is not currently active - | not (courseTerm `elem` (E.unValue <$> activeTerms)) = mempty - | otherwise = Set.toList occurrencesScheduled <&> \scheduled -> - let seOccurrence = Right scheduled in ScheduleEntry{..} - exceptions = Set.toList occurrencesExceptions <&> \exception -> - let seOccurrence = Left exception in ScheduleEntry{..} - in scheduleds <> exceptions - - 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 - scheduleds - -- omit regular occurrences if the course's term is not currently active - | not (courseTerm `elem` (E.unValue <$> activeTerms)) = mempty - | otherwise = Set.toList occurrencesScheduled <&> \scheduled -> - let seOccurrence = Right scheduled in ScheduleEntry{..} - exceptions = Set.toList occurrencesExceptions <&> \exception -> - let seOccurrence = Left exception in ScheduleEntry{..} - in scheduleds <> exceptions - - seOccurrenceIsInSlot :: Day -> TimeSlot -> ScheduleEntryOccurrence -> Bool - seOccurrenceIsInSlot day slot seOcc = - let - (day', start, _mEnd) = case seOcc of - Right ScheduleWeekly{..} -> (scheduleDayOfWeek `dayOfWeekToDayWith` now, scheduleStart, Just scheduleEnd) - Left ExceptOccur{..} -> (exceptDay, exceptStart, Just exceptEnd) - Left ExceptNoOccur{exceptTime=LocalTime{..}} -> (localDay, localTimeOfDay, Nothing) - in day == day' && TimeOfDay slot 0 0 <= start && start < TimeOfDay (slot+slotStep) 0 0 - - events' :: Map Day (Map TimeSlot [ScheduleEntry]) - events' = Map.fromList $ currentWeek <&> \day -> - ( day - , Map.fromList $ slotsToDisplay <&> \slot -> - ( slot - , filter (seOccurrenceIsInSlot day slot . seOccurrence) $ join $ - (courseEventToScheduleEntries <$> courseEvents) - <> (tutorialToScheduleEntries <$> tutorials) - -- TODO: incluse exams (maybe) - ) - ) - - events :: Map Day (Map TimeSlot [ScheduleEntry]) - events = events' <&> \slotsPerDay -> slotsPerDay <&> \occurrencesInSlot -> - let - isRegularWithoutException :: ScheduleEntry -> Bool - isRegularWithoutException = \case - -- remove regular occurrences if there is a NoOccur exception for the occurrence of this week - ScheduleEntry{seOccurrence=Right ScheduleWeekly{..}} -> - -- TODO: is equality on scheduleStart sane? - not $ Left (ExceptNoOccur $ LocalTime (scheduleDayOfWeek `dayOfWeekToDayWith` now) scheduleStart) - `elem` (seOccurrence <$> occurrencesInSlot) - -- remove NoOccur exceptions if there is no regular occurrence to override - ScheduleEntry{seOccurrence=Left ExceptNoOccur{exceptTime=LocalTime{..}}} -> - any (\case - -- TODO: is equality on scheduleStart sane? - Right ScheduleWeekly{..} -> scheduleDayOfWeek `dayOfWeekToDayWith` now == localDay - && scheduleStart == localTimeOfDay - _ -> False - ) (seOccurrence <$> occurrencesInSlot) - _ -> True -- TODO: maybe filter out ExceptNoOccurs? (Should NoOccurs be displayed or not?) - in filter isRegularWithoutException occurrencesInSlot - - currentWeek :: [Day] - currentWeek = currentWeekAux $ utctDay now - where currentWeekAux day - | Monday <- dayOfWeek day = [day .. toEnum (fromEnum day + 6)] - | otherwise = currentWeekAux $ pred day - - -- TODO: Internationalize week start (and/or make configurable) - -- TODO: auto-hide saturday and sunday (if there are no events scheduled)? - -- TODO: weekday messages deprecated / not used => remove - weekDays :: [(Day, UniWorXMessage, Text)] - weekDays = zipWith (\x (y,z) -> (x,y,z)) currentWeek - [ (MsgScheduleWeekDayMonday , "mon") - , (MsgScheduleWeekDayTuesday , "tue") - , (MsgScheduleWeekDayWednesday , "wed") - , (MsgScheduleWeekDayThursday , "thu") - , (MsgScheduleWeekDayFriday , "fri") - , (MsgScheduleWeekDaySaturday , "sat") - , (MsgScheduleWeekDaySunday , "sun") - ] - - formatOccurrenceW :: ScheduleEntryOccurrence -> Widget - formatOccurrenceW = \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 - - scheduleEntryToHref :: ScheduleEntry -> Route UniWorX - scheduleEntryToHref ScheduleEntry{seCourse=Entity _ Course{..},seType} = case seType of - SETCourseEvent{} -> CourseR courseTerm courseSchool courseShorthand CShowR -- TODO: link to events table? (TODO currently has no id) - SETTutorial{} -> CourseR courseTerm courseSchool courseShorthand CShowR -- TODO: link to table with id "tutorials"? - SETExam{..} -> CExamR courseTerm courseSchool courseShorthand seteName EShowR - - $(widgetFile "widgets/schedule/week") - - --- Helper functions for this module - --- | Convert from DayOfWeek to Day of this week using the current time (as UTCTime) -dayOfWeekToDayWith :: DayOfWeek -> UTCTime -> Day -dayOfWeekToDayWith weekDay = go . utctDay where - go day | weekDay' == weekDay = day - | weekDay' > weekDay = go $ pred day - | otherwise = go $ succ day - where weekDay' = dayOfWeek day +import Utils.Schedule.Week as Utils.Schedule diff --git a/src/Utils/Schedule/Types.hs b/src/Utils/Schedule/Types.hs index 1fc095fba..a77b68bb4 100644 --- a/src/Utils/Schedule/Types.hs +++ b/src/Utils/Schedule/Types.hs @@ -3,6 +3,7 @@ module Utils.Schedule.Types , ScheduleEntryType(..) , ScheduleEntryRoom , ScheduleEntryOccurrence + , ScheduleEntryExamOccurrence(..) ) where import Import @@ -14,15 +15,28 @@ data ScheduleEntry = ScheduleEntry , seRoom :: ScheduleEntryRoom , seOccurrence :: ScheduleEntryOccurrence } + deriving (Generic, Typeable) -data ScheduleEntryType = SETCourseEvent { setceType :: CI Text } -- TODO: CourseEventType not possible here (comes from data family instance) - | SETTutorial { settType :: CI Text - , settName :: TutorialName +data ScheduleEntryType = SETCourseEvent { setceType :: CI Text + } -- TODO: CourseEventType not possible here (comes from data family instance) + | SETTutorial { settType :: CI Text + , settName :: TutorialName } -- TODO: TutorialType not possible here (comes from data family instance) - | SETExam { seteName :: ExamName } + | SETExamOccurrence { seteoExamName :: ExamName + , seteoOccurrenceName :: ExamOccurrenceName + } -- TODO: more? deriving (Eq, Ord, Show, Read, Generic, Typeable) type ScheduleEntryRoom = Maybe Text -- TODO: is Maybe Text okay for every ScheduleEntryType? -type ScheduleEntryOccurrence = Either OccurrenceException OccurrenceSchedule +-- TODO: maybe introduce sum new type instead +type ScheduleEntryOccurrence = Either ScheduleEntryExamOccurrence (Either OccurrenceException OccurrenceSchedule) + +-- Similar to OccurrenceException, but with Maybe as end +data ScheduleEntryExamOccurrence = ScheduleEntryExamOccurrence + { seeoDay :: Day + , seeoStart :: TimeOfDay + , seeoEnd :: Maybe TimeOfDay + } + deriving (Eq, Ord, Show, Read, Generic, Typeable) diff --git a/src/Utils/Schedule/Week.hs b/src/Utils/Schedule/Week.hs new file mode 100644 index 000000000..827d5b52c --- /dev/null +++ b/src/Utils/Schedule/Week.hs @@ -0,0 +1,214 @@ +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.Types +import Utils.Course (mayViewCourse, isCourseLecturer) + + +-- TODO: very temporary slot representation +type TimeSlot = Int +firstSlot, lastSlot, slotStep :: Int +firstSlot = 8 +lastSlot = 20 +slotStep = 2 + +slotsToDisplay :: [TimeSlot] +slotsToDisplay = [firstSlot,firstSlot+slotStep..lastSlot] + +slotToDisplayTime :: TimeSlot -> Widget +slotToDisplayTime t = formatTimeRangeW SelFormatTime (TimeOfDay t 0 0) $ Just $ TimeOfDay (t + slotStep) 0 0 + + +-- TODO: implement weekOffset +weekSchedule :: UserId -> Maybe Int -> Widget +weekSchedule uid _weekOffset = do + now <- liftIO getCurrentTime + ata <- getSessionActiveAuthTags + + -- TODO: single runDB for all fetches below? + + activeTerms <- liftHandler . runDB $ E.select $ E.from $ \term -> do + E.where_ $ term E.^. TermActive + return $ term E.^. TermId + + -- TODO: fetch course events for this week only? + courseEvents <- liftHandler . runDB $ E.select $ E.from $ \(course `E.InnerJoin` courseEvent) -> do + E.on $ course E.^. CourseId E.==. courseEvent E.^. CourseEventCourse + E.where_ $ (E.exists $ E.from $ \courseParticipant -> E.where_ $ + courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId + E.&&. courseParticipant E.^. CourseParticipantUser E.==. E.val uid + E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive + E.&&. mayViewCourse (Just uid) ata now course Nothing -- should not be necessary, but let's be on the safe side + ) E.||. (E.exists $ E.from $ \lecturer -> E.where_ $ + lecturer E.^. LecturerCourse E.==. course E.^. CourseId + E.&&. lecturer E.^. LecturerUser E.==. E.val uid + ) + return (course, courseEvent) + + tutorials <- liftHandler . runDB $ E.select $ E.from $ \(course `E.InnerJoin` tutorial) -> do + E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse + E.where_ $ (E.exists $ E.from $ \tutorialParticipant -> E.where_ $ + tutorialParticipant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId + E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. E.val uid + E.&&. mayViewCourse (Just uid) ata now course Nothing -- should not be necessary, but let's be on the safe side + ) E.||. (E.exists $ E.from $ \tutor -> E.where_ $ + tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId + E.&&. tutor E.^. TutorUser E.==. E.val uid + ) + return (course, tutorial) + + -- TODO: this makes the exam table redundant once the weekOffset is implemented + -- TODO: check for exam visibility for participants! + exams <- liftHandler . runDB $ E.select $ E.from $ \(course `E.InnerJoin` (exam `E.InnerJoin` examOccurrence) `E.LeftOuterJoin` examRegistration) -> do + E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse + E.on $ exam E.^. ExamId E.==. examOccurrence E.^. ExamOccurrenceExam + E.on $ E.just (exam E.^. ExamId) E.==. examRegistration E.?. ExamRegistrationExam + E.where_ $ isCourseLecturer (Just uid) ata (course E.^. CourseId) + E.||. (examRegistration E.?. ExamRegistrationUser E.==. E.just (E.val uid) + E.&&. mayViewCourse (Just uid) ata now course Nothing) -- do NOT remove, this is actually necessary here! + -- (There can be exam participants that are + -- not enrolled, me thinks) + return (course, exam, examOccurrence, examRegistration) + + let + courseEventToScheduleEntries :: (Entity Course, Entity CourseEvent) -> [ScheduleEntry] + courseEventToScheduleEntries (seCourse@(Entity _ Course{..}), Entity _ CourseEvent{courseEventType,courseEventRoom,courseEventTime=Occurrences{..}}) = + let seType = SETCourseEvent { setceType = courseEventType } + seRoom = Just courseEventRoom + scheduleds + -- omit regular occurrences if the course's term is not currently active + | not (courseTerm `elem` (E.unValue <$> activeTerms)) = mempty + | otherwise = Set.toList occurrencesScheduled <&> \scheduled -> + let seOccurrence = Right (Right scheduled) in ScheduleEntry{..} + exceptions = Set.toList occurrencesExceptions <&> \exception -> + let seOccurrence = Right (Left exception) in ScheduleEntry{..} + in scheduleds <> exceptions + + 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 + scheduleds + -- omit regular occurrences if the course's term is not currently active + | not (courseTerm `elem` (E.unValue <$> activeTerms)) = mempty + | otherwise = Set.toList occurrencesScheduled <&> \scheduled -> + let seOccurrence = Right (Right scheduled) in ScheduleEntry{..} + exceptions = Set.toList occurrencesExceptions <&> \exception -> + let seOccurrence = Right (Left exception) in ScheduleEntry{..} + in scheduleds <> exceptions + + -- TODO: work in progress + -- TODO: maybe exam registration is not even necessary here => refactor select to exists check for registration + examToScheduleEntries :: (Entity Course, Entity Exam, Entity ExamOccurrence, Maybe (Entity ExamRegistration)) -> [ScheduleEntry] + examToScheduleEntries (seCourse@(Entity _ Course{}), Entity _ Exam{..}, Entity _ ExamOccurrence{..}, _mbExamRegistration) = + let seType = SETExamOccurrence + { seteoExamName = examName + , seteoOccurrenceName = examOccurrenceName + } + seRoom = Just examOccurrenceRoom + seOccurrence = Left $ ScheduleEntryExamOccurrence + { seeoDay = utctDay examOccurrenceStart + , seeoStart = timeToTimeOfDay $ utctDayTime examOccurrenceStart + , seeoEnd = (timeToTimeOfDay . utctDayTime) <$> examOccurrenceEnd + } + in pure $ ScheduleEntry{..} + + seOccurrenceIsInSlot :: Day -> TimeSlot -> ScheduleEntryOccurrence -> Bool + seOccurrenceIsInSlot day slot seOcc = + let + (day', start, _mEnd) = case seOcc of + Right (Right ScheduleWeekly{..}) -> (scheduleDayOfWeek `dayOfWeekToDayWith` now, scheduleStart, Just scheduleEnd) + Right (Left ExceptOccur{..}) -> (exceptDay, exceptStart, Just exceptEnd) + Right (Left ExceptNoOccur{exceptTime=LocalTime{..}}) -> (localDay, localTimeOfDay, Nothing) + Left ScheduleEntryExamOccurrence{..} -> (seeoDay, seeoStart, seeoEnd) + in day == day' && TimeOfDay slot 0 0 <= start && start < TimeOfDay (slot+slotStep) 0 0 + + events' :: Map Day (Map TimeSlot [ScheduleEntry]) + events' = Map.fromList $ currentWeek <&> \day -> + ( day + , Map.fromList $ slotsToDisplay <&> \slot -> + ( slot + , filter (seOccurrenceIsInSlot day slot . seOccurrence) $ join $ + (courseEventToScheduleEntries <$> courseEvents) + <> (tutorialToScheduleEntries <$> tutorials) + <> (examToScheduleEntries <$> exams) + ) + ) + + events :: Map Day (Map TimeSlot [ScheduleEntry]) + events = events' <&> \slotsPerDay -> slotsPerDay <&> \occurrencesInSlot -> + let + isRegularWithoutException :: ScheduleEntry -> Bool + isRegularWithoutException = \case + -- remove regular occurrences if there is a NoOccur exception for the occurrence of this week + ScheduleEntry{seOccurrence=Right (Right ScheduleWeekly{..})} -> + -- TODO: is equality on scheduleStart sane? + not $ Right (Left $ ExceptNoOccur $ LocalTime (scheduleDayOfWeek `dayOfWeekToDayWith` now) scheduleStart) + `elem` (seOccurrence <$> occurrencesInSlot) + -- remove NoOccur exceptions if there is no regular occurrence to override + ScheduleEntry{seOccurrence=Right (Left ExceptNoOccur{exceptTime=LocalTime{..}})} -> + any (\case + -- TODO: is equality on scheduleStart sane? + Right (Right ScheduleWeekly{..}) -> scheduleDayOfWeek `dayOfWeekToDayWith` now == localDay + && scheduleStart == localTimeOfDay + _ -> False + ) (seOccurrence <$> occurrencesInSlot) + _ -> True -- TODO: maybe filter out ExceptNoOccurs? (Should NoOccurs be displayed or not?) + in filter isRegularWithoutException occurrencesInSlot + + currentWeek :: [Day] + currentWeek = currentWeekAux $ utctDay now + where currentWeekAux day + | Monday <- dayOfWeek day = [day .. toEnum (fromEnum day + 6)] + | otherwise = currentWeekAux $ pred day + + -- TODO: Internationalize week start (and/or make configurable) + -- TODO: auto-hide saturday and sunday (if there are no events scheduled)? + -- TODO: weekday messages deprecated / not used => remove + weekDays :: [(Day, UniWorXMessage, Text)] + weekDays = zipWith (\x (y,z) -> (x,y,z)) currentWeek + [ (MsgScheduleWeekDayMonday , "mon") + , (MsgScheduleWeekDayTuesday , "tue") + , (MsgScheduleWeekDayWednesday , "wed") + , (MsgScheduleWeekDayThursday , "thu") + , (MsgScheduleWeekDayFriday , "fri") + , (MsgScheduleWeekDaySaturday , "sat") + , (MsgScheduleWeekDaySunday , "sun") + ] + + formatOccurrenceW :: ScheduleEntryOccurrence -> Widget + formatOccurrenceW = \case + Right (Right ScheduleWeekly{..}) -> [whamlet| _{MsgScheduleTime}: |] <> formatTimeRangeW SelFormatTime scheduleStart (Just scheduleEnd) + Right (Left ExceptOccur{..}) -> [whamlet| _{MsgScheduleOccur}: |] <> formatTimeRangeW SelFormatTime (LocalTime exceptDay exceptStart) (Just $ LocalTime exceptDay exceptEnd) + Right (Left ExceptNoOccur{}) -> [whamlet| _{MsgScheduleNoOccur} |] -- <> formatTimeW SelFormatDateTime exceptTime + Left ScheduleEntryExamOccurrence{..} -> [whamlet| _{MsgScheduleOccur}: |] <> formatTimeRangeW SelFormatTime (LocalTime seeoDay seeoStart) (LocalTime seeoDay <$> seeoEnd) + + scheduleEntryToHref :: ScheduleEntry -> Route UniWorX + scheduleEntryToHref ScheduleEntry{seCourse=Entity _ Course{..},seType} = case seType of + SETCourseEvent{} -> CourseR courseTerm courseSchool courseShorthand CShowR -- TODO: link to events table? (TODO currently has no id) + SETTutorial{} -> CourseR courseTerm courseSchool courseShorthand CShowR -- TODO: link to table with id "tutorials"? + SETExamOccurrence{..} -> CExamR courseTerm courseSchool courseShorthand seteoExamName EShowR + + $(widgetFile "widgets/schedule/week") + + +-- Helper functions for this module + +-- | Convert from DayOfWeek to Day of this week using the current time (as UTCTime) +dayOfWeekToDayWith :: DayOfWeek -> UTCTime -> Day +dayOfWeekToDayWith weekDay = go . utctDay where + go day | weekDay' == weekDay = day + | weekDay' > weekDay = go $ pred day + | otherwise = go $ succ day + where weekDay' = dayOfWeek day diff --git a/templates/widgets/occurrence/cell/except-no-occurr.hamlet b/templates/widgets/occurrence/cell/except-no-occurr.hamlet deleted file mode 100644 index 0019439a5..000000000 --- a/templates/widgets/occurrence/cell/except-no-occurr.hamlet +++ /dev/null @@ -1,2 +0,0 @@ -$newline never -_{MsgExceptionKindNoOccur}: #{exceptTime'} diff --git a/templates/widgets/occurrence/cell/except-occurr.hamlet b/templates/widgets/occurrence/cell/except-occurr.hamlet deleted file mode 100644 index 2d8147d8b..000000000 --- a/templates/widgets/occurrence/cell/except-occurr.hamlet +++ /dev/null @@ -1,2 +0,0 @@ -$newline never -_{MsgExceptionKindOccur}: #{exceptStart'}–#{exceptEnd'} diff --git a/templates/widgets/schedule/week.hamlet b/templates/widgets/schedule/week.hamlet index 06416ea60..a9d1a8582 100644 --- a/templates/widgets/schedule/week.hamlet +++ b/templates/widgets/schedule/week.hamlet @@ -28,8 +28,9 @@ $newline never $of SETTutorial{..} #{settName} # (#{CI.original settType}) - $of SETExam{..} - #{seteName} + $of SETExamOccurrence{..} + #{seteoExamName} # + (#{seteoOccurrenceName})
$maybe room <- seRoom