diff --git a/frontend/src/app.sass b/frontend/src/app.sass index e8602a8e1..7c43f62b2 100644 --- a/frontend/src/app.sass +++ b/frontend/src/app.sass @@ -1427,8 +1427,22 @@ table.schedule background-color: var(--color-dark) color: white font-weight: 600 - border-radius: 15px padding: 10px + + &__ends + border-radius: 0 0 15px 15px + background: linear-gradient(0turn, var(--color-dark), var(--color-dark) calc(100% - 7px), rgba(0,0,0,0)) + &__begins + border-radius: 15px 15px 0 0 + background: linear-gradient(0.5turn, var(--color-dark), var(--color-dark) calc(100% - 7px), rgba(0,0,0,0)) + &__contained + border-radius: 15px + &__intersects + background: linear-gradient(0turn, rgba(0,0,0,0), var(--color-dark) 7px, var(--color-dark) calc(100% - 7px), rgba(0,0,0,0)) + + &__continuation + font-style: italic + a.schedule--entry-link text-decoration: none a.schedule--entry-link + a.schedule--entry-link > .schedule--entry diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index f6ae216c2..53e1a8b73 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -140,6 +140,8 @@ ScheduleOffsetWeekCurrent: Zu aktueller Woche springen ScheduleOffsetWeekForwardDays n@Int: #{n} #{pluralDE n "Tag" "Tage"} vorwärts ScheduleOffsetWeekForwardWeek: 1 Woche vorwärts +ScheduleWeekSlotIsCont: Forts. + ScheduleOptActions: Terminübersicht ScheduleOptOut: Deabonnieren ScheduleOptIn: Abonnieren diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index c1c50d80f..31f6a955b 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -141,6 +141,8 @@ ScheduleOffsetWeekCurrent: Jump to current week ScheduleOffsetWeekForwardDays n: #{n} #{pluralEN n "day" "days"} forward ScheduleOffsetWeekForwardWeek: 1 week forward +ScheduleWeekSlotIsCont: Cont. + ScheduleOptActions: Schedule ScheduleOptOut: Unsubscribe ScheduleOptIn: Subscribe diff --git a/src/Utils/Schedule/Types/ScheduleEntry.hs b/src/Utils/Schedule/Types/ScheduleEntry.hs index 0cb1b50a7..c52480d89 100644 --- a/src/Utils/Schedule/Types/ScheduleEntry.hs +++ b/src/Utils/Schedule/Types/ScheduleEntry.hs @@ -10,6 +10,7 @@ data ScheduleEntry = ScheduleCourseEvent , sceType :: CourseEventType , sceRoom :: CourseEventRoom , sceOccurrence :: Either OccurrenceException OccurrenceSchedule + , sceNoOccur :: Set LocalTime } | ScheduleTutorial { stCourse :: Entity Course @@ -17,6 +18,7 @@ data ScheduleEntry = ScheduleCourseEvent , stType :: TutorialType , stRoom :: Maybe Text -- TODO: introduce TutorialRoom type synonym , stOccurrence :: Either OccurrenceException OccurrenceSchedule + , stNoOccur :: Set LocalTime } | ScheduleExamOccurrence { seoCourse :: Entity Course diff --git a/src/Utils/Schedule/Week.hs b/src/Utils/Schedule/Week.hs index dd2bb463b..1d05f2783 100644 --- a/src/Utils/Schedule/Week.hs +++ b/src/Utils/Schedule/Week.hs @@ -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 diff --git a/templates/schedule/week.hamlet b/templates/schedule/week.hamlet index 1de8cff2e..8e101c1fe 100644 --- a/templates/schedule/week.hamlet +++ b/templates/schedule/week.hamlet @@ -20,20 +20,34 @@ $newline never $maybe slotEvents <- Map.lookup slot dayEvents
- $forall scheduleEntry <- slotEvents + $forall (scheduleEntry, slotAssociation) <- slotEvents -
+
$case scheduleEntry $of ScheduleCourseEvent{sceCourse=Entity _ Course{courseName},sceType,sceRoom,sceOccurrence} - #{CI.original courseName}: #{CI.original sceType}
- _{MsgScheduleRoom}: #{sceRoom}
+ #{CI.original courseName}: #{CI.original sceType} # + $if slotAssocIsCont slotAssociation + (_{MsgScheduleWeekSlotIsCont}) +
+ _{MsgScheduleRoom}: #{sceRoom} +
^{formatEitherOccurrenceW sceOccurrence} $of ScheduleTutorial{stCourse=Entity _ Course{courseName},stName,stType,stRoom,stOccurrence} - #{CI.original courseName}: #{stName} (#{CI.original stType})
- _{MsgScheduleRoom}: #{stRoom}
+ #{CI.original courseName}: #{stName} # + ( + #{CI.original stType} + $if slotAssocIsCont slotAssociation + , _{MsgScheduleWeekSlotIsCont} + ) +
+ _{MsgScheduleRoom}: #{stRoom} +
^{formatEitherOccurrenceW stOccurrence} $of ScheduleExamOccurrence{seoCourse=Entity _ Course{courseName},seoExamName,seoRooms,seoStart,seoEnd} - #{CI.original courseName}: #{seoExamName}
+ #{CI.original courseName}: #{seoExamName} + $if slotAssocIsCont slotAssociation + (_{MsgScheduleWeekSlotIsCont}) +
$case toList seoRooms $of [room] _{MsgScheduleRoom}: #{room}