chore(termdays): add function to step businessdays
This commit is contained in:
Steffen Jost
parent
6728106cd5
commit
0c0cb06cdc
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user