time-recurrence 0.2 → 0.4.2
raw patch · 3 files changed
+522/−188 lines, 3 filesdep +HUnitdep +mtldep +old-locale
Dependencies added: HUnit, mtl, old-locale, test-framework, test-framework-hunit
Files
- src/Data/Time/Recurrence.hs +424/−183
- tests/Tests.lhs +74/−0
- time-recurrence.cabal +24/−5
src/Data/Time/Recurrence.hs view
@@ -6,31 +6,71 @@ -- * The @Month@ type , Month (..) - -- * The @Moment@ type+ -- * The @Moment@ type class , Moment (..) - -- * Generate list of recurring @Moment@- , recurBy- , recur+ -- * The @DateTime@ type class+ , DateTime (..) - -- * Create @UTCTime@- , utcGregorian- , utcGregorianWithTime+ -- * The @InitialMoment@ type+ , InitialMoment (..) - -- * @Recurrence@ type rule effects- , byMonth- , byWeekNumber- , byYearDay- , byMonthDay- , byDay + , toInterval+ , toStartOfWeek++ , secondly+ , minutely+ , hourly+ , daily+ , weekly+ , monthly+ , yearly++ , secondlyUTC+ , minutelyUTC+ , hourlyUTC+ , dailyUTC+ , weeklyUTC+ , monthlyUTC+ , yearlyUTC++ -- * Recurrence combinators+ , enumYear+ , enumMonth+ , enumWeek++ , restrict+ , bySeconds+ , byMinutes+ , byHours+ , byWeekDays+ , byMonthDays+ , byMonths+ , byYearDays++ , expand+ , onWeekNumbers+ , onMonths+ , onMonthDays+ , onYearDays++ , onEachWeek+ , onEachMonth+ , onEachYear++ , repeatSchedule+ , repeatSchedule' ) where -import Data.List.Ordered (nub, nubSort)-import Data.Maybe (mapMaybe, fromJust)+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 -- | Symbolic week days. --@@ -93,78 +133,41 @@ toEnum unmatched = error ("Month.toEnum: Cannot match " ++ show unmatched) --- | @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)---- | 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--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}---- | @Time@ data type-data Time = T- { year :: Integer- , month :: Month- , day :: Int- , hour :: Int- , minute :: Int- , second :: Int- , yearDay :: Int- , weekDay :: WeekDay+-- | @DateTime@ data type+-- This is a componentized version of a time value+-- simmilar to a 'struct tm'+data DateTime = DateTime+ { dtSecond :: Int+ , dtMinute :: Int+ , dtHour :: Int+ , dtDay :: Int+ , dtMonth :: Month+ , dtYear :: Integer+ , dtWeekDay :: WeekDay+ , dtYearDay :: Int+ , dtTimeZone :: TimeZone } deriving (Show) --- | 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- yDay = snd $ toOrdinalDate utcDay- (_, dow) = mondayStartWeek utcDay+-- | @Frequency@ data type+data Frequency+ = Seconds+ | Minutes+ | Hours+ | Days+ | Weeks+ | Months+ | Years+ deriving (Show) --- | Convert the @Time@ components into a @UTCTime@-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)+newtype Interval = Interval Integer deriving (Show)+newtype StartOfWeek = StartOfWeek { fromStartOfWeek :: WeekDay } deriving (Show) --- | Construct a @UTCTime@ at midnight-utcGregorian :: Integer -> Int -> Int -> UTCTime-utcGregorian y m d = UTCTime (fromGregorian y m d) (timeOfDayToTime midnight)+toInterval :: Integer -> Interval+toInterval = Interval --- | 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))+toStartOfWeek :: WeekDay -> StartOfWeek+toStartOfWeek = StartOfWeek -- useful time constants oneSecond :: Integer@@ -182,76 +185,206 @@ oneWeek :: Integer oneWeek = 7 * oneDay --- UTCTime addition-addTime :: Integer -> UTCTime -> UTCTime-addTime i = addUTCTime (fromIntegral i)+-- | The @Moment@ class is for representing a instance in time.+--+-- Instances of @Moment@ can be derived for any user-defined+-- datatype for which can satisfy the minimal complete definition.+--+-- Minimal complete definition: 'epoch', 'toDateTime', 'fromDateTime',+-- 'scaleTime', 'scaleMonth', 'scaleYear', 'alterWeekNumber',+-- 'alterYearDay' -addUTCDays :: (Integer -> Day -> Day) -> Integer -> UTCTime -> UTCTime-addUTCDays f i (UTCTime d t) = UTCTime (f i d) t+class Moment a where -addMonthsRollOver :: Integer -> UTCTime -> UTCTime-addMonthsRollOver = addUTCDays addGregorianMonthsRollOver+ -- | Provide a default moment.+ epoch :: a -addYearsRollOver :: Integer -> UTCTime -> UTCTime-addYearsRollOver = addUTCDays addGregorianYearsRollOver+ -- | Convert a @Moment@ into a @DateTime@+ toDateTime :: a -> DateTime --- | Moment addition-scaleUTCTime :: (Integer -> UTCTime -> UTCTime) -> Integer -> Moment -> Moment -scaleUTCTime f s m = m{moment = f s (moment m)}+ -- | Convert a @DateTime@ into a @Moment@+ fromDateTime :: DateTime -> Maybe a --- | Increment a Moment to its next value-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+ -- | Produce a new @Moment@ offset by a given number of seconds.+ scaleTime :: a -> Integer -> a --- | Generate recurrences from the startDate, filtered by optional rules-recurBy :: Integer -> [Moment -> [Moment]] -> Moment -> [Moment]-recurBy interval subRules startDate = nub $ applySubRules $ recurFrom startDate+ -- | Produce a new @Moment@ offset by a given number of months.+ scaleMonth :: a -> Integer -> a++ -- | Produce a new @Moment@ offset by a given number of years.+ scaleYear :: a -> Integer -> a++ -- | Possibly produce a new @Moment@ shifted to a different week of the year.+ alterWeekNumber :: StartOfWeek -> a -> Int -> Maybe a++ -- | Possibly produce a new @Moment@ shifted to a different day of the year.+ alterYearDay :: a -> Int -> Maybe a++ -- | The 'alter*' methods can potentially produce invalid dates.+ -- + -- For each user-defined @Moment@ instance the definitions of+ -- 'toDateTime', 'fromDateTime', 'alterWeekNumber' and 'alterYearDay' + -- will determine if an altered @Moment@ that lands on an invalid date+ -- in the given calendar will be reduced to @Nothing@++ -- | Possibly produce a new @Moment@ shifted to a different second of the day.+ alterSecond :: a -> Int -> Maybe a+ alterSecond x s = fromDateTime (toDateTime x){dtSecond = s}++ -- | Possibly produce a new @Moment@ shifted to a different minute of the day.+ alterMinute :: a -> Int -> Maybe a+ alterMinute x m = fromDateTime (toDateTime x){dtMinute = m}++ -- | Possibly produce a new @Moment@ shifted to a different hour of the day.+ alterHour :: a -> Int -> Maybe a+ alterHour x h = fromDateTime (toDateTime x){dtHour = h}++ -- | Possibly produce a new @Moment@ shifted to a different day of the month.+ alterDay :: a -> Int -> Maybe a+ alterDay x d = fromDateTime (toDateTime x){dtDay = d}++ -- | Possibly produce a new @Moment@ shifted to a different month of the year.+ alterMonth :: a -> Month -> Maybe a+ alterMonth x m = fromDateTime (toDateTime x){dtMonth = m}++ -- | Possibly produce a new @Moment@ shifted to a different year.+ alterYear :: a -> Integer -> Maybe a+ alterYear x y = fromDateTime (toDateTime x){dtYear = y}++ -- | Produce a new @Moment@ in the future ocurring at (/interval/ * /freq/)+ 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)++ -- | Produce a new @Moment@ in the past ocurring at (-/interval/ * /freq/)+ prev :: Interval -> Frequency -> a -> a+ prev (Interval interval) = next $ Interval (-interval)++-- | The @InitialMoment@ datatype++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++-- | Default initial moments++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++-- | The @Schedule@ datatype++newtype Schedule a = Schedule {fromSchedule :: [a]} deriving (Show, Eq, Ord)++-- | Produce an infinite list from an initial @Moment@ and a step function.+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- recurFrom = iterate $ next interval- fapply fs xs = foldl (\xs' f -> f xs') xs fs- applySubRules = fapply (map concatMap subRules)+ step' i = step (interval i) (frequency i) --- | Default interval of 1-recur :: [Moment -> [Moment]] -> Moment -> [Moment]-recur = recurBy 1+-- | 'enumFutureMoments' is a @Schedule@ of all future moments derived+-- from the @InitialMoment@+enumFutureMoments :: Moment a => RecurringSchedule a+enumFutureMoments = enumMoments next --- | 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'+-- | 'enumPastMoments' goes in the opposite direction of 'enumFutureMoments'+enumPastMoments :: Moment a => RecurringSchedule a+enumPastMoments = enumMoments prev++-- | 'enumPeriod' produces a period from /beg/ to /end/+enumPeriod :: (Moment a, Ord a) => a -> a -> RecurringSchedule a+enumPeriod beg end = do+ i <- ask+ return $ Schedule $ takeWhile (<= end) $ iterateMoments (step i) beg where- yearly = Yearly . moment - startDate = fromJust $ momentChangeYearDay m 1- startDate' = Daily $ moment startDate-moments (Monthly u) = map monthly $ take days $ recur [] startDate+ step i = next (interval i) (frequency i)++-- | 'enumPeriodFrom' generalizes 'enumPeriod' by allowing an explicit+-- starting moment+enumPeriodFrom :: (Moment a, Ord a) => + InitialMoment a+ -> a+ -> a+ -> RecurringSchedule a+enumPeriodFrom i' beg end = local (const i') (enumPeriod beg end)++-- | 'enumYear' produces all days in the year starting with /m/+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- 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')+ eoy = if isLeapYear $ dtYear $ toDateTime m then 366 else 365+ endDate = fromJust $ alterYearDay m eoy+ startDate' = max (fromJust $ alterYearDay m 1)++-- | 'enumMonth' produces all days in the current month starting with /m/+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- weekly = Weekly . moment- tm = utcToTime u- delta = fromEnum (weekDay tm) - fromEnum Monday- m' = fromJust $ momentChangeYearDay m (yearDay tm - delta)-moments m = [m]+ dt = toDateTime m+ eom = monthLength (isLeapYear $ dtYear dt) (fromEnum $ dtMonth dt)+ endDate = fromJust $ alterDay m eom+ startDate' = max (fromJust $ alterDay m 1) +-- | 'enumWeek' produces all days in the current week starting with /m/+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+ -- | Normalize an bounded index -- Pass an upper-bound 'ub' and an index 'idx' -- Converts 'idx' < 0 into valid 'idx' > 0 or@@ -265,53 +398,161 @@ where ub' = ub + 1 -limit :: Eq a => [a] -> (Time -> a) -> Moment -> [Moment]-limit xs f m = [m | momentElem m f xs]+mapNormIndex :: Int -> [Int] -> [Int]+mapNormIndex n = mapMaybe (normIndex n) -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+-- | 'restrict', applied to a predicate and a @Schedule@, returns a @Schedule@+-- of those moments that statisfy the predicate.+restrict :: Moment a => (a -> Bool) -> Schedule a -> RecurringSchedule a+restrict f s = return $ Schedule $ filter f $ fromSchedule s -byWeekNumber :: [Int] -> Moment -> [Moment]-byWeekNumber weeks m@(Yearly _) = mapMaybe (momentChangeWeekNumber m) weeks'- where- weeks' = nubSort $ mapMaybe (normIndex 53) weeks-byWeekNumber _ m = [m]+by :: (Moment a, Ord b) => (DateTime -> b) -> [b] -> a -> Bool+by f bs a = f (toDateTime a) `elem` nubSort bs -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+by' :: Moment a => (DateTime -> Int) -> Int -> [Int] -> a -> Bool+by' f n bs = by f $ mapNormIndex n bs -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}}+bySeconds :: Moment a => [Int] -> a -> Bool+bySeconds = by dtSecond -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- +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++-- monadic concatMap+concatMapM :: Applicative m => (a -> m [b]) -> [a] -> m [b]+concatMapM f xs = concat <$> traverse f xs++-- | 'expand', takes an expansion function and a @Schedule@, and maps the+-- expansion function over the moments.+-- Each moment is then replaced with its expansions.+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' runs a schedule with a given /init/ and rule /r/+repeatSchedule :: Moment a => + InitialMoment a + -> (Schedule a -> RecurringSchedule a)+ -> [a]+repeatSchedule init r = fromSchedule $ runReader (enumFutureMoments >>= r) init++-- | 'repeatSchedule'' is like 'repeatSchedule' but it takes no rules+repeatSchedule' :: Moment a =>+ InitialMoment a+ -> [a]+repeatSchedule' init = repeatSchedule init return++-- | Instance of the @Moment@ class defined for the @UTCTime@ datatype.++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 -- just called here to shut GHC up for now+ 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++ -- TODO: First argument is StartOfWeek and is ignored right now. fix.+ 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++-- | @InitialMoment@ defaults for @UTCTime@++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
+ tests/Tests.lhs view
@@ -0,0 +1,74 @@+HUnut test suite of example recurrences lifted from RFC 5545 section 3.8.5.3++> module Main where++> import Test.Framework (Test, defaultMain, testGroup)+> import Test.Framework.Providers.HUnit+> import Test.HUnit hiding (Test)++There are various dates used during these tests, some as start dates and+some as end dates.++The examples are actually all in the America/New_York time zone, but since+a local time instance has not been created yet, all the dates are converted+into UTC.++> import System.Locale (defaultTimeLocale, rfc822DateFormat)+> import Data.Time+> import Data.Maybe (fromJust)++> import Prelude hiding (until)+> import Control.Monad ((>=>))+> import Data.Time.Recurrence++We are certain of the validity of the dates used, and so fromJust is safe+to use.++> parse822Time :: String -> UTCTime+> parse822Time = zonedTimeToUTC +> . fromJust +> . parseTime defaultTimeLocale rfc822DateFormat+> date1 = parse822Time "Tue, 02 Sep 1997 09:00:00 -0400"+> date2 = parse822Time "Wed, 24 Dec 1997 00:00:00 -0400"+> date3 = parse822Time "Thu, 01 Jan 1998 09:00:00 -0400"+> date4 = parse822Time "Mon, 01 Jan 2000 09:00:00 -0400"++> main :: IO ()+> main = defaultMain tests++> until :: (Moment a, Ord a) => a -> [a] -> [a]+> until m = takeWhile (<= m)++> tests :: [Test]+> tests = +> [ testGroup "RFC5445 Examples" $ zipWith (testCase . show) [1::Int ..]+> [ assertEqual ("Test Daily from "++ show date1 ++". 10 Occurrences") +> (take 10 $ repeatSchedule' dailyUTC{moment = date1})+> (take 10 $ repeatSchedule monthlyUTC{moment = date1} $ expand (onMonthDays [2 .. 11]))+> , assertEqual ("Test Daily from "++ show date1 ++". Until "++ show date2)+> (until date2 $ repeatSchedule' dailyUTC{moment = date1})+> (until date2 $ repeatSchedule monthlyUTC{moment = date1} $ expand onEachMonth)+> , assertBool ("Test every other day from "++ show date1 ++". Cap at 10000")+> (checkDayDist 2 $ take 10000 $ repeatSchedule' dailyUTC{moment = date1, interval = toInterval 2})+> , assertEqual ("Test every 10 days from "++ show date1 ++". 5 Occurrences")+> (take 5 $ repeatSchedule' dailyUTC{moment = date1, interval = toInterval 10})+> (take 5 $ repeatSchedule yearlyUTC{moment = date1} $ expand (onMonths [September,October]) >=> expand (onMonthDays [2,12,22]))+> , assertEqual "Test every day in Jan. for 3 years"+> (until date4 $ repeatSchedule yearlyUTC{moment = date3} $ expand (onMonths [January]) >=> expand onEachMonth)+> (until date4 $ repeatSchedule dailyUTC{moment = date3} $ restrict (byMonths [January]))+> ]+> ]++This is the assertion function for testing the number of days between moments.+It will be used in a couple of tests, and requires at least two moments to +operate correctly.++> dayDist :: [UTCTime] -> [Integer]+> dayDist [] = []+> dayDist (_:[]) = []+> dayDist (x:xs) = fst $ foldl go ([], utcDay x) xs+> where+> go acc x = let d = utcDay x in (abs (diffDays d (snd acc)):fst acc, d)+> utcDay (UTCTime d _) = d+> checkDayDist :: Integer -> [UTCTime] -> Bool+> checkDayDist d = all (== d) . dayDist
time-recurrence.cabal view
@@ -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.2+Version: 0.4.2 -- A short (one-line) description of the package. Synopsis: Generate recurring dates.@@ -44,17 +44,21 @@ Build-type: Simple -- Constraint on the version of Cabal needed to build this package.-Cabal-version: >=1.6+Cabal-version: >=1.10 -- Extra files to be distributed with the package, such as examples or -- a README. Extra-source-files: - README, AUTHORS+ README, AUTHORS, tests/Tests.lhs source-repository head type: git location: http://github.com/hellertime/time-recurrence +flag test-suite+ description: Build the test suite+ default: False+ Library hs-source-dirs: src ghc-options: -Wall -fno-warn-name-shadowing@@ -65,11 +69,26 @@ -- Packages needed in order to build this package. Build-depends: base >= 4 && < 5, time >= 1.2 && < 1.2.0.6,- data-ordlist >= 0.4 && < 0.4.5+ data-ordlist >= 0.4 && < 0.4.5,+ mtl >= 2.0.1.0 && < 2.1 + Default-Language: Haskell98 -- Modules not exported by this package. -- Other-modules: -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. -- Build-tools: - ++Test-Suite test-time-recurrence+ type: exitcode-stdio-1.0+ hs-source-dirs: src, tests+ main-is: Tests.lhs+ ghc-options: -Wall -fno-warn-name-shadowing+ build-depends: base >= 4 && < 5,+ test-framework >= 0.4.0 && < 0.5,+ test-framework-hunit >= 0.2.6 && < 0.3,+ HUnit >= 1.2.2.3 && < 1.3,+ old-locale >= 1.0.0.2 && < 1.1+ other-modules:+ Data.Time.Recurrence+ default-language: Haskell98