From 9b78a5be12368b0fec1b799725deb77446c95bd4 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel <> Date: Thu, 20 Aug 2020 17:08:30 +0200 Subject: [PATCH] feat(schedule): stubby display of course events --- messages/uniworx/de-de-formal.msg | 3 + messages/uniworx/en-eu.msg | 3 + src/Handler/News.hs | 2 +- src/Utils/Schedule.hs | 142 ++++++++++++++++--------- src/Utils/Schedule/Types.hs | 6 +- templates/widgets/schedule/week.hamlet | 15 +-- 6 files changed, 107 insertions(+), 64 deletions(-) diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 06a91d75c..771d30b1b 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -109,6 +109,9 @@ ScheduleTableHeadTime: Zeit ScheduleRoom: Raum ScheduleTime: Zeit +ScheduleOccur: Findet statt +ScheduleNoOccur: Findet nicht statt + ScheduleWeekDayMonday: Montag ScheduleWeekDayTuesday: Dienstag ScheduleWeekDayWednesday: Mittwoch diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 8ad7417ae..af5771ff4 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -109,6 +109,9 @@ ScheduleTableHeadTime: Time ScheduleRoom: Room ScheduleTime: Time +ScheduleOccur: Does occur +ScheduleNoOccur: Does not occur + ScheduleWeekDayMonday: Monday ScheduleWeekDayTuesday: Tuesday ScheduleWeekDayWednesday: Wednesday diff --git a/src/Handler/News.hs b/src/Handler/News.hs index 88aef9395..95473cb5b 100644 --- a/src/Handler/News.hs +++ b/src/Handler/News.hs @@ -89,7 +89,7 @@ newsSystemMessages = do -- TODO: persist default schedule in user settings, lookup default and choose schedule accordingly -- TODO: add action to switch schedule (replace widget) newsSchedule :: UserId -> Widget -newsSchedule = weekSchedule +newsSchedule = flip weekSchedule Nothing newsUpcomingSheets :: UserId -> Widget diff --git a/src/Utils/Schedule.hs b/src/Utils/Schedule.hs index 25cbfbc9c..06ed64a0f 100644 --- a/src/Utils/Schedule.hs +++ b/src/Utils/Schedule.hs @@ -6,11 +6,11 @@ import Import import qualified Data.CaseInsensitive as CI import qualified Data.Map as Map ---import qualified Data.Set as Set +import qualified Data.Set as Set import qualified Database.Esqueleto as E -import Handler.Utils.DateTime (formatTimeRangeW) +import Handler.Utils.DateTime (formatTimeRangeW, formatTimeW) import Utils.Schedule.Types import Utils.Course (mayViewCourse) @@ -30,18 +30,23 @@ slotToDisplayTime :: TimeSlot -> Widget slotToDisplayTime t = formatTimeRangeW SelFormatTime (TimeOfDay t 0 0) $ Just $ TimeOfDay (t + slotStep) 0 0 -weekSchedule :: UserId -> Widget -weekSchedule uid = do +-- TODO: implement weekOffset +weekSchedule :: UserId + -> Maybe Int -- weekOffset + -> Widget +weekSchedule uid _weekOffset = do now <- liftIO getCurrentTime ata <- getSessionActiveAuthTags - -- TODO: single runDB for every fetch below? + -- TODO: single runDB for all fetches below? + -- TODO: filter by activeTerm only for regular occurrences, i.e. not for exceptions -- TODO: fetch course events for this week only: - -- - for regular occurrences: check for active semester - -- - also fetch exceptions - courseEvents' <- liftHandler . runDB $ E.select $ E.from $ \(course `E.InnerJoin` courseEvent) -> do + 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 $ \term -> E.where_ $ + -- term E.^. TermId E.==. course E.^. CourseTerm + -- E.&&. term E.^. TermActive E.where_ $ (E.exists $ E.from $ \courseParticipant -> E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId E.&&. courseParticipant E.^. CourseParticipantUser E.==. E.val uid @@ -53,10 +58,12 @@ weekSchedule uid = do ) return (course, courseEvent) - -- TODO: fetch registered tutorials - -- TODO: also fetch tutorials with user as tutor + -- TODO: include in schedule _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 $ \term -> E.where_ $ + -- term E.^. TermId E.==. course E.^. CourseTerm + -- E.&&. term E.^. TermActive E.where_ $ (E.exists $ E.from $ \tutorialParticipant -> E.where_ $ tutorialParticipant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. E.val uid @@ -66,59 +73,92 @@ weekSchedule uid = do ) return (course, tutorial) - -- TODO: fetch exam occurrences for exam participants and lecturers - let _exams = [] + -- TODO: fetch exam occurrences for exam participants and lecturers? let - courseEventToScheduleEntry :: (Entity Course, Entity CourseEvent) -> ScheduleEntry - courseEventToScheduleEntry (seCourse, Entity _ CourseEvent{..}) = - let seType = SETCourseEvent { setceType = courseEventType } - seRoom = Just courseEventRoom - seOccurrences = courseEventTime - in ScheduleEntry{..} - - occursInSlot :: DayOfWeek -> TimeSlot -> ScheduleEntry -> Bool - occursInSlot day slot ScheduleEntry{seOccurrences=Occurrences{..}} = - isScheduledInSlot day slot occurrencesScheduled && not (exceptNotOccursInSlot day slot occurrencesExceptions) - || exceptOccursInSlot day slot occurrencesExceptions - - isScheduledInSlot :: DayOfWeek -> TimeSlot -> Set OccurrenceSchedule -> Bool - isScheduledInSlot _day _slot _schedules = False -- TODO - - exceptOccursInSlot :: DayOfWeek -> TimeSlot -> Set OccurrenceException -> Bool - exceptOccursInSlot _day _slot _exceptions = False -- TODO + courseEventToScheduleEntries :: (Entity Course, Entity CourseEvent) -> [ScheduleEntry] + courseEventToScheduleEntries (seCourse, Entity _ CourseEvent{courseEventType,courseEventRoom,courseEventTime=Occurrences{..}}) = + let seType = SETCourseEvent { setceType = courseEventType } + seRoom = Just courseEventRoom + scheduleds = Set.toList occurrencesScheduled <&> \scheduled -> + let seOccurrence = Right scheduled in ScheduleEntry{..} + exceptions = Set.toList occurrencesExceptions <&> \exception -> + let seOccurrence = Left exception in ScheduleEntry{..} + in scheduleds <> exceptions - exceptNotOccursInSlot :: DayOfWeek -> TimeSlot -> Set OccurrenceException -> Bool - exceptNotOccursInSlot _day _slot _exceptions = False -- TODO - - -- TODO: remove - --formatTimeRangeOccurrencesInSlotW :: Occurrences -> TimeSlot -> Widget - --formatTimeRangeOccurrencesInSlotW Occurrences{..} slot = - -- let (start,mEnd) | - -- in formatTimeRangeW SelFormatTime start mEnd + 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 - -- TODO: use NonEmpty ScheduleEntry instead of [ScheduleEntry] - courseEvents :: Map DayOfWeek (Map TimeSlot [ScheduleEntry]) - courseEvents = Map.fromList $ [Monday .. Sunday] <&> \day -> + courseEvents' :: Map Day (Map TimeSlot [ScheduleEntry]) + courseEvents' = Map.fromList $ currentWeek <&> \day -> ( day , Map.fromList $ slotsToDisplay <&> \slot -> ( slot - , flip filter (courseEventToScheduleEntry <$> courseEvents') $ occursInSlot day slot - -- \ScheduleEntry{seOccurrences} -> occursInSlot day slot seOccurrences - --seDayOfWeek == day && TimeOfDay slot 0 0 <= seStart && seStart < TimeOfDay (slot + slotStep) 0 0 + , filter (seOccurrenceIsInSlot day slot . seOccurrence) $ join $ courseEventToScheduleEntries <$> courseEvents'' ) ) + courseEvents :: Map Day (Map TimeSlot [ScheduleEntry]) + courseEvents = courseEvents' <&> \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)? - weekDays :: [(DayOfWeek,UniWorXMessage,Text)] - weekDays = [ (Monday , MsgScheduleWeekDayMonday , "mon") - , (Tuesday , MsgScheduleWeekDayTuesday , "tue") - , (Wednesday , MsgScheduleWeekDayWednesday , "wed") - , (Thursday , MsgScheduleWeekDayThursday , "thu") - , (Friday , MsgScheduleWeekDayFriday , "fri") - , (Saturday , MsgScheduleWeekDaySaturday , "sat") - , (Sunday , MsgScheduleWeekDaySunday , "sun") + 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 :: Either OccurrenceException OccurrenceSchedule -> Widget + formatOccurrenceW = \case + Right ScheduleWeekly{..} -> [whamlet| _{MsgScheduleTime}: |] <> formatTimeRangeW SelFormatTime scheduleStart (Just scheduleEnd) + Left ExceptOccur{..} -> [whamlet| _{MsgScheduleOccur}: |] <> formatTimeRangeW SelFormatDateTime (LocalTime exceptDay exceptStart) (Just (LocalTime exceptDay exceptEnd)) + Left ExceptNoOccur{exceptTime} -> [whamlet| _{MsgScheduleNoOccur}: |] <> formatTimeW SelFormatDateTime exceptTime + $(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/src/Utils/Schedule/Types.hs b/src/Utils/Schedule/Types.hs index 6a325b4c9..d847d3532 100644 --- a/src/Utils/Schedule/Types.hs +++ b/src/Utils/Schedule/Types.hs @@ -2,6 +2,7 @@ module Utils.Schedule.Types ( ScheduleEntry(..) , ScheduleEntryType(..) , ScheduleEntryRoom + , ScheduleEntryOccurrence ) where import Import @@ -11,7 +12,8 @@ data ScheduleEntry = ScheduleEntry { seCourse :: Entity Course -- TODO: just course?; TODO: Maybe? , seType :: ScheduleEntryType , seRoom :: ScheduleEntryRoom - , seOccurrences :: Occurrences -- TODO: will require converting exam occurrences to an ExceptOccur OccurrenceException + --, seOccurrences :: Occurrences -- TODO: will require converting exam occurrences to an ExceptOccur OccurrenceException + , seOccurrence :: ScheduleEntryOccurrence } data ScheduleEntryType = SETCourseEvent { setceType :: CI Text } -- TODO: CourseEventType not possible here (comes from data family instance) @@ -21,3 +23,5 @@ data ScheduleEntryType = SETCourseEvent { setceType :: CI Text } -- TOD deriving (Eq, Ord, Show, Read, Generic, Typeable) type ScheduleEntryRoom = Maybe Text -- TODO: is Maybe Text okay for every ScheduleEntryType? + +type ScheduleEntryOccurrence = Either OccurrenceException OccurrenceSchedule diff --git a/templates/widgets/schedule/week.hamlet b/templates/widgets/schedule/week.hamlet index 3db49b061..8f0952cd3 100644 --- a/templates/widgets/schedule/week.hamlet +++ b/templates/widgets/schedule/week.hamlet @@ -17,12 +17,12 @@ $newline never ^{slotToDisplayTime slot} - $forall (weekDay, _, _) <- weekDays + $forall (day, _, _) <- weekDays
- $maybe dayEvents <- Map.lookup weekDay courseEvents + $maybe dayEvents <- Map.lookup day courseEvents $maybe slotEvents <- Map.lookup slot dayEvents - $forall ScheduleEntry{seCourse=Entity _ Course{courseTerm,courseSchool,courseShorthand,courseName},seType,seRoom,seOccurrences=Occurrences{..}} <- slotEvents + $forall ScheduleEntry{seCourse=Entity _ Course{courseTerm,courseSchool,courseShorthand,courseName},seType,seRoom,seOccurrence} <- slotEvents
#{CI.original courseName}: # @@ -38,11 +38,4 @@ $newline never $maybe room <- seRoom _{MsgScheduleRoom}: #{room}
- _{MsgScheduleTime}: # - $if isScheduledInSlot weekDay slot occurrencesScheduled - $if exceptNotOccursInSlot weekDay slot occurrencesExceptions - TODO does not occur - $else - TODO scheduled - $elseif exceptOccursInSlot weekDay slot occurrencesExceptions - TODO except occurs + ^{formatOccurrenceW seOccurrence}