fix(occurrences): occurringLessons had an erroneously inverted condition

src/Handler/School/DayTasks.hs

@@ -71,9 +71,9 @@ data OccurrenceCacheKey = OccurrenceCacheKeyTutorials SchoolId (Day,Day)
   deriving anyclass (Hashable, Binary)
 
 getDayTutorials :: SchoolId -> (Day,Day) -> DB [TutorialId]
-getDayTutorials ssh dlimit@(dstart, dend )
+getDayTutorials ssh _dlimit@(dstart, dend )
   | dstart > dend = return mempty
-  | otherwise = memcachedByClass MemcachedKeyClassTutorialOccurrences (Just . Right $ 9 * diffDay) (OccurrenceCacheKeyTutorials ssh dlimit) $ do
+  | otherwise = memcachedByClass MemcachedKeyClassTutorialOccurrences (Just . Right $ 9 * diffDay) (OccurrenceCacheKeyTutorials ssh dlimit) $
     candidates <- E.select $ do
       (trm :& crs :& tut) <- E.from $ E.table @Term
           `E.innerJoin` E.table @Course   `E.on` (\(trm :& crs)      -> crs E.^. CourseTerm E.==. trm E.^. TermId)
@@ -82,11 +82,12 @@ getDayTutorials ssh dlimit@(dstart, dend )
           E.&&.  trm E.^. TermStart    E.<=. E.val dend
           E.&&.  trm E.^. TermEnd      E.>=. E.val dstart
       return (trm, tut, E.just (tut E.^. TutorialTime) @>. E.jsonbVal (occurrenceDayValue dstart))
+    $logErrorS "DAILY" $ foldMap (\(Entity{entityVal=someTerm},Entity{entityVal=Tutorial{..}},_) -> tshow someTerm <> " *** " <> ciOriginal tutorialName <> ": " <> tshow (unJSONB tutorialTime)) candidates
     return $ mapMaybe checkCandidate candidates
   where
     period = Set.fromAscList [dstart..dend]
 
-    checkCandidate (_, Entity{entityKey=tutId}, E.unValue -> True) = Just tutId -- common case
+    -- TODO: checkCandidate (_, Entity{entityKey=tutId}, E.unValue -> True) = Just tutId -- common case
     checkCandidate (Entity{entityVal=trm}, Entity{entityKey=tutId, entityVal=Tutorial{tutorialTime=JSONB occ}},_)
       | not $ Set.null $ Set.intersection period $ occurrencesCompute' trm occ
         = Just tutId

src/Handler/Utils/Occurrences.hs

@@ -20,7 +20,7 @@ import Utils.Occurrences
 
 import Handler.Utils.DateTime
 
-
+-- import Text.Read (read) -- for DEBUGGING only
 
 
 ----------------
@@ -38,7 +38,7 @@ occurringLessons t Occurrences{..} = Set.union exceptOcc $ Set.filter isExcept s
   where
     scheduledLessons      = occurrenceScheduleToLessons t `foldMap` occurrencesScheduled
     (exceptOcc, exceptNo) = occurrenceExceptionToLessons  occurrencesExceptions
-    isExcept LessonTime{lessonStart} = Set.member lessonStart exceptNo
+    isExcept LessonTime{lessonStart} = Set.notMember lessonStart exceptNo
 
 occurrenceScheduleToLessons :: Term -> OccurrenceSchedule -> Set LessonTime
 occurrenceScheduleToLessons Term{..} =
@@ -84,14 +84,13 @@ occurrencesWidget (normalizeOccurrences . unJSONB -> Occurrences{..}) = do
           $(widgetFile "widgets/occurrence/cell/except-no-occur")
   $(widgetFile "widgets/occurrence/cell")
 
--- | More precise verison of `occurrencesCompute`, which accounts for TimeOfDay as well
+-- | 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
-
--- | Get all occurrences during a term, excluding term holidays from the regular schedule, but not from exceptions
---   Beware: code currently ignores TimeOfDay, see Model.Types.DateTime.LessonTime for a start to address this if needed
 occurrencesCompute :: Term -> Occurrences -> Set Day
-occurrencesCompute Term{..} Occurrences{..} = ((scdDays \\ Set.fromList termHolidays) <> plsDays) \\ excDays
+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
@@ -133,3 +132,42 @@ occurrencesAddBusinessDays Term{..} (dayOld, dayNew) Occurrences{..} = Occurrenc
       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"
+  }
+
+-}