chore(termdays): add function to step businessdays

src/Handler/Utils/DateTime.hs

@@ -16,6 +16,7 @@ module Handler.Utils.DateTime
   , addOneWeek, addWeeks
   , weeksToAdd
   , setYear, getYear
+  , firstDayOfWeekOnAfter
   , ceilingQuarterHour
   , formatGregorianW
   ) where
@@ -224,6 +225,14 @@ getYear date = y
   where 
     (y,_,_) = toGregorian date    
 
+dayOfWeekDiff :: DayOfWeek -> DayOfWeek -> Int
+dayOfWeekDiff a b = mod (fromEnum a - fromEnum b) 7
+
+-- | The first day-of-week on or after some day
+-- | from time-compat-1.9.5, not included
+firstDayOfWeekOnAfter :: DayOfWeek -> Day -> Day
+firstDayOfWeekOnAfter dw d = addDays (toInteger $ dayOfWeekDiff dw $ dayOfWeek d) d
+
 addOneWeek :: UTCTime -> UTCTime
 addOneWeek = addWeeks 1
 

src/Model/Types/DateTime.hs

@@ -27,7 +27,7 @@ import Data.Aeson.Types as Aeson
 ----
 --  Terms and anything loosely related to time
 
-newtype TermIdentifier = TermIdentifier { tday :: Day }
+newtype TermIdentifier = TermIdentifier { getTermDay :: Day }
     deriving (Show, Read, Eq, Ord, Generic, Typeable, Enum)     
     deriving newtype (Binary, ISO8601)
     deriving anyclass (NFData)
@@ -72,6 +72,18 @@ termFromText t = maybeToRight errm $ iso8601ParseM $ Text.unpack t
       errm = "Invalid TermIdentifier: “" <> t <> "”"
 
 -- Option 2: show as WeekNr-DayOfWeek-Year, e.g. 22Mon2021?
+termToText' :: TermIdentifier -> Text 
+termToText' TermIdentifier{..} = Text.pack $ show weeknr ++ wd ++ show year
+  where 
+    wd = take 3 $ show $ dayOfWeek getTermDay
+    (year,weeknr,_wd_) = toWeekDate getTermDay
+
+{- TODO
+termFromText' :: Text -> Either Text TermIdentifier
+termFromText' t = error "not implemented"
+  where 
+      errm = "Invalid TermIdentifier: “" <> t <> "”"
+-}
 
 daysPerYear :: Rational
 daysPerYear = 365 + (97 % 400)
@@ -83,7 +95,7 @@ dayOffset = fromIntegral yearzero + (fromIntegral diffstart / daysPerYear)
     yearzero  = fst3 $ toGregorian dayzero
     diffstart = diffDays dayzero $ fromGregorian yearzero 1 1 
     
--- Attempt to ensure that ``truncate . termToRational == fst3 . toGregorian . tday´´ holds
+-- Attempt to ensure that ``truncate . termToRational == fst3 . toGregorian . getTermDay´´ holds
 termToRational :: TermIdentifier -> Rational 
 termToRational = (dayOffset +) . (/ daysPerYear) . fromIntegral . fromEnum        
 
@@ -131,8 +143,8 @@ data TermDay
 guessDay :: TermIdentifier
          -> TermDay
          -> Day
-guessDay TermIdentifier{..} TermDayLectureStart =           tday
+guessDay TermIdentifier{..} TermDayLectureStart =           getTermDay
-guessDay TermIdentifier{..} TermDayLectureEnd   = addDays 8 tday -- courses last only a week
+guessDay TermIdentifier{..} TermDayLectureEnd   = addDays 8 getTermDay -- courses last only a week
 guessDay tid TermDayStart = fromWeekDate year weekStart 1 -- Monday before lecture time 
   where ( year, weekStart, _) = toWeekDate $ guessDay tid TermDayLectureStart
 guessDay tid TermDayEnd   = fromWeekDate year weekStart 7 -- Sunday after lecture time
@@ -141,7 +153,6 @@ guessDay tid TermDayEnd   = fromWeekDate year weekStart 7 -- Sunday after lectur
 withinTerm :: Day -> TermIdentifier -> Bool 
 withinTerm d tid = guessDay tid TermDayStart <= d && d <= guessDay tid TermDayEnd
 
-
 data OccurrenceSchedule = ScheduleWeekly
                           { scheduleDayOfWeek :: WeekDay
                           , scheduleStart     :: TimeOfDay

src/Utils/Holidays.hs

@@ -10,6 +10,8 @@ module Utils.Holidays
   , feiertage
   , bankHolidays, bankHolidaysArea, bankHolidaysAreaSet
   , isBankHoliday, isBankHolidayArea 
+  , isWeekend
+  , addBusinessDays
   ) where
 
 import Import.NoModel
@@ -107,13 +109,16 @@ isBankHolidayArea land dd = dd `Set.member` holidays
 -- | Returns whether a day is a bank holiday for years >= 1995
 -- | Repeated calls are handled efficiently using lazy memoization 
 isBankHolidayArea :: Feiertagsgebiet -> Day -> Bool
-isBankHolidayArea land dd = dd `Set.member` holidays
+isBankHolidayArea land = ibha
   where 
-    (year, _, _) = toGregorian dd
+    landHoliday = Map.lookup land memoHolidays 
-    holidays 
+    ibha dd     = dd `Set.member` holidays
-      | (Just hys) <- Map.lookup land memoHolidays
+      where 
-      , (Just hds) <- index hys $ fromInteger $ year2index year = hds
+        (year, _, _) = toGregorian dd
-      | otherwise = bankHolidaysAreaSet land year 
+        holidays 
+          | (Just hys) <- landHoliday
+          , (Just hds) <- index hys $ fromInteger $ year2index year = hds
+          | otherwise = bankHolidaysAreaSet land year 
 
 -- memoize holidays 
 memoHolidays :: Map.Map Feiertagsgebiet [Set.Set Day]
@@ -137,3 +142,27 @@ index2year y = result
     (x,r) = y `divMod` 2 
     result | r == 0    = memoTip + x 
            | otherwise = memoTip - x - 1
+
+-- | Test for Saturday/Sunday 
+isWeekend :: Day -> Bool
+isWeekend = isWeekend' . dayOfWeek 
+  where 
+    isWeekend' :: WeekDay -> Bool
+    isWeekend' Sunday   = True 
+    isWeekend' Saturday = True 
+    isWeekend' _        = False
+
+-- | Always returns a business day. 
+-- | Saturday/Sunday/Holiday treated like next (n>=0) or previous (n<0) working day
+addBusinessDays :: Feiertagsgebiet -> Integer -> Day -> Day
+addBusinessDays land = abd 
+  where 
+    ibhal        = isBankHolidayArea land 
+    freeday   dd = isWeekend dd || ibhal dd 
+    abd n = abd' n
+      where         
+        (fwd, bwd)  | n >= 0    = (succ, pred)
+                    | otherwise = (pred, succ)
+        abd' m dd | freeday dd = abd'      m  (fwd dd)              
+                  | m == 0     =                   dd
+                  | otherwise  = abd' (bwd m) (fwd dd)

test/Database/Fill.hs

@@ -14,6 +14,7 @@ import qualified Data.Map as Map
 
 -- import Data.Time.Calendar.OrdinalDate
 import Data.Time.Calendar.WeekDate
+import Utils.Holidays
 
 import Control.Applicative (ZipList(..))
 
@@ -56,33 +57,23 @@ fillDb = do
     insert' :: (PersistRecordBackend r (YesodPersistBackend UniWorX), AtLeastOneUniqueKey r) => r -> YesodDB UniWorX (Key r)
     insert' = fmap (either entityKey id) . insertBy
 
-    (currentYear, currentMonth, _) = toGregorian $ utctDay now
+    addBDays = addBusinessDays Fraport -- holiday area to use 
-    currentTerm
+    currentTerm = TermIdentifier $ utctDay now
-      | 3 >= currentMonth = TermIdentifier currentYear Q1
+    (currentYear, currentMonth, currentDay) = toGregorian $ getTermDay currentTerm    
-      | 6 >= currentMonth = TermIdentifier currentYear Q2
+    nextTerm n = TermIdentifier $ addBDays n $ getTermDay currentTerm
-      | 9 >= currentMonth = TermIdentifier currentYear Q3
-      | otherwise         = TermIdentifier currentYear Q4
-    nextTerm = succ currentTerm
-    prevTerm = pred currentTerm
-    prevPrevTerm = pred prevTerm
 
-    seasonTerm next wSeason = until ((wSeason ==) . season) prog currentTerm
+    termTime :: Integer -- ^ Term Offset to current Term (i.e. Days)
-      where prog | next      = succ
+             -> Integer -- ^ Days Offset from Start/End of Term 
-                 | otherwise = pred
+             -> Bool    -- ^ Relative to end of Term?
-
+             -> Maybe WeekDay -- ^ Move to weekday
-    termTime :: Bool -- ^ Next term?
-             -> Season
-             -> Rational
-             -> Bool -- ^ Relative to end of semester?
-             -> WeekDay
              -> (Day -> UTCTime) -- ^ Add time to day
              -> UTCTime
-    termTime next gSeason weekOffset fromEnd d = ($ utctDay)
+    termTime next doff fromEnd mbWeekDay = ($ utctDay)
       where
-        utctDay = fromWeekDate wYear wWeek $ fromEnum d
+        gTid = nextTerm next 
-        (wYear, wWeek, _) = toWeekDate . addDays (round $ 7 * weekOffset) $ fromGregorian rYear rMonth rDay
+        gDay | fromEnd   = addBDays (negate doff) $ guessDay gTid TermDayLectureEnd
-        gTid = seasonTerm next gSeason        
+             | otherwise = addBDays         doff  $ guessDay gTid TermDayLectureStart 
-        (rYear, rMonth, rDay) = toGregorian $ guessDay gTid $ bool TermDayLectureStart TermDayLectureEnd fromEnd          
+        utctDay = maybe gDay (`firstDayOfWeekOnAfter` gDay) mbWeekDay         
     
   gkleen <- insert User
     { userIdent  = "G.Kleen@campus.lmu.de"
@@ -354,16 +345,17 @@ fillDb = do
   matrikel <- toMatrikel <$> getRandomRs (0 :: Int, 9 :: Int)
   manyUsers <- insertMany . getZipList $ manyUser <$> ZipList ((,,) <$> firstNames <*> middlenames <*> surnames) <*> ZipList matrikel
     
-  forM_ [(pred $ pred prevPrevTerm)..(succ $ succ $ succ $ succ nextTerm)] $ \tid -> do
+  terms <- forM [-7..31*6] $ \nr -> do
-    let term = Term { termName     = tid
+    let tid = nextTerm nr tid 
+        term = Term { termName     = termToText' tid 
                     , termStart    = guessDay tid TermDayStart
                     , termEnd      = guessDay tid TermDayEnd
-                    , termHolidays = []
+                    , termHolidays = bankHolidaysArea Fraport
                     , termLectureStart = guessDay tid TermDayLectureStart
                     , termLectureEnd   = guessDay tid TermDayLectureEnd
                     }
     void $ repsert (TermKey tid) term 
-    void . insert_ $ TermActive (TermKey tid) (toMidnight $ addDays (-60) $ termStart term) (Just . beforeMidnight $ addDays 60 $ termEnd term) Nothing
+    insert $ TermActive (TermKey tid) (toMidnight $ addDays (-60) $ termStart term) (Just . beforeMidnight $ addDays 60 $ termEnd term) Nothing
   
   ifiAuthorshipStatement <- insertAuthorshipStatement I18n
     { i18nFallback = htmlToStoredMarkup