From 38d043ec1ad2aa100c46b98c298163a9d3753ee1 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 7 Oct 2013 23:02:47 -0400 Subject: calculating the next time on a Schedule Wow! This was hairy, but about 10x less hairy than expected actually! A bit more recursion than I really like, since I think in theory all of this date stuff can be calulated using some formulas I am too lazy too look up. But this doesn't matter in practice; I asked it for nextTime (Schedule (Divisible 100 (Yearly 7)) (SpecificTime 23 59) (MinutesDuration 10)) Nothing .. and it calculated (NextTimeExactly 2100-01-07 23:59:00) in milliseconds. --- Utility/Scheduled.hs | 149 +++++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 128 insertions(+), 21 deletions(-) (limited to 'Utility') diff --git a/Utility/Scheduled.hs b/Utility/Scheduled.hs index 2b771a9b5..2c8663339 100644 --- a/Utility/Scheduled.hs +++ b/Utility/Scheduled.hs @@ -8,8 +8,9 @@ module Utility.Scheduled ( Schedule(..), Recurrance(..), - TimeOfDay(..), + ScheduledTime(..), Duration(..), + nextTime, fromSchedule, toSchedule, parseSchedule, @@ -19,8 +20,15 @@ module Utility.Scheduled ( import Common import Utility.QuickCheck +import Data.Time.Clock +import Data.Time.LocalTime +import Data.Time.Calendar +import Data.Time.Calendar.WeekDate +import Data.Time.Calendar.OrdinalDate +import Data.Tuple.Utils + {- Some sort of scheduled event. -} -data Schedule = Schedule Recurrance TimeOfDay Duration +data Schedule = Schedule Recurrance ScheduledTime Duration deriving (Eq, Show, Ord) data Recurrance @@ -28,14 +36,16 @@ data Recurrance | Weekly WeekDay | Monthly MonthDay | Yearly YearDay - | Divisable Int Recurrance + -- Days, Weeks, or Months of the year evenly divisible by a number. + -- (Divisible Year is years evenly divisible by a number.) + | Divisible Int Recurrance deriving (Eq, Show, Ord) type WeekDay = Int type MonthDay = Int type YearDay = Int -data TimeOfDay +data ScheduledTime = AnyTime | SpecificTime Hour Minute deriving (Eq, Show, Ord) @@ -46,8 +56,105 @@ type Minute = Int data Duration = MinutesDuration Int deriving (Eq, Show, Ord) +{- Next time a Schedule should take effect. The NextTimeWindow is used + - when a Schedule is allowed to start at some point within the window. -} +data NextTime + = NextTimeExactly LocalTime + | NextTimeWindow LocalTime LocalTime + deriving (Eq, Show) + +nextTime :: Schedule -> Maybe LocalTime -> IO (Maybe NextTime) +nextTime schedule lasttime = do + now <- getCurrentTime + tz <- getTimeZone now + return $ calcNextTime schedule lasttime $ utcToLocalTime tz now + +{- Calculate the next time that fits a Schedule, based on the + - last time it occurred, and the current time. -} +calcNextTime :: Schedule -> Maybe LocalTime -> LocalTime -> Maybe NextTime +calcNextTime (Schedule recurrance scheduledtime _duration) lasttime currenttime + | scheduledtime == AnyTime = do + start <- findfromtoday + return $ NextTimeWindow + start + (LocalTime (localDay start) (TimeOfDay 23 59 0)) + | otherwise = NextTimeExactly <$> findfromtoday + where + findfromtoday = + LocalTime <$> nextday <*> pure nexttime + where + nextday = findnextday recurrance afterday today + today = localDay currenttime + afterday = sameaslastday || toolatetoday + toolatetoday = localTimeOfDay currenttime >= nexttime + sameaslastday = (localDay <$> lasttime) == Just today + nexttime = case scheduledtime of + AnyTime -> TimeOfDay 0 0 0 + SpecificTime h m -> TimeOfDay h m 0 + findnextday r afterday day = case r of + Daily + | afterday -> Just $ addDays 1 day + | otherwise -> Just day + Weekly w + | w < 0 || w > maxwday -> Nothing + | w == wday day -> if afterday + then Just $ addDays 7 day + else Just day + | otherwise -> Just $ + addDays (fromIntegral $ (w - wday day) `mod` 7) day + Monthly m + | m < 0 || m > maxmday -> Nothing + -- TODO can be done more efficiently than recursing + | m == mday day -> if afterday + then findnextday r False (addDays 1 day) + else Just day + | otherwise -> findnextday r False (addDays 1 day) + Yearly y + | y < 0 || y > maxyday -> Nothing + | y == yday day -> if afterday + then findnextday r False (addDays 365 day) + else Just day + | otherwise -> findnextday r False (addDays 1 day) + Divisible n r'@Daily + | n > 0 && n <= maxyday -> + findnextdaywhere r' (divisible n . yday) afterday day + | otherwise -> Nothing + Divisible n r'@(Weekly _) + | n > 0 && n <= maxwnum -> + findnextdaywhere r' (divisible n . wnum) afterday day + | otherwise -> Nothing + Divisible n r'@(Monthly _) + | n > 0 && n <= maxmnum -> + findnextdaywhere r' (divisible n . mnum) afterday day + | otherwise -> Nothing + Divisible n r'@(Yearly _) + | n > 0 -> + findnextdaywhere r' (divisible n . year) afterday day + | otherwise -> Nothing + Divisible _ r'@(Divisible _ _) -> findnextday r' afterday day + findnextdaywhere r p afterday day + | maybe True p d = d + | otherwise = maybe d (findnextdaywhere r p True) d + where + d = findnextday r afterday day + divisible n v = v `rem` n == 0 + + -- extracting various quantities from a Day + wday = thd3 . toWeekDate + wnum = snd3 . toWeekDate + mday = thd3 . toGregorian + mnum = snd3 . toGregorian + yday = snd . toOrdinalDate + year = fromIntegral . fst . toOrdinalDate + + maxyday = 366 -- with leap days + maxwnum = 53 -- some years have more than 53 + maxmday = 31 + maxmnum = 12 + maxwday = 7 + fromRecurrance :: Recurrance -> String -fromRecurrance (Divisable n r) = +fromRecurrance (Divisible n r) = fromRecurrance' (++ "s divisible by " ++ show n) r fromRecurrance r = fromRecurrance' ("every " ++) r @@ -56,7 +163,7 @@ fromRecurrance' a Daily = a "day" fromRecurrance' a (Weekly n) = onday n (a "week") fromRecurrance' a (Monthly n) = onday n (a "month") fromRecurrance' a (Yearly n) = onday n (a "year") -fromRecurrance' a (Divisable _n r) = fromRecurrance' a r -- not used +fromRecurrance' a (Divisible _n r) = fromRecurrance' a r -- not used onday :: Int -> String -> String onday n s = "on day " ++ show n ++ " of " ++ s @@ -66,9 +173,9 @@ toRecurrance s = case words s of ("every":"day":[]) -> Just Daily ("on":"day":sd:"of":"every":something:[]) -> parse something sd ("days":"divisible":"by":sn:[]) -> - Divisable <$> getdivisor sn <*> pure Daily + Divisible <$> getdivisor sn <*> pure Daily ("on":"day":sd:"of":something:"divisible":"by":sn:[]) -> - Divisable + Divisible <$> getdivisor sn <*> parse something sd _ -> Nothing @@ -86,13 +193,13 @@ toRecurrance s = case words s of then Just n else Nothing -fromTimeOfDay :: TimeOfDay -> String -fromTimeOfDay AnyTime = "any time" -fromTimeOfDay (SpecificTime h m) = show h ++ ":" ++ show m +fromScheduledTime :: ScheduledTime -> String +fromScheduledTime AnyTime = "any time" +fromScheduledTime (SpecificTime h m) = show h ++ ":" ++ show m -toTimeOfDay :: String -> Maybe TimeOfDay -toTimeOfDay "any time" = Just AnyTime -toTimeOfDay s = +toScheduledTime :: String -> Maybe ScheduledTime +toScheduledTime "any time" = Just AnyTime +toScheduledTime s = let (h, m) = separate (== ':') s in SpecificTime <$> readish h <*> readish m @@ -106,10 +213,10 @@ toDuration s = case words s of _ -> Nothing fromSchedule :: Schedule -> String -fromSchedule (Schedule recurrance timeofday duration) = unwords +fromSchedule (Schedule recurrance scheduledtime duration) = unwords [ fromRecurrance recurrance , "at" - , fromTimeOfDay timeofday + , fromScheduledTime scheduledtime , "for" , fromDuration duration ] @@ -121,8 +228,8 @@ parseSchedule :: String -> Either String Schedule parseSchedule s = do r <- maybe (Left $ "bad recurrance: " ++ recurrance) Right (toRecurrance recurrance) - t <- maybe (Left $ "bad time of day: " ++ timeofday) Right - (toTimeOfDay timeofday) + t <- maybe (Left $ "bad time of day: " ++ scheduledtime) Right + (toScheduledTime scheduledtime) d <- maybe (Left $ "bad duration: " ++ duration) Right (toDuration duration) Right $ Schedule r t d @@ -131,7 +238,7 @@ parseSchedule s = do (rws, ws') = separate (== "at") ws (tws, dws) = separate (== "for") ws' recurrance = unwords rws - timeofday = unwords tws + scheduledtime = unwords tws duration = unwords dws instance Arbitrary Schedule where @@ -140,7 +247,7 @@ instance Arbitrary Schedule where instance Arbitrary Duration where arbitrary = MinutesDuration <$> nonNegative arbitrary -instance Arbitrary TimeOfDay where +instance Arbitrary ScheduledTime where arbitrary = oneof [ pure AnyTime , SpecificTime @@ -154,7 +261,7 @@ instance Arbitrary Recurrance where , Weekly <$> nonNegative arbitrary , Monthly <$> nonNegative arbitrary , Yearly <$> nonNegative arbitrary - , Divisable + , Divisible <$> positive arbitrary <*> oneof -- no nested Divisibles [ pure Daily -- cgit v1.2.3