-- SPDX-FileCopyrightText: 2022 Gregor Kleen -- -- SPDX-License-Identifier: AGPL-3.0-or-later module Handler.Utils.Occurrences ( LessonTime(..) , lessonTimeWidget, lessonTimesWidget , lessonTimesSpan , occurringLessons , occurrencesWidget , occurrencesCompute, occurrencesCompute' , occurrencesBounds , occurrencesAddBusinessDays ) where import Import import qualified Data.Set as Set import Utils.Holidays (isWeekend) import Utils.Occurrences import Handler.Utils.DateTime import Handler.Utils.Widgets (roomReferenceWidget) -- import Text.Read (read) -- for DEBUGGING only ---------------- -- LessonTime -- ---------------- -- -- Model time intervals to compute lecture/tutorial lessons more intuitively -- data LessonTime = LessonTime { lessonStart, lessonEnd :: LocalTime, lessonRoom :: Maybe RoomReference } deriving (Eq, Ord, Show, Generic, Binary) -- BEWARE: Ord instance might not be intuitive, but needed for Set occurringLessons :: Term -> Occurrences -> Set LessonTime occurringLessons term Occurrences{..} = Set.union exceptOcc $ Set.filter isExcept scheduledLessons where scheduledLessons = occurrenceScheduleToLessons term `foldMap` occurrencesScheduled (exceptOcc, exceptNo) = occurrenceExceptionToLessons occurrencesExceptions isExcept LessonTime{lessonStart} = Set.notMember lessonStart exceptNo occurrenceScheduleToLessons :: Term -> OccurrenceSchedule -> Set LessonTime occurrenceScheduleToLessons Term{..} = let setHolidays = Set.fromList termHolidays -- ensure that the conversion is performed only once for repeated calls in \ScheduleWeekly{..} -> let occDays = daysOfWeekBetween (termLectureStart, termLectureEnd) scheduleDayOfWeek \\ setHolidays toLesson d = LessonTime { lessonStart = LocalTime d scheduleStart , lessonEnd = LocalTime d scheduleEnd , lessonRoom = scheduleRoom } in Set.map toLesson occDays occurrenceExceptionToLessons :: Set OccurrenceException -> (Set LessonTime, Set LocalTime) occurrenceExceptionToLessons = Set.foldr aux mempty where aux ExceptOccur{..} (oc,no) = let t = LessonTime { lessonStart = LocalTime exceptDay exceptStart , lessonEnd = LocalTime exceptDay exceptEnd , lessonRoom = exceptRoom } in (Set.insert t oc,no) aux ExceptNoOccur{..} (oc,no) = (oc, Set.insert exceptTime no) lessonTimeWidget :: Bool -> LessonTime -> Widget lessonTimeWidget roomHidden LessonTime{..} = do lStart <- formatTime SelFormatTime lessonStart lEnd <- formatTime SelFormatTime lessonEnd $(widgetFile "widgets/lesson/single") lessonTimesWidget :: (Traversable t, MonoFoldable (t Widget)) => Bool -> t LessonTime -> Widget lessonTimesWidget roomHidden lessonsSet = do let lessons = lessonTimeWidget roomHidden <$> lessonsSet $(widgetFile "widgets/lesson/set") lessonTimesSpan :: Set LessonTime -> Maybe (Day, Day) lessonTimesSpan ls = comb (Set.lookupMin lDays, Set.lookupMax lDays) where lDays = Set.foldr accDay mempty ls accDay LessonTime{..} = Set.insert (localDay lessonStart) . Set.insert (localDay lessonEnd) comb (Just x, Just y) = Just (x,y) comb _ = Nothing ----------------- -- Occurrences -- ----------------- occurrencesWidget :: Bool -> JSONB Occurrences -> Widget occurrencesWidget roomHidden (normalizeOccurrences . unJSONB -> Occurrences{..}) = do let occurrencesScheduled' = flip map (Set.toList occurrencesScheduled) $ \case ScheduleWeekly{..} -> do scheduleStart' <- formatTime SelFormatTime scheduleStart scheduleEnd' <- formatTime SelFormatTime scheduleEnd $(widgetFile "widgets/occurrence/cell/weekly") occurrencesExceptions' = flip map (Set.toList occurrencesExceptions) $ \case ExceptOccur{..} -> do exceptStart' <- formatTime SelFormatDateTime (LocalTime exceptDay exceptStart) exceptEnd' <- formatTime SelFormatTime exceptEnd $(widgetFile "widgets/occurrence/cell/except-occur") ExceptNoOccur{..} -> do exceptTime' <- formatTime SelFormatDateTime exceptTime $(widgetFile "widgets/occurrence/cell/except-no-occur") $(widgetFile "widgets/occurrence/cell") -- | Get all days of occurrences during a term, excluding term holidays from the regular schedule, but not from do-occur exceptions occurrencesCompute :: Term -> Occurrences -> Set Day occurrencesCompute trm occ = Set.map (localDay . lessonStart) $ occurringLessons trm occ -- | Less precise versison of `occurrencesCompute`, which ignores TimeOfDay; might be faster, but could be wrong in some cases occurrencesCompute' :: Term -> Occurrences -> Set Day occurrencesCompute' Term{..} Occurrences{..} = ((scdDays \\ Set.fromList termHolidays) <> plsDays) \\ excDays where scdDays = Set.foldr getOccDays mempty occurrencesScheduled (plsDays,excDays) = Set.foldr getExcDays mempty occurrencesExceptions getExcDays :: OccurrenceException -> (Set Day, Set Day) -> (Set Day, Set Day) getExcDays ExceptNoOccur{exceptTime} (occ,exc) = (occ, Set.insert (localDay exceptTime) exc) getExcDays ExceptOccur{exceptDay} (occ,exc) = (Set.insert exceptDay occ, exc) getOccDays :: OccurrenceSchedule -> Set Day -> Set Day getOccDays ScheduleWeekly{scheduleDayOfWeek=wday} = Set.union $ daysOfWeekBetween (termLectureStart,termLectureEnd) wday -- | Get bounds for an Occurrences occurrencesBounds :: Term -> Occurrences -> (Maybe Day, Maybe Day) occurrencesBounds = (liftM2 (,) Set.lookupMin Set.lookupMax .) . occurrencesCompute occurrencesAddBusinessDays :: Term -> (Day,Day) -> Occurrences -> Occurrences occurrencesAddBusinessDays Term{..} (dayOld, dayNew) Occurrences{..} = Occurrences newSchedule newExceptions where newSchedule = Set.map switchDayOfWeek occurrencesScheduled dayDiff = diffDays dayNew dayOld offDays = Set.fromList $ termHolidays <> weekends weekends = [d | d <- [(min termLectureStart termStart)..(max termEnd termLectureEnd)], isWeekend d] switchDayOfWeek :: OccurrenceSchedule -> OccurrenceSchedule switchDayOfWeek os | 0 == dayDiff `mod` 7 = os switchDayOfWeek os@ScheduleWeekly{scheduleDayOfWeek=wday} = os{scheduleDayOfWeek= toEnum (fromIntegral dayDiff + fromEnum wday)} newExceptions = snd $ Set.foldl' advanceExceptions (dayDiff,mempty) occurrencesExceptions -- we assume that instance Ord OccurrenceException is ordered chronologically advanceExceptions :: (Integer, Set OccurrenceException) -> OccurrenceException -> (Integer, Set OccurrenceException) advanceExceptions (offset, acc) ex | ed `Set.notMember` offDays -- skip term-holidays and weekends, unless the original day was a holiday or weekend , nd `Set.member` offDays = advanceExceptions (succ offset, acc) ex | otherwise = (offset, Set.insert (setDayOfOccurrenceException nd ex) acc) where ed = dayOfOccurrenceException ex nd = addDays offset ed {- ----------- -- DEBUG -- ----------- theorieschulung :: Occurrences theorieschulung = Occurrences {occurrencesScheduled = Set.fromList [ScheduleWeekly {scheduleDayOfWeek = Thursday, scheduleStart = read "11:11:00", scheduleEnd = read "12:22:00"} ,ScheduleWeekly {scheduleDayOfWeek = Friday , scheduleStart = read "13:33:00", scheduleEnd = read "14:44:00"} ,ScheduleWeekly {scheduleDayOfWeek = Sunday , scheduleStart = read "15:55:00", scheduleEnd = read "16:06:00"} ] , occurrencesExceptions = Set.fromList [ExceptOccur {exceptDay = read "2024-01-07", exceptStart = read "08:30:00", exceptEnd = read "16:00:00"} ,ExceptOccur {exceptDay = read "2024-01-15", exceptStart = read "09:00:00", exceptEnd = read "16:00:00"} ,ExceptOccur {exceptDay = read "2024-09-24", exceptStart = read "09:10:00", exceptEnd = read "16:10:00"} ,ExceptNoOccur {exceptTime = read "2024-02-25 15:55:00"} ,ExceptNoOccur {exceptTime = read "2024-10-25 13:33:00"} ,ExceptNoOccur {exceptTime = read "2024-11-08 08:08:08"} -- causes difference between occurrencesCompute and occurrencesCompute' ,ExceptNoOccur {exceptTime = read "2024-11-09 11:11:08"} ] } exampleTerm :: Term exampleTerm = Term { termName = TermIdentifier {year = 2024} , termStart = read "2024-01-01" , termEnd = read "2024-12-29" , termHolidays = [read "2024-01-01", read "2024-03-29", read "2024-03-31", read "2024-04-01", read "2024-05-01", read "2024-05-09" ,read "2024-05-19", read "2024-05-20", read "2024-05-30", read "2024-10-03", read "2024-12-24", read "2024-12-25", read "2024-12-26" ] , termLectureStart = read "2024-01-01" , termLectureEnd = read "2024-12-27" } -}