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,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 diff --git a/tests/Tests.lhs b/tests/Tests.lhs new file mode 100644 --- /dev/null +++ b/tests/Tests.lhs @@ -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 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.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