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.
This commit is contained in:
Joey Hess
parent
cf6403a13c
commit
1d5207b1e5
1 changed files with 128 additions and 21 deletions
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue