add support for weekly, monthly, and yearly schedules that run on no specific day

This commit is contained in:
Joey Hess 2013-10-15 13:05:41 -04:00
parent 7b82f431ba
commit e5e4b80b09
3 changed files with 145 additions and 80 deletions

View file

@ -38,9 +38,9 @@ data Schedule = Schedule Recurrance ScheduledTime
data Recurrance
= Daily
| Weekly WeekDay
| Monthly MonthDay
| Yearly YearDay
| Weekly (Maybe WeekDay)
| Monthly (Maybe MonthDay)
| Yearly (Maybe YearDay)
-- Days, Weeks, or Months of the year evenly divisible by a number.
-- (Divisible Year is years evenly divisible by a number.)
| Divisible Int Recurrance
@ -65,6 +65,10 @@ data NextTime
| NextTimeWindow LocalTime LocalTime
deriving (Eq, Read, Show)
startTime :: NextTime -> LocalTime
startTime (NextTimeExactly t) = t
startTime (NextTimeWindow t _) = t
nextTime :: Schedule -> Maybe LocalTime -> IO (Maybe NextTime)
nextTime schedule lasttime = do
now <- getCurrentTime
@ -76,77 +80,127 @@ nextTime schedule lasttime = do
calcNextTime :: Schedule -> Maybe LocalTime -> LocalTime -> Maybe NextTime
calcNextTime (Schedule recurrance scheduledtime) lasttime currenttime
| scheduledtime == AnyTime = do
start <- findfromtoday True
return $ NextTimeWindow
start
(LocalTime (localDay start) (TimeOfDay 23 59 0))
| otherwise = NextTimeExactly <$> findfromtoday False
next <- findfromtoday True
return $ case next of
NextTimeWindow _ _ -> next
NextTimeExactly t -> window (localDay t) (localDay t)
| otherwise = NextTimeExactly . startTime <$> findfromtoday False
where
findfromtoday anytime =
LocalTime <$> nextday <*> pure nexttime
findfromtoday anytime = findfrom recurrance afterday today
where
nextday = findnextday recurrance afterday today
today = localDay currenttime
afterday = sameaslastday || toolatetoday
toolatetoday = not anytime && localTimeOfDay currenttime >= nexttime
sameaslastday = (localDay <$> lasttime) == Just today
sameaslastday = lastday == Just today
lastday = localDay <$> lasttime
nexttime = case scheduledtime of
AnyTime -> TimeOfDay 0 0 0
SpecificTime h m -> TimeOfDay h m 0
findnextday r afterday day = case r of
exactly d = NextTimeExactly $ LocalTime d nexttime
window startd endd = NextTimeWindow
(LocalTime startd nexttime)
(LocalTime endd (TimeOfDay 23 59 0))
findfrom r afterday day = case r of
Daily
| afterday -> Just $ addDays 1 day
| otherwise -> Just day
Weekly w
| afterday -> Just $ exactly $ addDays 1 day
| otherwise -> Just $ exactly day
Weekly Nothing
| afterday -> skip 1
| otherwise -> case (wday <$> lastday, wday day) of
(Nothing, _) -> Just $ window day (addDays 6 day)
(Just old, curr)
| old == curr -> Just $ window day (addDays 6 day)
| otherwise -> skip 1
Monthly Nothing
| afterday -> skip 1
| maybe True (\old -> mnum day > mday old && mday day >= (mday old `mod` minmday)) lastday ->
-- Window only covers current month,
-- in case there is a Divisible requirement.
Just $ window day (endOfMonth day)
| otherwise -> skip 1
Yearly Nothing
| afterday -> skip 1
| maybe True (\old -> ynum day > ynum old && yday day >= (yday old `mod` minyday)) lastday ->
Just $ window day (endOfYear day)
| otherwise -> skip 1
Weekly (Just w)
| w < 0 || w > maxwday -> Nothing
| w == wday day -> if afterday
then Just $ addDays 7 day
else Just day
| otherwise -> Just $
then Just $ exactly $ addDays 7 day
else Just $ exactly day
| otherwise -> Just $ exactly $
addDays (fromIntegral $ (w - wday day) `mod` 7) day
Monthly m
Monthly (Just 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
then skip 1
else Just $ exactly day
| otherwise -> skip 1
Yearly (Just 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)
then skip 365
else Just $ exactly day
| otherwise -> skip 1
Divisible n r'@Daily -> handlediv n r' yday (Just maxyday)
Divisible n r'@(Weekly _) -> handlediv n r' wnum (Just maxwnum)
Divisible n r'@(Monthly _) -> handlediv n r' mnum (Just maxmnum)
Divisible n r'@(Yearly _) -> handlediv n r' year Nothing
Divisible _ r'@(Divisible _ _) -> findnextday r' afterday day
Divisible n r'@(Yearly _) -> handlediv n r' ynum Nothing
Divisible _ r'@(Divisible _ _) -> findfrom r' afterday day
where
skip n = findfrom r False (addDays n day)
handlediv n r' getval mmax
| n > 0 && maybe True (n <=) mmax =
findnextdaywhere r' (divisible n . getval) afterday day
findfromwhere r' (divisible n . getval) afterday day
| otherwise = Nothing
findnextdaywhere r p afterday day
| maybe True p d = d
| otherwise = maybe d (findnextdaywhere r p True) d
findfromwhere r p afterday day
| maybe True (p . getday) next = next
| otherwise = maybe Nothing (findfromwhere r p True . getday) next
where
d = findnextday r afterday day
next = findfrom r afterday day
getday = localDay . startTime
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
endOfMonth :: Day -> Day
endOfMonth day =
let (y,m,_d) = toGregorian day
in fromGregorian y m (gregorianMonthLength y m)
maxyday = 366 -- with leap days
maxwnum = 53 -- some years have more than 52
maxmday = 31
maxmnum = 12
maxwday = 7
endOfYear :: Day -> Day
endOfYear day =
let (y,_m,_d) = toGregorian day
in endOfMonth (fromGregorian y maxmnum 1)
-- extracting various quantities from a Day
wday :: Day -> Int
wday = thd3 . toWeekDate
wnum :: Day -> Int
wnum = snd3 . toWeekDate
mday :: Day -> Int
mday = thd3 . toGregorian
mnum :: Day -> Int
mnum = snd3 . toGregorian
yday :: Day -> Int
yday = snd . toOrdinalDate
ynum :: Day -> Int
ynum = fromIntegral . fst . toOrdinalDate
{- Calendar max and mins. -}
maxyday :: Int
maxyday = 366 -- with leap days
minyday :: Int
minyday = 365
maxwnum :: Int
maxwnum = 53 -- some years have more than 52
maxmday :: Int
maxmday = 31
minmday :: Int
minmday = 28
maxmnum :: Int
maxmnum = 12
maxwday :: Int
maxwday = 7
fromRecurrance :: Recurrance -> String
fromRecurrance (Divisible n r) =
@ -160,28 +214,40 @@ fromRecurrance' a (Monthly n) = onday n (a "month")
fromRecurrance' a (Yearly n) = onday n (a "year")
fromRecurrance' a (Divisible _n r) = fromRecurrance' a r -- not used
onday :: Int -> String -> String
onday n s = "on day " ++ show n ++ " of " ++ s
onday :: Maybe Int -> String -> String
onday (Just n) s = "on day " ++ show n ++ " of " ++ s
onday Nothing s = s
toRecurrance :: String -> Maybe Recurrance
toRecurrance s = case words s of
("every":"day":[]) -> Just Daily
("on":"day":sd:"of":"every":something:[]) -> parse something sd
("on":"day":sd:"of":"every":something:[]) -> withday sd something
("every":something:[]) -> noday something
("days":"divisible":"by":sn:[]) ->
Divisible <$> getdivisor sn <*> pure Daily
("on":"day":sd:"of":something:"divisible":"by":sn:[]) ->
Divisible
<$> getdivisor sn
<*> parse something sd
<*> withday sd something
("every":something:"divisible":"by":sn:[]) ->
Divisible
<$> getdivisor sn
<*> noday something
_ -> Nothing
where
parse "week" sd = withday Weekly sd
parse "month" sd = withday Monthly sd
parse "year" sd = withday Yearly sd
parse v sd
| "s" `isSuffixOf` v = parse (reverse $ drop 1 $ reverse v) sd
constructor "week" = Just Weekly
constructor "month" = Just Monthly
constructor "year" = Just Yearly
constructor u
| "s" `isSuffixOf` u = constructor $ reverse $ drop 1 $ reverse u
| otherwise = Nothing
withday c sd = c <$> readish sd
withday sd u = do
c <- constructor u
d <- readish sd
Just $ c (Just d)
noday u = do
c <- constructor u
Just $ c Nothing
getdivisor sn = do
n <- readish sn
if n > 0
@ -255,18 +321,23 @@ instance Arbitrary ScheduledTime where
instance Arbitrary Recurrance where
arbitrary = oneof
[ pure Daily
, Weekly <$> nonNegative arbitrary
, Monthly <$> nonNegative arbitrary
, Yearly <$> nonNegative arbitrary
, Weekly <$> arbday
, Monthly <$> arbday
, Yearly <$> arbday
, Divisible
<$> positive arbitrary
<*> oneof -- no nested Divisibles
[ pure Daily
, Weekly <$> nonNegative arbitrary
, Monthly <$> nonNegative arbitrary
, Yearly <$> nonNegative arbitrary
, Weekly <$> arbday
, Monthly <$> arbday
, Yearly <$> arbday
]
]
where
arbday = oneof
[ Just <$> nonNegative arbitrary
, pure Nothing
]
prop_schedule_roundtrips :: Schedule -> Bool
prop_schedule_roundtrips s = toSchedule (fromSchedule s) == Just s