diff --git a/models/courses.model b/models/courses.model index 708064a28..509a49d5f 100644 --- a/models/courses.model +++ b/models/courses.model @@ -4,7 +4,7 @@ DegreeCourse json -- for which degree programmes this course is appropriate fo terms StudyTermsId UniqueDegreeCourse course degree terms Course -- Information about a single course; contained info is always visible to all users - name (CI Text) + name CourseName description Html Maybe -- user-defined large Html, ought to contain module description linkExternal Text Maybe -- arbitrary user-defined url for external course page shorthand (CI Text) -- practical shorthand of course name, used for identification @@ -29,9 +29,9 @@ Course -- Information about a single course; contained info is always visible TermSchoolCourseName term school name -- name must be unique within school and semester deriving Generic CourseEvent - type (CI Text) + type CourseEventType course CourseId - room Text + room CourseEventRoom time Occurrences note Html Maybe lastChanged UTCTime default=now() diff --git a/models/exams.model b/models/exams.model index d89914768..bc51b17bb 100644 --- a/models/exams.model +++ b/models/exams.model @@ -29,7 +29,7 @@ ExamPart ExamOccurrence exam ExamId name ExamOccurrenceName - room Text + room ExamOccurrenceRoom capacity Natural start UTCTime end UTCTime Maybe @@ -66,4 +66,4 @@ ExamCorrector ExamPartCorrector part ExamPartId corrector ExamCorrectorId - UniqueExamPartCorrector part corrector \ No newline at end of file + UniqueExamPartCorrector part corrector diff --git a/models/tutorials.model b/models/tutorials.model index 6650f24ef..3eb2b3fc8 100644 --- a/models/tutorials.model +++ b/models/tutorials.model @@ -1,7 +1,7 @@ Tutorial json name TutorialName course CourseId - type (CI Text) -- "Tutorium", "Zentralübung", ... + type TutorialType -- "Tutorium", "Zentralübung", ... capacity Int Maybe -- limit for enrolment in this tutorial room Text Maybe time Occurrences @@ -20,4 +20,4 @@ Tutor TutorialParticipant tutorial TutorialId user UserId - UniqueTutorialParticipant tutorial user \ No newline at end of file + UniqueTutorialParticipant tutorial user diff --git a/src/Model/Types/Common.hs b/src/Model/Types/Common.hs index ceb97f2a2..d7dd3ab56 100644 --- a/src/Model/Types/Common.hs +++ b/src/Model/Types/Common.hs @@ -36,14 +36,18 @@ type SchoolName = CI Text type SchoolShorthand = CI Text type CourseName = CI Text type CourseShorthand = CI Text +type CourseEventType = CI Text +type CourseEventRoom = Text type SheetName = CI Text type MaterialName = CI Text type UserEmail = CI Email type UserIdent = CI Text type TutorialName = CI Text +type TutorialType = CI Text type ExamName = CI Text type ExamPartName = CI Text type ExamOccurrenceName = CI Text +type ExamOccurrenceRoom = Text type AllocationName = CI Text type AllocationShorthand = CI Text diff --git a/src/Utils/Schedule/Types.hs b/src/Utils/Schedule/Types.hs index 9a55e2c7f..200444771 100644 --- a/src/Utils/Schedule/Types.hs +++ b/src/Utils/Schedule/Types.hs @@ -1,41 +1,28 @@ module Utils.Schedule.Types ( ScheduleEntry(..) - , ScheduleEntryType(..) - , ScheduleEntryRoom - , ScheduleEntryOccurrence - , ScheduleEntryExamOccurrence(..) ) where import Import -data ScheduleEntry = ScheduleEntry - { seCourse :: Entity Course -- TODO: just course?; TODO: Maybe? - , seType :: ScheduleEntryType - , seRooms :: [ScheduleEntryRoom] -- multiple rooms in case of multiple parallel exam occurrences, - -- no room in case of no room info (Nothing) for tutorials - -- TODO: encode in ScheduleEntryType instead - , 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 - } -- TODO: TutorialType not possible here (comes from data family instance) - | SETExamOccurrence { seteoExamName :: ExamName - } - deriving (Eq, Ord, Show, Read, Generic, Typeable) - -type ScheduleEntryRoom = Text - --- 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 - { seeoStart :: UTCTime - , seeoEnd :: Maybe UTCTime - } - deriving (Eq, Ord, Show, Read, Generic, Typeable) +data ScheduleEntry = ScheduleCourseEvent + { sceCourse :: Entity Course -- TODO: just course? + , sceType :: CourseEventType + , sceRoom :: CourseEventRoom + , sceOccurrence :: Either OccurrenceException OccurrenceSchedule + } + | ScheduleTutorial + { stCourse :: Entity Course + , stName :: TutorialName + , stType :: TutorialType + , stRoom :: Maybe Text -- TODO: introduce TutorialRoom type synonym + , stOccurrence :: Either OccurrenceException OccurrenceSchedule + } + | ScheduleExamOccurrence + { seoCourse :: Entity Course + , seoExamName :: ExamName + , seoRooms :: NonEmpty ExamOccurrenceRoom + , seoStart :: UTCTime + , seoEnd :: Maybe UTCTime + } + deriving (Generic, Typeable) diff --git a/src/Utils/Schedule/Week.hs b/src/Utils/Schedule/Week.hs index 947269f46..189c5a9c1 100644 --- a/src/Utils/Schedule/Week.hs +++ b/src/Utils/Schedule/Week.hs @@ -26,6 +26,8 @@ weekSchedule uid dayOffset = do tz <- liftIO getCurrentTimeZone ata <- getSessionActiveAuthTags + let dayNowOffset = fromMaybe 0 dayOffset `addDays` utctDay now + -- TODO: single runDB for all fetches below? activeTerms <- liftHandler . runDB $ E.select $ E.from $ \term -> do @@ -59,7 +61,6 @@ weekSchedule uid dayOffset = do return (course, tutorial) -- TODO: this makes the exam table partly redundant => maybe remove? - -- TODO: for lecturers, do not display one entry for each exam occurrences, but instead collect all occurrences happening at the same time in a list examOccurrences <- liftHandler . runDB $ E.select $ E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examOccurrence) -> do E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse E.on $ exam E.^. ExamId E.==. examOccurrence E.^. ExamOccurrenceExam @@ -74,29 +75,25 @@ weekSchedule uid dayOffset = do let courseEventToScheduleEntries :: (Entity Course, Entity CourseEvent) -> [ScheduleEntry] - courseEventToScheduleEntries (seCourse@(Entity _ Course{..}), Entity _ CourseEvent{courseEventType,courseEventRoom,courseEventTime=Occurrences{..}}) = - let seType = SETCourseEvent { setceType = courseEventType } - seRooms = pure $ courseEventRoom - scheduleds - -- omit regular occurrences if the course's term is not currently active + 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 seOccurrence = Right (Right scheduled) in ScheduleEntry{..} + | otherwise = Set.toList occurrencesScheduled <&> \scheduled -> + let sceOccurrence = Right scheduled in ScheduleCourseEvent{..} exceptions = Set.toList occurrencesExceptions <&> \exception -> - let seOccurrence = Right (Left exception) in ScheduleEntry{..} + let sceOccurrence = Left exception in ScheduleCourseEvent{..} 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 } - seRooms = maybe mempty pure tutorialRoom - scheduleds - -- omit regular occurrences if the course's term is not currently active + 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 seOccurrence = Right (Right scheduled) in ScheduleEntry{..} + let stOccurrence = Right scheduled in ScheduleTutorial{..} exceptions = Set.toList occurrencesExceptions <&> \exception -> - let seOccurrence = Right (Left exception) in ScheduleEntry{..} + let stOccurrence = Left exception in ScheduleTutorial{..} in scheduleds <> exceptions -- TODO: introduce type synonym for (Entity Course, Entity Exam, Entity ExamOccurrence)? @@ -111,58 +108,68 @@ weekSchedule uid dayOffset = do && examOccurrenceStart occ == examOccurrenceStart occ' && examOccurrenceEnd occ == examOccurrenceEnd occ' examOccurrenceToScheduleEntry :: (Entity Course, Entity Exam, NonEmpty (Entity ExamOccurrence)) -> ScheduleEntry - examOccurrenceToScheduleEntry (seCourse@(Entity _ Course{}), Entity _ Exam{..}, examOccs@((Entity _ occ):|_)) = - let seType = SETExamOccurrence - { seteoExamName = examName - } - seRooms = toList $ (examOccurrenceRoom . entityVal) <$> examOccs - seOccurrence = Left $ ScheduleEntryExamOccurrence -- multiple exam occurrences are joined on equality - { seeoStart = examOccurrenceStart occ -- of start and end, so taking the timstamps of the first - , seeoEnd = examOccurrenceEnd occ -- occurrence suffices - } - in 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{..} - seOccurrenceIsInSlot :: Day -> TimeSlot -> ScheduleEntryOccurrence -> Bool - seOccurrenceIsInSlot day slot = \case - Right occurrence -> occDay == day && occTime `isInTimeSlot` slot where - (occDay,occTime) = case occurrence of - Right ScheduleWeekly{..} -> (scheduleDayOfWeek `dayOfWeekToDayWith` now, scheduleStart) - Left ExceptOccur{..} -> (exceptDay, exceptStart) - Left ExceptNoOccur{exceptTime=LocalTime{..}} -> (localDay, localTimeOfDay) - Left ScheduleEntryExamOccurrence{..} -> let slotUTCTime = timeSlotToUTCTime tz day slot - nextSlotUTCTime = timeSlotToUTCTime tz day (slot+slotStep) - in slotUTCTime <= seeoStart - && seeoStart < nextSlotUTCTime + 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 = timeSlotToUTCTime tz day slot + nextSlotTime = timeSlotToUTCTime tz day (slot+slotStep) + in slotTime <= seoStart + && seoStart < nextSlotTime - events' :: Map Day (Map Int [ScheduleEntry]) + events' :: Map Day (Map TimeSlot [ScheduleEntry]) events' = Map.fromList $ week <&> \day -> ( day , Map.fromList $ slotsToDisplay <&> \slot -> ( slot - , filter (seOccurrenceIsInSlot day slot . seOccurrence) $ join $ + , filter (seIsInSlot day slot) $ join $ (courseEventToScheduleEntries <$> courseEvents) <> (tutorialToScheduleEntries <$> tutorials) <> pure (examOccurrenceToScheduleEntry <$> (joinParallelExamOccurrences examOccurrences)) ) ) - events :: Map Day (Map Int [ScheduleEntry]) + 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 = \case - -- remove regular occurrences if there is a NoOccur exception for the occurrence of this week - ScheduleEntry{seOccurrence=Right (Right ScheduleWeekly{..})} -> - 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 - Right (Right ScheduleWeekly{..}) -> scheduleDayOfWeek `dayOfWeekToDayWith` now == localDay - && scheduleStart == localTimeOfDay - _ -> False - ) (seOccurrence <$> occurrencesInSlot) - _ -> True -- TODO: maybe filter out ExceptNoOccurs? (Should NoOccurs be displayed or not?) + 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) + -- 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) + 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: Internationalize default week start (and/or make configurable) @@ -181,27 +188,26 @@ weekSchedule uid dayOffset = do -- | To which route should each schedule entry link to? 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 +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 -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 selFormat seeoStart seeoEnd - where selFormat = bool SelFormatDateTime SelFormatTime $ maybe True ((utctDay seeoStart ==) . utctDay) seeoEnd +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 time (as UTCTime) -dayOfWeekToDayWith :: DayOfWeek -> UTCTime -> Day -dayOfWeekToDayWith weekDay = go . utctDay where +-- | Convert from DayOfWeek to Day of this week using the current day +dayOfWeekToDayWith :: DayOfWeek -> Day -> Day +dayOfWeekToDayWith weekDay = go where go day | weekDay' == weekDay = day | weekDay' > weekDay = go $ pred day | otherwise = go $ succ day diff --git a/templates/widgets/schedule/week.hamlet b/templates/widgets/schedule/week.hamlet index c9f690364..477482f01 100644 --- a/templates/widgets/schedule/week.hamlet +++ b/templates/widgets/schedule/week.hamlet @@ -18,26 +18,28 @@ $newline never
$maybe dayEvents <- Map.lookup day events $maybe slotEvents <- Map.lookup slot dayEvents - $forall se@ScheduleEntry{seCourse=Entity _ Course{courseName},seType,seRooms,seOccurrence} <- slotEvents - + $forall scheduleEntry <- slotEvents +
- #{CI.original courseName}: # - $case seType - $of SETCourseEvent{..} - #{CI.original setceType} - $of SETTutorial{..} - #{settName} # - (#{CI.original settType}) - $of SETExamOccurrence{..} - #{seteoExamName} # -
- - $case seRooms - $of [] - $of [room] - _{MsgScheduleRoom}: #{room} - $of rooms - _{MsgScheduleRooms}: #{intercalate ", " rooms} -
- - ^{formatOccurrenceW seOccurrence} + $case scheduleEntry + $of ScheduleCourseEvent{sceCourse=Entity _ Course{courseName},sceType,sceRoom,sceOccurrence} + #{CI.original courseName}: #{CI.original sceType}
+ _{MsgScheduleRoom}: #{sceRoom}
+ ^{formatEitherOccurrenceW sceOccurrence} + $of ScheduleTutorial{stCourse=Entity _ Course{courseName},stName,stType,stRoom,stOccurrence} + #{CI.original courseName}: #{stName} (#{CI.original stType})
+ _{MsgScheduleRoom}: #{stRoom}
+ ^{formatEitherOccurrenceW stOccurrence} + $of ScheduleExamOccurrence{seoCourse=Entity _ Course{courseName},seoExamName,seoRooms,seoStart,seoEnd} + #{CI.original courseName}: #{seoExamName}
+ $case toList seoRooms + $of [room] + _{MsgScheduleRoom}: #{room} + $of more + _{MsgScheduleRooms}: #{intercalate ", " more} +
+ _{MsgScheduleOccur}: # + $if Just (utctDay seoStart) == fmap utctDay seoEnd + ^{formatTimeRangeW SelFormatTime seoStart seoEnd} + $else + ^{formatTimeRangeW SelFormatDateTime seoStart seoEnd}