196 lines
8.7 KiB
Haskell
196 lines
8.7 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
|
|
--
|
|
-- 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"
|
|
}
|
|
|
|
-} |