module Data.Time.Recurrence
(
WeekDay (..)
, Month (..)
, Moment (..)
, recurBy
, recur
, utcGregorian
, utcGregorianWithTime
, byMonth
, byWeekNumber
, byYearDay
, byMonthDay
, byDay
)
where
import Data.List.Ordered (nub, nubSort)
import Data.Maybe (mapMaybe, fromJust)
import Data.Time
import Data.Time.Calendar.MonthDay (monthLength)
import Data.Time.Calendar.OrdinalDate (toOrdinalDate, fromOrdinalDateValid, fromMondayStartWeekValid, mondayStartWeek)
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 Moment
= Secondly { moment :: UTCTime }
| Minutely { moment :: UTCTime }
| Hourly { moment :: UTCTime }
| Daily { moment :: UTCTime }
| Weekly { moment :: UTCTime }
| Monthly { moment :: UTCTime }
| Yearly { moment :: UTCTime }
deriving (Show, Eq, Ord)
momentElem :: Eq a => Moment -> (Time -> a) -> [a] -> Bool
momentElem m field xs = field (utcToTime $ moment m) `elem` xs
momentChangeWeekNumber :: Moment -> Int -> Maybe Moment
momentChangeWeekNumber m w = do
let (UTCTime _ t) = moment m
let tm = utcToTime $ moment m
d <- fromMondayStartWeekValid (year tm) w (fromEnum $ weekDay tm)
return $ m{moment = UTCTime d t}
momentChangeYearDay :: Moment -> Int -> Maybe Moment
momentChangeYearDay m yd = do
let (UTCTime _ t) = moment m
let tm = utcToTime $ moment m
d <- fromOrdinalDateValid (year tm) yd
return $ m{moment = UTCTime d t}
data Time = T
{ year :: Integer
, month :: Month
, day :: Int
, hour :: Int
, minute :: Int
, second :: Int
, yearDay :: Int
, weekDay :: WeekDay
}
deriving (Show)
utcToTime :: UTCTime -> Time
utcToTime (UTCTime utcDay utcTime) = T y (toEnum m) d
hh mm (fromEnum ss)
yDay
(toEnum $ dow 1)
where
(y, m, d) = toGregorian utcDay
(TimeOfDay hh mm ss) = timeToTimeOfDay utcTime
yDay = snd $ toOrdinalDate utcDay
(_, dow) = mondayStartWeek utcDay
timeToUTC :: Time -> UTCTime
timeToUTC tm = UTCTime d t
where
d = fromGregorian (year tm) (fromEnum $ month tm) (day tm)
t = timeOfDayToTime $ TimeOfDay (hour tm) (minute tm) (toEnum $ second tm)
utcGregorian :: Integer -> Int -> Int -> UTCTime
utcGregorian y m d = UTCTime (fromGregorian y m d) (timeOfDayToTime midnight)
utcGregorianWithTime :: Integer -> Int -> Int -> Int -> Int -> Int -> UTCTime
utcGregorianWithTime y m d hh mm ss = UTCTime d' t'
where
d' = fromGregorian y m d
t' = timeOfDayToTime (TimeOfDay hh mm (toEnum ss))
oneSecond :: Integer
oneSecond = 1
oneMinute :: Integer
oneMinute = 60 * oneSecond
oneHour :: Integer
oneHour = 60 * oneMinute
oneDay :: Integer
oneDay = 24 * oneHour
oneWeek :: Integer
oneWeek = 7 * oneDay
addTime :: Integer -> UTCTime -> UTCTime
addTime i = addUTCTime (fromIntegral i)
addUTCDays :: (Integer -> Day -> Day) -> Integer -> UTCTime -> UTCTime
addUTCDays f i (UTCTime d t) = UTCTime (f i d) t
addMonthsRollOver :: Integer -> UTCTime -> UTCTime
addMonthsRollOver = addUTCDays addGregorianMonthsRollOver
addYearsRollOver :: Integer -> UTCTime -> UTCTime
addYearsRollOver = addUTCDays addGregorianYearsRollOver
scaleUTCTime :: (Integer -> UTCTime -> UTCTime) -> Integer -> Moment -> Moment
scaleUTCTime f s m = m{moment = f s (moment m)}
next :: Integer -> Moment -> Moment
next interval = go
where
go m@(Secondly _) = scale oneSecond m
go m@(Minutely _) = scale oneMinute m
go m@(Hourly _) = scale oneHour m
go m@(Daily _) = scale oneDay m
go m@(Weekly _) = scale oneWeek m
go m@(Monthly _) = scaleUTCTime addMonthsRollOver interval m
go m@(Yearly _) = scaleUTCTime addYearsRollOver interval m
scale x = scaleUTCTime addTime $ interval * x
recurBy :: Integer -> [Moment -> [Moment]] -> Moment -> [Moment]
recurBy interval subRules startDate = nub $ applySubRules $ recurFrom startDate
where
recurFrom = iterate $ next interval
fapply fs xs = foldl (\xs' f -> f xs') xs fs
applySubRules = fapply (map concatMap subRules)
recur :: [Moment -> [Moment]] -> Moment -> [Moment]
recur = recurBy 1
moments :: Moment -> [Moment]
moments m@(Yearly u) =
if isLeapYear (year $ utcToTime u)
then map yearly $ take 366 $ recur [] startDate'
else map yearly $ take 365 $ recur [] startDate'
where
yearly = Yearly . moment
startDate = fromJust $ momentChangeYearDay m 1
startDate' = Daily $ moment startDate
moments (Monthly u) = map monthly $ take days $ recur [] startDate
where
monthly = Monthly . moment
tm = utcToTime u
startDate = Daily $ timeToUTC tm{day = 1}
days = monthLength (isLeapYear (year tm)) (fromEnum $ month tm)
moments m@(Weekly u) = map weekly $ take 7 $ recur [] $ Daily (moment m')
where
weekly = Weekly . moment
tm = utcToTime u
delta = fromEnum (weekDay tm) fromEnum Monday
m' = fromJust $ momentChangeYearDay m (yearDay tm delta)
moments m = [m]
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
limit :: Eq a => [a] -> (Time -> a) -> Moment -> [Moment]
limit xs f m = [m | momentElem m f xs]
byMonth :: [Month] -> Moment -> [Moment]
byMonth months m@(Yearly _) = map (setMonth m) months
where
setMonth :: Moment -> Month -> Moment
setMonth m mo = m{moment = timeToUTC (utcToTime $ moment m){month = mo}}
byMonth months m = limit months month m
byWeekNumber :: [Int] -> Moment -> [Moment]
byWeekNumber weeks m@(Yearly _) = mapMaybe (momentChangeWeekNumber m) weeks'
where
weeks' = nubSort $ mapMaybe (normIndex 53) weeks
byWeekNumber _ m = [m]
byYearDay :: [Int] -> Moment -> [Moment]
byYearDay days = go days'
where
days' = nubSort $ mapMaybe (normIndex 366) days
go days m@(Secondly _) = limit days yearDay m
go days m@(Minutely _) = limit days yearDay m
go days m@(Hourly _) = limit days yearDay m
go _ m@(Daily _) = [m]
go _ m@(Weekly _) = [m]
go _ m@(Monthly _) = [m]
go days m@(Yearly _) = mapMaybe (momentChangeYearDay m) days
byMonthDay :: [Int] -> Moment -> [Moment]
byMonthDay days = go days'
where
days' = nubSort $ mapMaybe (normIndex 31) days
go _ m@(Weekly _) = [m]
go days m@(Secondly _) = limit days day m
go days m@(Minutely _) = limit days day m
go days m@(Hourly _) = limit days day m
go days m@(Daily _) = limit days day m
go days m = map (setDay m) days
setDay :: Moment -> Int -> Moment
setDay m d = m{moment = timeToUTC (utcToTime $ moment m){day = d}}
byDay :: [WeekDay] -> Moment -> [Moment]
byDay days = go (nubSort days)
where
go days m@(Secondly _) = limit days weekDay m
go days m@(Minutely _) = limit days weekDay m
go days m@(Hourly _) = limit days weekDay m
go days m@(Daily _) = limit days weekDay m
go days m = filter (\x -> momentElem x weekDay days) $ moments m