diff --git a/src/Data/Time/Recurrence.hs b/src/Data/Time/Recurrence.hs --- a/src/Data/Time/Recurrence.hs +++ b/src/Data/Time/Recurrence.hs @@ -6,47 +6,31 @@ -- * The @Month@ type , Month (..) - -- * The @Recurrence@ type - , toUTCTime - - -- * Frequency Constrcutors for the @Recuurence@ type - , secondly - , minutely - , hourly - , daily - , weekly - , monthly - , yearly + -- * The @Moment@ type + , Moment (..) - -- * Generates list of @Recurrence@ type + -- * Generate list of recurring @Moment@ + , recurBy , recur + -- * Create @UTCTime@ + , utcGregorian + , utcGregorianWithTime + -- * @Recurrence@ type rule effects - , withRules , byMonth , byWeekNumber , byYearDay + , byMonthDay + , byDay ) where import Data.List.Ordered (nub, nubSort) -import Data.Ord (comparing) +import Data.Maybe (mapMaybe, fromJust) import Data.Time -import Data.Time.Calendar.OrdinalDate (fromOrdinalDate, toOrdinalDate) -import Data.Time.Calendar.WeekDate (fromWeekDate) - --- | The base frequency of a Recurrence. --- --- The frequencies are chosen fromRFC 5545. -data Frequency - = Secondly -- ^ every second - | Minutely -- ^ every minute - | Hourly -- ^ every hour - | Daily -- ^ every day - | Weekly -- ^ every week - | Monthly -- ^ every month - | Yearly -- ^ every year - deriving (Show, Eq) +import Data.Time.Calendar.MonthDay (monthLength) +import Data.Time.Calendar.OrdinalDate (toOrdinalDate, fromOrdinalDateValid, fromMondayStartWeekValid, mondayStartWeek) -- | Symbolic week days. -- @@ -109,107 +93,78 @@ toEnum unmatched = error ("Month.toEnum: Cannot match " ++ show unmatched) --- | Recurrence data type --- --- This encapulates a point-in-time of a recurring series --- from here we can compute the 'next' and 'prev' Recurrence -data Recurrence = R - { frequency :: Frequency -- ^ defines the base frequency - , pointInTime :: UTCTime -- ^ the current moment --- , startOfWeek :: WeekDay -- ^ used in calculations on a week - -- TODO: compute accurately when this - -- is another value than Monday - -- ^ (RFC 5545 defaults to Monday) - , interval :: Integer -- ^ defines the step size - , rollOver :: Bool -- ^ for values that would exceed the base - -- frequency, we clip them to the freq - -- unless this is True - } - deriving (Show) +-- | @Moment@ data type +-- One per Frequency (Is this the best way to define this?) +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) -toUTCTime :: Recurrence -> UTCTime -toUTCTime = pointInTime +-- | Test if (field t) is elem in xs +momentElem :: Eq a => Moment -> (Time -> a) -> [a] -> Bool +momentElem m field xs = field (utcToTime $ moment m) `elem` xs -instance Eq Recurrence where - x == y = toUTCTime x == toUTCTime y +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} -instance Ord Recurrence where - x `compare` y = comparing toUTCTime x y +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} --- | Moment data type --- --- Refinements work on a Moment, which is a UTCTime broken out into fields -data Moment = M - { year :: Integer -- ^ YYYY-January-dd - , month :: Month -- - , day :: Int -- - , hour :: Int -- ^ HH:MM:SS - , minute :: Int -- - , second :: Int -- --- , week :: Int -- --- , weekDay :: WeekDay -- - , yearDay :: Int -- - -- , daysInMonth :: Int -- - -- , leapYear :: Bool -- +-- | @Time@ data type +data Time = T + { year :: Integer + , month :: Month + , day :: Int + , hour :: Int + , minute :: Int + , second :: Int + , yearDay :: Int + , weekDay :: WeekDay } deriving (Show) --- | moment conversions -moment :: UTCTime -> Moment -moment (UTCTime utcDay utcTime) = M y (toEnum m) d - hh mm (fromEnum ss) --- wk (toEnum wkDay) - yDay --- mDays --- leap +-- | Expand a @UTCTime@ into its @Time@ components +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 --- (_, wk, _ wkDay) = toWeekDate utcDay yDay = snd $ toOrdinalDate utcDay --- leap = isLeapYear y --- mDays = monthLength leap m + (_, dow) = mondayStartWeek utcDay -momentToUTCTime :: Moment -> UTCTime -momentToUTCTime m = UTCTime d t +-- | Convert the @Time@ components into a @UTCTime@ +timeToUTC :: Time -> UTCTime +timeToUTC tm = UTCTime d t where - d = fromGregorian (year m) (fromEnum $ month m) (day m) - t = timeOfDayToTime $ TimeOfDay (hour m) (minute m) (toEnum $ second m) - --- UTCTime zero -utcEpoch :: UTCTime -utcEpoch = UTCTime (toEnum 0) 0 - --- Default constructor. Use a more refined constructor instead -mkR :: Frequency -> Recurrence -mkR freq = R { frequency = freq - , pointInTime = utcEpoch --- , startOfWeek = Monday - , interval = 1 - , rollOver = False - } - --- | Base 'Recurrence' constructors. One for each of the Frequency types. -secondly :: Recurrence -secondly = mkR Secondly - -minutely :: Recurrence -minutely = mkR Minutely - -hourly :: Recurrence -hourly = mkR Hourly - -daily :: Recurrence -daily = mkR Daily - -weekly :: Recurrence -weekly = mkR Weekly + d = fromGregorian (year tm) (fromEnum $ month tm) (day tm) + t = timeOfDayToTime $ TimeOfDay (hour tm) (minute tm) (toEnum $ second tm) -monthly :: Recurrence -monthly = mkR Monthly +-- | Construct a @UTCTime@ at midnight +utcGregorian :: Integer -> Int -> Int -> UTCTime +utcGregorian y m d = UTCTime (fromGregorian y m d) (timeOfDayToTime midnight) -yearly :: Recurrence -yearly = mkR Yearly +-- | Construct a @UTCTime@ at a time +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)) -- useful time constants oneSecond :: Integer @@ -234,98 +189,129 @@ addUTCDays :: (Integer -> Day -> Day) -> Integer -> UTCTime -> UTCTime addUTCDays f i (UTCTime d t) = UTCTime (f i d) t -addMonthsClip :: Integer -> UTCTime -> UTCTime -addMonthsClip = addUTCDays addGregorianMonthsClip - addMonthsRollOver :: Integer -> UTCTime -> UTCTime addMonthsRollOver = addUTCDays addGregorianMonthsRollOver -addMonths :: Bool -> Integer -> UTCTime -> UTCTime -addMonths b = if b then addMonthsRollOver else addMonthsClip - -addYearsClip :: Integer -> UTCTime -> UTCTime -addYearsClip = addUTCDays addGregorianYearsClip - addYearsRollOver :: Integer -> UTCTime -> UTCTime addYearsRollOver = addUTCDays addGregorianYearsRollOver -addYears :: Bool -> Integer -> UTCTime -> UTCTime -addYears b = if b then addYearsRollOver else addYearsClip +-- | Moment addition +scaleUTCTime :: (Integer -> UTCTime -> UTCTime) -> Integer -> Moment -> Moment +scaleUTCTime f s m = m{moment = f s (moment m)} --- | Recurrence addition -scaleUTCTime :: (Integer -> UTCTime -> UTCTime) -> Integer -> Recurrence -> Recurrence -scaleUTCTime f m r = r{pointInTime = f (i * m) t} +-- | Increment a Moment to its next value +next :: Integer -> Moment -> Moment +next interval = go where - i = interval r - t = pointInTime r + 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 +-- | Generate recurrences from the startDate, filtered by optional rules +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) --- | Forward and backward drivers. -next :: Recurrence -> Recurrence -next r = - case frequency r of - Secondly -> scale oneSecond - Minutely -> scale oneMinute - Hourly -> scale oneHour - Daily -> scale oneDay - Weekly -> scale oneWeek - Monthly -> scaleUTCTime (addMonths $ rollOver r) 1 r - Yearly -> scaleUTCTime (addYears $ rollOver r) 1 r +-- | Default interval of 1 +recur :: [Moment -> [Moment]] -> Moment -> [Moment] +recur = recurBy 1 + +-- | Generate all days within the frequency +-- Yearly generates all days in the year +-- Monthly all days in the month of that year +-- Weekly all days in the week of that month of that year, +-- starting on the first day of the week +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 - scale s = scaleUTCTime addTime s r + 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] --- | Generate a infinite list of recurrences -recur :: Recurrence -> [Recurrence] -recur = iterate next +-- | Normalize an bounded index +-- Pass an upper-bound 'ub' and an index 'idx' +-- Converts 'idx' < 0 into valid 'idx' > 0 or +-- Nothing +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 --- | Takes a list of rule parts and apply them over a list of Recurrence --- to generate a new list of Recurrence -withRules :: [Recurrence -> [Recurrence]] -> [Recurrence] -> [Recurrence] -withRules rs = nub . mapply (map concatMap rs) +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 - mapply fs xs = foldl (\xs' f -> f xs') xs fs + setMonth :: Moment -> Month -> Moment + setMonth m mo = m{moment = timeToUTC (utcToTime $ moment m){month = mo}} +byMonth months m = limit months month m -byMonth :: [Month] -> Recurrence -> [Recurrence] -byMonth ms = go +byWeekNumber :: [Int] -> Moment -> [Moment] +byWeekNumber weeks m@(Yearly _) = mapMaybe (momentChangeWeekNumber m) weeks' where - go :: Recurrence -> [Recurrence] - go r@(R{frequency=freq, pointInTime=t}) = - case freq of - Yearly -> map (expand r $ moment t) $ nubSort ms - _ -> [r | month (moment t) `elem` ms] - expand :: Recurrence -> Moment -> Month -> Recurrence - expand r mt m = r { pointInTime = momentToUTCTime $ mt { month = m } } + weeks' = nubSort $ mapMaybe (normIndex 53) weeks +byWeekNumber _ m = [m] -byWeekNumber :: [Int] -> Recurrence -> [Recurrence] -byWeekNumber wks = go +byYearDay :: [Int] -> Moment -> [Moment] +byYearDay days = go days' where - go :: Recurrence -> [Recurrence] - go r@(R{frequency=freq, pointInTime=t}) = - case freq of - Yearly -> map (expand r $ moment t) $ nubSort wks - _ -> error ("Data.Time.Recurrence.byWeekNumber: Undefined on " ++ show r) - expand :: Recurrence -> Moment -> Int -> Recurrence - expand r mt wk = r {pointInTime = momentToUTCTime $ mt {year = y, month = toEnum m, day = d}} - where - (y, m, d) = toGregorian $ fromWeekDate (year mt) wk (day mt) + 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 -byYearDay :: [Int] -> Recurrence -> [Recurrence] -byYearDay dys = go +byMonthDay :: [Int] -> Moment -> [Moment] +byMonthDay days = go days' where - normDay :: Int -> Int - normDay d = if d < 0 then 367 + d else d - normDays = nubSort $ map normDay dys - go :: Recurrence -> [Recurrence] - go r@(R{frequency=freq, pointInTime=t}) = - case freq of - Yearly -> map (expand r $ moment t) normDays - Hourly -> limit r - Minutely -> limit r - Secondly -> limit r - _ -> error ("Data.Time.Recurrence.byYearDay: Undefined on " ++ show r) - limit :: Recurrence -> [Recurrence] - limit r = [r | yearDay (moment $ pointInTime r) `elem` dys] - expand :: Recurrence -> Moment -> Int -> Recurrence - expand r mt dy = r {pointInTime = momentToUTCTime $ mt {year = y, month = toEnum m, day = d}} - where - (y, m, d) = toGregorian $ fromOrdinalDate (year mt) dy + 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 + diff --git a/time-recurrence.cabal b/time-recurrence.cabal --- a/time-recurrence.cabal +++ b/time-recurrence.cabal @@ -7,7 +7,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented. -Version: 0.1.1 +Version: 0.2 -- A short (one-line) description of the package. Synopsis: Generate recurring dates. @@ -57,7 +57,7 @@ Library hs-source-dirs: src - ghc-options: -Wall + ghc-options: -Wall -fno-warn-name-shadowing -- Modules exported by the library. Exposed-modules: Data.Time.Recurrence