module Data.Time.Recurrence
(
WeekDay (..)
, Month (..)
, Moment (..)
, DateTime (..)
, InitialMoment (..)
, toInterval
, toStartOfWeek
, secondly
, minutely
, hourly
, daily
, weekly
, monthly
, yearly
, secondlyUTC
, minutelyUTC
, hourlyUTC
, dailyUTC
, weeklyUTC
, monthlyUTC
, yearlyUTC
, enumYear
, enumMonth
, enumWeek
, restrict
, bySeconds
, byMinutes
, byHours
, byWeekDays
, byMonthDays
, byMonths
, byYearDays
, expand
, onWeekNumbers
, onMonths
, onMonthDays
, onYearDays
, onEachWeek
, onEachMonth
, onEachYear
, repeatSchedule
, repeatSchedule'
)
where
import Control.Applicative
import Control.Monad.Reader
import Data.List.Ordered (nubSort)
import Data.Maybe (fromJust, mapMaybe)
import Data.Time
import Data.Time.Calendar.MonthDay (monthLength)
import Data.Time.Calendar.OrdinalDate (toOrdinalDate, fromOrdinalDateValid, fromMondayStartWeekValid, mondayStartWeek)
import Data.Traversable
data WeekDay
= Monday
| Tuesday
| Wednesday
| Thursday
| Friday
| Saturday
| Sunday
deriving (Show, Eq, Ord, Enum, Bounded)
data Month
= January
| February
| March
| April
| May
| June
| July
| August
| September
| October
| November
| December
deriving (Show, Eq, Ord, Bounded)
instance Enum Month where
fromEnum January = 1
fromEnum February = 2
fromEnum March = 3
fromEnum April = 4
fromEnum May = 5
fromEnum June = 6
fromEnum July = 7
fromEnum August = 8
fromEnum September = 9
fromEnum October = 10
fromEnum November = 11
fromEnum December = 12
toEnum 1 = January
toEnum 2 = February
toEnum 3 = March
toEnum 4 = April
toEnum 5 = May
toEnum 6 = June
toEnum 7 = July
toEnum 8 = August
toEnum 9 = September
toEnum 10 = October
toEnum 11 = November
toEnum 12 = December
toEnum unmatched = error ("Month.toEnum: Cannot match " ++ show unmatched)
data DateTime = DateTime
{ dtSecond :: Int
, dtMinute :: Int
, dtHour :: Int
, dtDay :: Int
, dtMonth :: Month
, dtYear :: Integer
, dtWeekDay :: WeekDay
, dtYearDay :: Int
, dtTimeZone :: TimeZone
}
deriving (Show)
data Frequency
= Seconds
| Minutes
| Hours
| Days
| Weeks
| Months
| Years
deriving (Show)
newtype Interval = Interval Integer deriving (Show)
newtype StartOfWeek = StartOfWeek { fromStartOfWeek :: WeekDay } deriving (Show)
toInterval :: Integer -> Interval
toInterval = Interval
toStartOfWeek :: WeekDay -> StartOfWeek
toStartOfWeek = StartOfWeek
oneSecond :: Integer
oneSecond = 1
oneMinute :: Integer
oneMinute = 60 * oneSecond
oneHour :: Integer
oneHour = 60 * oneMinute
oneDay :: Integer
oneDay = 24 * oneHour
oneWeek :: Integer
oneWeek = 7 * oneDay
class Moment a where
epoch :: a
toDateTime :: a -> DateTime
fromDateTime :: DateTime -> Maybe a
scaleTime :: a -> Integer -> a
scaleMonth :: a -> Integer -> a
scaleYear :: a -> Integer -> a
alterWeekNumber :: StartOfWeek -> a -> Int -> Maybe a
alterYearDay :: a -> Int -> Maybe a
alterSecond :: a -> Int -> Maybe a
alterSecond x s = fromDateTime (toDateTime x){dtSecond = s}
alterMinute :: a -> Int -> Maybe a
alterMinute x m = fromDateTime (toDateTime x){dtMinute = m}
alterHour :: a -> Int -> Maybe a
alterHour x h = fromDateTime (toDateTime x){dtHour = h}
alterDay :: a -> Int -> Maybe a
alterDay x d = fromDateTime (toDateTime x){dtDay = d}
alterMonth :: a -> Month -> Maybe a
alterMonth x m = fromDateTime (toDateTime x){dtMonth = m}
alterYear :: a -> Integer -> Maybe a
alterYear x y = fromDateTime (toDateTime x){dtYear = y}
next :: Interval -> Frequency -> a -> a
next (Interval interval) freq =
case freq of
Seconds -> scale oneSecond
Minutes -> scale oneMinute
Hours -> scale oneHour
Days -> scale oneDay
Weeks -> scale oneWeek
Months -> flip scaleMonth interval
Years -> flip scaleYear interval
where
scale x = flip scaleTime (interval * x)
prev :: Interval -> Frequency -> a -> a
prev (Interval interval) = next $ Interval (interval)
data InitialMoment a = InitialMoment
{ frequency :: Frequency
, interval :: Interval
, startOfWeek :: StartOfWeek
, moment :: a
}
deriving (Show)
mkIM :: Moment a => Frequency -> InitialMoment a
mkIM f = InitialMoment f (toInterval 1) (StartOfWeek Monday) epoch
secondly :: Moment a => InitialMoment a
secondly = mkIM Seconds
minutely :: Moment a => InitialMoment a
minutely = mkIM Minutes
hourly :: Moment a => InitialMoment a
hourly = mkIM Hours
daily :: Moment a => InitialMoment a
daily = mkIM Days
weekly :: Moment a => InitialMoment a
weekly = mkIM Weeks
monthly :: Moment a => InitialMoment a
monthly = mkIM Months
yearly :: Moment a => InitialMoment a
yearly = mkIM Years
newtype Schedule a = Schedule {fromSchedule :: [a]} deriving (Show, Eq, Ord)
iterateMoments :: Moment a => (a -> a) -> a -> [a]
iterateMoments = iterate
type RecurringSchedule a = Reader (InitialMoment a) (Schedule a)
enumMoments :: Moment a =>
(Interval -> Frequency -> a -> a)
-> RecurringSchedule a
enumMoments step = do
i <- ask
return $ Schedule $ iterateMoments (step' i) (moment i)
where
step' i = step (interval i) (frequency i)
enumFutureMoments :: Moment a => RecurringSchedule a
enumFutureMoments = enumMoments next
enumPastMoments :: Moment a => RecurringSchedule a
enumPastMoments = enumMoments prev
enumPeriod :: (Moment a, Ord a) => a -> a -> RecurringSchedule a
enumPeriod beg end = do
i <- ask
return $ Schedule $ takeWhile (<= end) $ iterateMoments (step i) beg
where
step i = next (interval i) (frequency i)
enumPeriodFrom :: (Moment a, Ord a) =>
InitialMoment a
-> a
-> a
-> RecurringSchedule a
enumPeriodFrom i' beg end = local (const i') (enumPeriod beg end)
enumYear :: (Moment a, Ord a) => a -> RecurringSchedule a
enumYear m = do
i <- ask
let mi = moment i
enumPeriodFrom (daily `asTypeOf` i){moment = mi} (startDate' mi) endDate
where
eoy = if isLeapYear $ dtYear $ toDateTime m then 366 else 365
endDate = fromJust $ alterYearDay m eoy
startDate' = max (fromJust $ alterYearDay m 1)
enumMonth :: (Moment a, Ord a) => a -> RecurringSchedule a
enumMonth m = do
i <- ask
let mi = moment i
enumPeriodFrom (daily `asTypeOf` i){moment = mi} (startDate' mi) endDate
where
dt = toDateTime m
eom = monthLength (isLeapYear $ dtYear dt) (fromEnum $ dtMonth dt)
endDate = fromJust $ alterDay m eom
startDate' = max (fromJust $ alterDay m 1)
enumWeek :: (Moment a, Ord a) => a -> RecurringSchedule a
enumWeek m = do
i <- ask
let mi = moment i
let sow = startOfWeek i
let dt = toDateTime m
let delta = fromEnum (dtWeekDay dt) fromEnum (fromStartOfWeek sow)
let delta' = toInteger delta
let endDate = scaleTime m $ (7 delta') * oneDay
enumPeriodFrom (daily `asTypeOf` i){moment = mi} m endDate
normIndex :: Int -> Int -> Maybe Int
normIndex _ 0 = Nothing
normIndex ub idx =
if abs idx > ub
then Nothing
else Just $ (idx + ub') `mod` ub'
where
ub' = ub + 1
mapNormIndex :: Int -> [Int] -> [Int]
mapNormIndex n = mapMaybe (normIndex n)
restrict :: Moment a => (a -> Bool) -> Schedule a -> RecurringSchedule a
restrict f s = return $ Schedule $ filter f $ fromSchedule s
by :: (Moment a, Ord b) => (DateTime -> b) -> [b] -> a -> Bool
by f bs a = f (toDateTime a) `elem` nubSort bs
by' :: Moment a => (DateTime -> Int) -> Int -> [Int] -> a -> Bool
by' f n bs = by f $ mapNormIndex n bs
bySeconds :: Moment a => [Int] -> a -> Bool
bySeconds = by dtSecond
byMinutes :: Moment a => [Int] -> a -> Bool
byMinutes = by dtMinute
byHours :: Moment a => [Int] -> a -> Bool
byHours = by dtHour
byWeekDays :: Moment a => [WeekDay] -> a -> Bool
byWeekDays = by dtWeekDay
byMonthDays :: Moment a => [Int] -> a -> Bool
byMonthDays = by' dtDay 31
byMonths :: Moment a => [Month] -> a -> Bool
byMonths = by dtMonth
byYearDays :: Moment a => [Int] -> a -> Bool
byYearDays = by' dtYearDay 366
concatMapM :: Applicative m => (a -> m [b]) -> [a] -> m [b]
concatMapM f xs = concat <$> traverse f xs
expand :: Moment a => (a -> Reader (InitialMoment a) [a]) -> Schedule a -> RecurringSchedule a
expand f s = do
xs <- concatMapM f (fromSchedule s)
return $ Schedule xs
on :: Moment a =>
(a -> b -> Maybe a)
-> [b]
-> a
-> Reader (InitialMoment a) [a]
on f bs a = return $ mapMaybe (f a) bs
on' :: Moment a =>
(InitialMoment a -> a -> b -> Maybe a)
-> [b]
-> a
-> Reader (InitialMoment a) [a]
on' f bs a = ask >>= \i -> on (f i) bs a
onEach :: (Moment a, Ord a) =>
(a -> RecurringSchedule a)
-> a
-> Reader (InitialMoment a) [a]
onEach f m = fmap fromSchedule (f m)
onEachYear :: (Moment a, Ord a) => a -> Reader (InitialMoment a) [a]
onEachYear = onEach enumYear
onEachMonth :: (Moment a, Ord a) => a -> Reader (InitialMoment a) [a]
onEachMonth = onEach enumMonth
onEachWeek :: (Moment a, Ord a) => a -> Reader (InitialMoment a) [a]
onEachWeek = onEach enumWeek
onMonths :: Moment a => [Month] -> a -> Reader (InitialMoment a) [a]
onMonths = on alterMonth
onMonthDays :: Moment a => [Int] -> a -> Reader (InitialMoment a) [a]
onMonthDays ds = on alterDay (mapNormIndex 31 ds)
onYearDays :: Moment a => [Int] -> a -> Reader (InitialMoment a) [a]
onYearDays ds = on alterYearDay (mapNormIndex 366 ds)
onWeekNumbers :: Moment a => [Int] -> a -> Reader (InitialMoment a) [a]
onWeekNumbers ds = on' (alterWeekNumber . startOfWeek) (mapNormIndex 53 ds)
repeatSchedule :: Moment a =>
InitialMoment a
-> (Schedule a -> RecurringSchedule a)
-> [a]
repeatSchedule init r = fromSchedule $ runReader (enumFutureMoments >>= r) init
repeatSchedule' :: Moment a =>
InitialMoment a
-> [a]
repeatSchedule' init = repeatSchedule init return
instance Moment UTCTime where
epoch = UTCTime (toEnum 0) 0
toDateTime (UTCTime utcDay utcTime) =
DateTime (fromEnum seconds) minutes hours
day (toEnum month) year
weekDay yearDay utc
where
(TimeOfDay hours minutes seconds) = timeToTimeOfDay utcTime
(year, month, day) = toGregorian utcDay
yearDay = snd $ toOrdinalDate utcDay
weekDay = toEnum $ snd (mondayStartWeek utcDay) 1
fromDateTime dt = do
let _ = dtTimeZone dt
day <- fromGregorianValid (dtYear dt) (fromEnum $ dtMonth dt) (dtDay dt)
time <- makeTimeOfDayValid (dtHour dt) (dtMinute dt) (toEnum $ dtSecond dt)
return $ UTCTime day (timeOfDayToTime time)
scaleTime utc i = addUTCTime (fromIntegral i) utc
scaleMonth (UTCTime d t) i = UTCTime (addGregorianMonthsRollOver i d) t
scaleYear (UTCTime d t) i = UTCTime (addGregorianYearsRollOver i d) t
alterWeekNumber _ utc@(UTCTime _ time) week = do
let dt = toDateTime utc
day <- fromMondayStartWeekValid (dtYear dt) week (fromEnum $ dtWeekDay dt)
return $ UTCTime day time
alterYearDay utc@(UTCTime _ time) yearDay = do
let dt = toDateTime utc
day <- fromOrdinalDateValid (dtYear dt) yearDay
return $ UTCTime day time
secondlyUTC :: InitialMoment UTCTime
secondlyUTC = secondly
minutelyUTC :: InitialMoment UTCTime
minutelyUTC = minutely
hourlyUTC :: InitialMoment UTCTime
hourlyUTC = hourly
dailyUTC :: InitialMoment UTCTime
dailyUTC = daily
weeklyUTC :: InitialMoment UTCTime
weeklyUTC = weekly
monthlyUTC :: InitialMoment UTCTime
monthlyUTC = monthly
yearlyUTC :: InitialMoment UTCTime
yearlyUTC = yearly