diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index c39d24103..1c752536e 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/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 diff --git a/src/Model/Types/DateTime.hs b/src/Model/Types/DateTime.hs index ab7cf8bc7..4346cd381 100644 --- a/src/Model/Types/DateTime.hs +++ b/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{..} TermDayLectureEnd = addDays 8 tday -- courses last only a week +guessDay TermIdentifier{..} TermDayLectureStart = getTermDay +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 diff --git a/src/Utils/Holidays.hs b/src/Utils/Holidays.hs index 5b8d317a3..fb9bc1a08 100644 --- a/src/Utils/Holidays.hs +++ b/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 - holidays - | (Just hys) <- Map.lookup land memoHolidays - , (Just hds) <- index hys $ fromInteger $ year2index year = hds - | otherwise = bankHolidaysAreaSet land year + landHoliday = Map.lookup land memoHolidays + ibha dd = dd `Set.member` holidays + where + (year, _, _) = toGregorian dd + 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) diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index ed4c8c55e..6f80532eb 100644 --- a/test/Database/Fill.hs +++ b/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 - currentTerm - | 3 >= currentMonth = TermIdentifier currentYear Q1 - | 6 >= currentMonth = TermIdentifier currentYear Q2 - | 9 >= currentMonth = TermIdentifier currentYear Q3 - | otherwise = TermIdentifier currentYear Q4 - nextTerm = succ currentTerm - prevTerm = pred currentTerm - prevPrevTerm = pred prevTerm + addBDays = addBusinessDays Fraport -- holiday area to use + currentTerm = TermIdentifier $ utctDay now + (currentYear, currentMonth, currentDay) = toGregorian $ getTermDay currentTerm + nextTerm n = TermIdentifier $ addBDays n $ getTermDay currentTerm - seasonTerm next wSeason = until ((wSeason ==) . season) prog currentTerm - where prog | next = succ - | otherwise = pred - - termTime :: Bool -- ^ Next term? - -> Season - -> Rational - -> Bool -- ^ Relative to end of semester? - -> WeekDay + termTime :: Integer -- ^ Term Offset to current Term (i.e. Days) + -> Integer -- ^ Days Offset from Start/End of Term + -> Bool -- ^ Relative to end of Term? + -> Maybe WeekDay -- ^ Move to 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 - (wYear, wWeek, _) = toWeekDate . addDays (round $ 7 * weekOffset) $ fromGregorian rYear rMonth rDay - gTid = seasonTerm next gSeason - (rYear, rMonth, rDay) = toGregorian $ guessDay gTid $ bool TermDayLectureStart TermDayLectureEnd fromEnd + gTid = nextTerm next + gDay | fromEnd = addBDays (negate doff) $ guessDay gTid TermDayLectureEnd + | otherwise = addBDays doff $ guessDay gTid TermDayLectureStart + 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 - let term = Term { termName = tid + terms <- forM [-7..31*6] $ \nr -> do + 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