packages feed

time-recurrence 0.4.2 → 0.5.2

raw patch · 15 files changed

+1099/−565 lines, 15 files

Files

README view
@@ -4,3 +4,238 @@ library, however the library does not make an effort to track the RFC at all times. A future Data.Time.Recurrence.RFC5545 library would be a useful add-on for those in need of strict RFC compliance.++Examples:++> parse822Time :: String -> UTCTime+> parse822Time = ...++> nov1996 = parse822Time "Tue, 05 Nov 1996 09:00:00 -0400"+> mar1997 = parse822Time "Mon, 10 Mar 1997 09:00:00 -0400"+> sep1997 = parse822Time "Tue, 02 Sep 1997 09:00:00 -0400"+> oct1997 = parse822Time "Fri, 10 Oct 1997 00:00:00 -0400"+> dec1997 = parse822Time "Wed, 24 Dec 1997 00:00:00 -0400"+> jan1998 = parse822Time "Thu, 01 Jan 1998 09:00:00 -0400"+> jan2000 = parse822Time "Mon, 31 Jan 2000 09:00:00 -0400"++Daily for 10 occurrences:++> take 10 $ recur daily `begin` sep1997++Daily until Dec. 24, 1997:++> takeWhile (<= dec1997) $ recur daily `begin` sep1997++Every other day - forever:++> recur daily `by` 2 `begin` sep1997++Every 10 days, 5 occurrences:++> take 5 $ recur daily `by` 10 `begin` sep1997++Every day in January, for 3 years:++> takeWhile (<= jan2000) $ recur yearly `starting` jan1998 $+>   enumMonths [January] >=>+>   filterWeekDays [Monday .. Sunday]++> takeWhile (<= jan2000) $ recur daily `starting` jan1998 $+>   enumMonths [January]++Weekly for 10 occurrences:++> take 10 $ recur weekly `begin` sep1997++Weekly until Dec. 24, 1997:++> takeWhile (<= dec1997) $ recur weekly `withStartOfWeek` Sunday `begin` sep1997++Every other week - forever:++> recur weekly `by` 2 `begin` sep1997++Weekly on Tuesday and Thursday for five weeks:++> takeUntil (<= oct1997) $ recur weekly `withStartOfWeek` Sunday `starting` sep1997 $+>   enumWeekDaysInWeek [Tuesday, Thursday]++or++> take 10 $ recur weekly `withStartOfWeek` Sunday `starting` sep1997 $+>   enumWeekDaysInWeek [Tuesday, Thursday]++Every other week (Monday, Wednesday, Firday) until Dec. 24, 1997:++> takeWhile (<= dec1997) $ recur weekly `withStartOfWeek` Sunday `by` 2 `starting` sep1997$+>   enumWeekDaysInWeek [Monday, Wednesday, Friday] >=>++> Every other week on Tuesday and Thursday, for 8 occurrences:++> take 8 $ recur weekly `withStartOfWeek` Sunday `by` 2 `starting` sep1997 $+>   enumWeekDaysInWeek [Tuesday, Thursday]++Monthly on the first Friday for 10 occurrences:++> take 10 $ recur monthly `starting` sep1997 $+>   enumWeekDaysInMonth [Friday] >=>+>   nthWeekDayInMonth [1]++Monthly on the first Friday until Dec. 24, 1997++> takeWhile (<= dec1997) $ recur monthly `starting` sep1997 $+>   enumWeekDaysInMonth [Friday] >=>+>   nthWeekDayInMonth [1]++Every other month on the first and last Sunday of the month for 10 occurrences:++> take 10 $ recur monthly `by` 2 `starting` sep1997 $+>   enumWeekDaysInMonth [Sunday] >=>+>   nthWeekDayInMonth [1,-1]++Monthly on the second-to-last Monday of the month for 6 months:++> take 6 $ recur monthly `starting` sep1997 $+>   enumWeekDaysInMonth [Monday] >=>+>   nthWeekDayInMonth [-2]++Monthly on the third-to-last day of the month, forever:++> recur monthly `starting` sep1997 $ enumDays [-3]++Monthly on the 2nd and 15th of the month for 10 occurrences:++> take 10 $ recur monthly `starting` sep1997 $ enumDays [2,15]++Monthly on the first and last day of the month for 10 occurrences:++> take 10 $ recur monthly `starting` sep1997 $ enumDays [1,-1]++Every 18 months on the 10th thru 15th of the month for 10 occurrences:++> take 10 $ recur monthly `by` 18 `starting` sep1997 $ enumDays [10 .. 15]++Every Tuesday, every other month:++> recur monthly `by` 2 `starting` sep1997 $ enumWeekDaysInMonth [Tuesday]++Yearly in June and July for 10 occurrences:++> take 10 $ recur yearly `starting` sep1997 $ enumMonths [June, July]++Every other year on January thru March for 10 occurrences:++> take 10 $ recur yearly `by` 2 `starting` mar1997 $ +>   enumMonths [January .. March] >=>+>   enumWeekDaysInMonth [Monday .. Sunday]++Every third year on the 1st, 100th, and 200th day for 10 occurrences:++> take 10 $ recur yearly `by` 3 `starting` sep1997 $+>   enumYearDays [1,100,200]++Every 20th Monday of the year, forever:++> recur monthly `starting` sep1997 $ +>   enumWeekDaysInMonth [Monday] >=>+>   nthWeekDay [20]++Monday of week number 20, forever:++> recur yearly `starting` mar1997 $+>   enumWeekNumbers [20] >=>+>   filterWeekDays [Monday]++or++> recur weekly `starting` mar1997 $+>  filterWeekNumbers [20] >=>+>  filterWeekDays [Monday]++Every Thursday in March, forever:++> recur yearly `starting` mar1997 $+>   enumMonths [March] >=>+>   enumWeekDaysInMonth [Thrusday]++Every Thursday, but only during June thru August, forever:++> recur yearly `starting` mar1997 $+>   enumMonths [June .. August] >=>+>   enumWeekDaysInMonth [Thursday]++Firday the 13th, Forever:++> recur monthly `starting` sep1997 $ enumDays [13] >=> filterWeekDays [Friday]++The first Saturday that follows the first Sunday of the month, forever:++> recur monthly sep1997 $+>   enumDays [7 .. 13] >=>+>   filterWeekDays [Saturday]++U.S. Presidential Election Day:+Every 4 years, the first Tuesday after a Monday in November, forever:++> recur yearly `by` 4 `starting` nov1996 $+>   enumMonths [November] >=>+>   enumDays [2 .. 8] >=>+>   filterWeekDays [Tuesday]++The third instance into the month of one of Tuesday, Wednesday, or Thursday, for the next 3 months.++> take 3 $ recur monthly `starting` sep1997 $+>   enumWeekDaysInMonth [Tuesday .. Thursday] >=>+>   nthWeekDayInMonth [3]++The second-to-last weekday of the month:++> recur monthly `starting` sep1997 $+>   enumWeekDaysOfMonth [Monday .. Friday] >=>+>   nthWeekDayOfMonth [-2]++Every 3 hours from 9:00 AM to 5:00 PM on a specific day:++> takeWhile (<= addSeconds sep1997 (8 * oneHour)) $ +>   recur hourly `by` 3 `begin` sep1997++Every 15 minutes for 6 occurrences:++> take 6 $ recur minutely `by` 15 `begin` sep1997++Every hour and a hald for 4 occurrences:++> take 4 $ recur minutely `by` 90 `begin` sep1997++Every 20 minutes from 9:00 AM to 4:40 PM every day:++> recur daily `starting` sep1997 $+>   enumHours [9 .. 16] >=>+>   enumMinutes [0,20,40]++or++> recur minutely `by` 20 `starting` sep1997 $ enumHours [9 .. 16]++The following two examples will generate different results due to changes in the start of the week.++> take 4 $ recur weekly `by` 2 `withStartOfWeek` Monday $+>   enumWeekDaysInWeek [Tuesday,Sunday]++vs++> take 4 $ recur weekly `by` 2 `withStartOfWeek` Sunday $+>   enumWeekDaysInWeek [Tuesday,Sunday]++An example where an invalid date (Feb. 30) is ignored:++> take 5 $ recur monthly `starting` jan2000 $ enumDays [15,30]++The 15th and the 30th of the month, forever:++> recur monthly `starting` sep1997 $ enumDays [15,30]++The 15th and the 30th of the month, but only during the work week:+> recur monthly `starting` sep1997 $+>   enumDays [15,30] >=>+>   filterWeekDays [Monday .. Friday]
+ src/Data/Time/Calendar/Month.hs view
@@ -0,0 +1,50 @@+module Data.Time.Calendar.Month+    (+      -- * Month+      Month (..)+    ) +  where++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)
+ src/Data/Time/Calendar/WeekDay.hs view
@@ -0,0 +1,16 @@+module Data.Time.Calendar.WeekDay+    (+      -- * WeekDay+      WeekDay(..)+    )+  where++data WeekDay +    = Monday +    | Tuesday +    | Wednesday +    | Thursday +    | Friday +    | Saturday +    | Sunday+  deriving (Show, Eq, Ord, Enum, Bounded)
+ src/Data/Time/CalendarTime.hs view
@@ -0,0 +1,7 @@+module Data.Time.CalendarTime+    (+      module Data.Time.CalendarTime.CalendarTime+    )+  where++import Data.Time.CalendarTime.CalendarTime
+ src/Data/Time/CalendarTime/CalendarTime.hs view
@@ -0,0 +1,124 @@+module Data.Time.CalendarTime.CalendarTime+    (+      -- * Calendar Time+      CalendarTime (..)+    , toDay+    , withDay+    , toTimeOfDay+    , daysInYear+    , lastDayOfMonth+    , weekNumber++      -- * Calendar Time Convertible+    , CalendarTimeConvertible (..)+    ) +  where++import Data.Time+import Data.Time.Calendar.OrdinalDate+import Data.Time.Calendar.Month+import Data.Time.Calendar.WeekDay+import Data.Time.Moment.StartOfWeek+import System.IO.Unsafe++-- | A representation of calendar time separated into year, month, day, and so on.+data CalendarTime = CalendarTime +    {+      calendarSecond   :: Int+    , calendarMinute   :: Int+    , calendarHour     :: Int+    , calendarDay      :: Int+    , calendarMonth    :: Month+    , calendarYear     :: Integer+    , calendarWeekDay  :: WeekDay+    , calendarYearDay  :: Int+    , calendarTimeZone :: TimeZone+} deriving (Eq,Ord,Show)++-- | The class of types which can be converted to a 'CalendarTime'+class CalendarTimeConvertible t where+  -- | Convert to a 'CalendarTime'+  toCalendarTime :: t -> CalendarTime+  -- | Convert from a 'CalendarTime'+  fromCalendarTime :: CalendarTime -> Maybe t++instance CalendarTimeConvertible CalendarTime where+  toCalendarTime = id+  fromCalendarTime = Just . id++-- | Convert to a 'Day'+toDay :: CalendarTime -> Maybe Day+toDay t = fromGregorianValid (calendarYear t) (fromEnum $ calendarMonth t) (calendarDay t)++-- | Convert to a 'TimeOfDay'+toTimeOfDay :: CalendarTime -> Maybe TimeOfDay+toTimeOfDay t = makeTimeOfDayValid (calendarHour t) (calendarMinute t) (toEnum $ calendarSecond t)++-- | Change y-m-d in 'CalendarTime'+withDay :: CalendarTime -> Day -> CalendarTime+withDay ct day = ct+               { calendarYear = y+               , calendarMonth = toEnum m+               , calendarDay = d}+  where+    (y, m, d) = toGregorian day++dayInfo :: +  Day +  -> ( Integer -- Year+     , Int     -- Month+     , Int     -- Day+     , WeekDay -- Week Day+     , Int     -- Year Day+     )+dayInfo day = let+  (y, m, d) = toGregorian day+  weekDay   = toEnum $ snd (mondayStartWeek day) - 1+  yearDay   = snd $ toOrdinalDate day+  in (y, m, d, weekDay, yearDay)+  ++instance CalendarTimeConvertible UTCTime where+  toCalendarTime (UTCTime utcDay utcTime) = CalendarTime (fromEnum ss) mm hh d (toEnum m) y weekDay yearDay utc+    where+      (TimeOfDay hh mm ss) = timeToTimeOfDay utcTime+      (y, m, d, weekDay, yearDay) = dayInfo utcDay++  fromCalendarTime t = do+    day <- toDay t+    time <- toTimeOfDay t+    return $ UTCTime day (timeOfDayToTime time)++instance CalendarTimeConvertible LocalTime where+  toCalendarTime (LocalTime day t) = CalendarTime (fromEnum $ todSec t) (todMin t) (todHour t) d (toEnum m) y weekDay yearDay tz+    where+      (y, m, d, weekDay, yearDay) = dayInfo day+      tz = unsafePerformIO getCurrentTimeZone++  fromCalendarTime t = do+    day <- toDay t+    time <- toTimeOfDay t+    return $ LocalTime day time++instance CalendarTimeConvertible ZonedTime where+  toCalendarTime (ZonedTime (LocalTime day t) tz) = CalendarTime (fromEnum $ todSec t) (todMin t) (todHour t) d (toEnum m) y weekDay yearDay tz+    where+      (y, m, d, weekDay, yearDay) = dayInfo day++  fromCalendarTime t = do+    day <- toDay t+    time <- toTimeOfDay t+    return $ ZonedTime (LocalTime day time) (calendarTimeZone t)++daysInYear :: (CalendarTimeConvertible a) => a -> Int+daysInYear t = let ct = toCalendarTime t+  in if isLeapYear $ calendarYear ct then 366 else 365++lastDayOfMonth :: (CalendarTimeConvertible a) => a -> Int+lastDayOfMonth t = let ct = toCalendarTime t+  in gregorianMonthLength (calendarYear ct) (fromEnum $ calendarMonth ct)++weekNumber :: (CalendarTimeConvertible a) => StartOfWeek -> a -> Maybe Int+weekNumber _  t = do+  day <- toDay $ toCalendarTime t+  return $ fst $ mondayStartWeek day
+ src/Data/Time/Moment.hs view
@@ -0,0 +1,10 @@+module Data.Time.Moment+    (+      module ReExport+    )+  where++import Data.Time.Moment.Interval as ReExport+import Data.Time.Moment.Moment as ReExport+import Data.Time.Moment.StartOfWeek as ReExport+import Data.Time.Moment.UTC as ReExport
+ src/Data/Time/Moment/Interval.hs view
@@ -0,0 +1,12 @@+module Data.Time.Moment.Interval+    (+      -- * Interval+      Interval (fromInterval)+    , toInterval+    )+  where++import Data.Time.Moment.Private++toInterval :: Integer -> Interval+toInterval = Interval
+ src/Data/Time/Moment/Moment.hs view
@@ -0,0 +1,224 @@+module Data.Time.Moment.Moment+    (+      -- * Moment+      Moment (..)+    , iterateMoments+    , withYearDay+    , withWeekNumber+    , withSecond+    , withMinute+    , withHour+    , withDay+    , withMonth+    , withYear+    , advanceToWeekDay++      -- * Initial Moment+    , InitialMoment (..)++      -- * Default Initial Moment+    , secondly+    , minutely+    , hourly+    , daily+    , weekly+    , monthly+    , yearly++      -- * Adjust Interval+    , by+      -- * Adjust Start of Week+    , withStartOfWeek++      -- * Period+    , Period (..)+    )+  where++import Data.Time.Calendar.Month+import Data.Time.Calendar.OrdinalDate+import Data.Time.Calendar.WeekDay+import Data.Time.CalendarTime hiding (withDay)+import qualified Data.Time.CalendarTime as CT+import Data.Time.Moment.Interval+import Data.Time.Moment.Private+import Data.Time.Moment.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++-- | 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', 'addSeconds', 'addMonths', 'addYears'++class Moment a where+  -- | Provide a default moment.+  epoch      :: a+  addSeconds :: a -> Integer -> a+  addMonths  :: a -> Integer -> a+  addYears   :: a -> Integer -> a++  addMinutes :: a -> Integer -> a+  addMinutes a = addSeconds a . (* oneMinute)+  addHours   :: a -> Integer -> a+  addHours a = addSeconds a . (* oneHour)+  addDays    :: a -> Integer -> a+  addDays a = addSeconds a . (* oneDay)+  addWeeks   :: a -> Integer -> a+  addWeeks a = addSeconds a . (* oneWeek)++  -- | Produce a new @Moment@ in the future ocurring at (/interval/ * /freq/)+  next :: Interval -> Period -> a -> a+  next (Interval interval) freq =+    case freq of+      Seconds -> add oneSecond+      Minutes -> add oneMinute+      Hours   -> add oneHour+      Days    -> add oneDay+      Weeks   -> add oneWeek+      Months  -> flip addMonths interval+      Years   -> flip addYears interval+    where+      add x = flip addSeconds (interval * x)++  -- | Produce a new @Moment@ in the past ocurring at (-/interval/ * /freq/)+  prev :: Interval -> Period -> a -> a+  prev (Interval interval) = next $ Interval (-interval)++-- | Produce an infinite list from an initial @Moment@ and a step function.+iterateMoments :: Moment a => (a -> a) -> a -> [a]+iterateMoments = iterate++-- | Possibly produce a 'Moment' with the given week number+withWeekNumber :: +  (CalendarTimeConvertible a, Moment a) => +  StartOfWeek +  -> a +  -> Int +  -> Maybe a+withWeekNumber _ t wk = do+  let ct = toCalendarTime t+  day <- fromMondayStartWeekValid (calendarYear ct) wk (fromEnum $ calendarWeekDay ct)+  fromCalendarTime $ CT.withDay ct day++-- | Possibly produce a 'Moment' with the given day of the year+withYearDay ::+  (CalendarTimeConvertible a, Moment a) =>+  a+  -> Int+  -> Maybe a+withYearDay t yd = do+ let ct = toCalendarTime t+ day <- fromOrdinalDateValid (calendarYear ct) yd+ fromCalendarTime $ CT.withDay ct day++-- | Possibly produce a 'Moment' with the given second+withSecond :: (CalendarTimeConvertible a, Moment a) => a -> Int -> Maybe a+withSecond t s = fromCalendarTime (toCalendarTime t){calendarSecond = s}++-- | Possibly produce a 'Moment' with the given minute+withMinute :: (CalendarTimeConvertible a, Moment a) => a -> Int -> Maybe a+withMinute t m = fromCalendarTime (toCalendarTime t){calendarMinute = m}++-- | Possibly produce a 'Moment' with the given hour+withHour :: (CalendarTimeConvertible a, Moment a) => a -> Int -> Maybe a+withHour t h = fromCalendarTime (toCalendarTime t){calendarHour = h}++-- | Possibly produce a 'Moment' with the given month day+withDay :: (CalendarTimeConvertible a, Moment a) => a -> Int -> Maybe a+withDay t d = fromCalendarTime (toCalendarTime t){calendarDay = d}++-- | Possibly produce a 'Moment' with the given month+withMonth :: (CalendarTimeConvertible a, Moment a) => a -> Month -> Maybe a+withMonth t m = fromCalendarTime (toCalendarTime t){calendarMonth = m}++-- | Possibly produce a 'Moment' with the given year+withYear :: (CalendarTimeConvertible a, Moment a) => a -> Integer -> Maybe a+withYear t y = fromCalendarTime (toCalendarTime t){calendarYear = y}++advanceToWeekDay :: +  (CalendarTimeConvertible a, Moment a) => +  a -> +  WeekDay -> +  a+advanceToWeekDay t d = let+  ct  = toCalendarTime t+  d0  = calendarWeekDay ct+  d'  = fromEnum d+  d0' = fromEnum d0+  delta = toInteger $ d' - d0' `mod` 7+  in addDays t $ if delta == 0 then 7 else delta++-- | The @InitialMoment@ datatype++data InitialMoment a = InitialMoment+    { period      :: Period+    , interval    :: Interval+    , startOfWeek :: StartOfWeek+    , moment      :: a+    }+  deriving (Show)++mkIM :: Moment a => Period -> 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++-- | Typically called infix on an existing 'InitialMoment', like:+-- +-- > monthly `by` 2+by :: InitialMoment a -> Integer -> InitialMoment a+by im i = im{interval=toInterval i}++-- | Typically called infix on an existing 'InitialMoment', like:+--+-- > weekly `withStartOfWeek` Tuesday+withStartOfWeek :: InitialMoment a -> WeekDay -> InitialMoment a+withStartOfWeek im sow = im{startOfWeek=toStartOfWeek sow}++-- | @Period@ data type+data Period+    = Seconds+    | Minutes+    | Hours+    | Days+    | Weeks+    | Months+    | Years+  deriving (Enum, Bounded, Eq, Ord, Show)
+ src/Data/Time/Moment/Private.hs view
@@ -0,0 +1,14 @@+module Data.Time.Moment.Private+    (+      -- * Interval+      Interval (..)+     +      -- * StartOfWeek+    , StartOfWeek (..)+    )+  where++import Data.Time.Calendar.WeekDay++newtype Interval = Interval { fromInterval :: Integer } deriving (Show)+newtype StartOfWeek = StartOfWeek { fromStartOfWeek :: WeekDay } deriving (Show)
+ src/Data/Time/Moment/StartOfWeek.hs view
@@ -0,0 +1,13 @@+module Data.Time.Moment.StartOfWeek+    (+      -- * StartOfWeek+      StartOfWeek (fromStartOfWeek)+    , toStartOfWeek+    )+  where++import Data.Time.Calendar.WeekDay+import Data.Time.Moment.Private++toStartOfWeek :: WeekDay -> StartOfWeek+toStartOfWeek = StartOfWeek
+ src/Data/Time/Moment/UTC.hs view
@@ -0,0 +1,43 @@+module Data.Time.Moment.UTC+    (+      secondlyUTC+    , minutelyUTC+    , hourlyUTC+    , dailyUTC+    , weeklyUTC+    , monthlyUTC+    , yearlyUTC+    )+  where++import Data.Time+import Data.Time.Moment.Moment++instance Moment UTCTime where+  epoch = UTCTime (toEnum 0) 0+  addSeconds utc i = addUTCTime (fromIntegral i) utc+  addMonths (UTCTime d t) i = UTCTime (addGregorianMonthsRollOver i d) t+  addYears (UTCTime d t) i = UTCTime (addGregorianYearsRollOver i d) t++-- | @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
src/Data/Time/Recurrence.hs view
@@ -1,558 +1,12 @@ module Data.Time.Recurrence     (-      -- * The @WeekDay@ type-      WeekDay (..)--      -- * The @Month@ type-    , Month (..)--      -- * The @Moment@ type class-    , Moment (..)--      -- * The @DateTime@ type class-    , DateTime (..)--      -- * The @InitialMoment@ type-    , InitialMoment (..)--    , 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'+      CalendarTime (..)+    , module ReExport     )   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---- | Symbolic week days.------ Note: The first Day of the Week is Monday --- TODO: Move this to a more general library-data WeekDay-    = Monday-    | Tuesday-    | Wednesday-    | Thursday-    | Friday-    | Saturday-    | Sunday-  deriving (Show, Eq, Ord, Enum, Bounded)---- | Symbolic months.------ TODO: Move this to a more general library-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)---- | @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)---- | @Frequency@ data type-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---- useful time constants-oneSecond :: Integer-oneSecond = 1--oneMinute :: Integer-oneMinute = 60 * oneSecond--oneHour :: Integer-oneHour   = 60 * oneMinute--oneDay :: Integer-oneDay    = 24 * oneHour--oneWeek :: Integer-oneWeek   = 7  * oneDay---- | 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'--class Moment a where--  -- | Provide a default moment.-  epoch           :: a--  -- | Convert a @Moment@ into a @DateTime@-  toDateTime      :: a -> DateTime--  -- | Convert a @DateTime@ into a @Moment@-  fromDateTime    :: DateTime -> Maybe a--  -- | Produce a new @Moment@ offset by a given number of seconds.-  scaleTime       :: a -> Integer -> a--  -- | 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-    step' i = step (interval i) (frequency i)---- | 'enumFutureMoments' is a @Schedule@ of all future moments derived--- from the @InitialMoment@-enumFutureMoments :: Moment a => RecurringSchedule a-enumFutureMoments = enumMoments next---- | '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-    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-    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-    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---   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--mapNormIndex :: Int -> [Int] -> [Int]-mapNormIndex n = mapMaybe (normIndex n)---- | '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--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---- 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+import Data.Time.CalendarTime+import Data.Time.Calendar.Month as ReExport+import Data.Time.Calendar.WeekDay as ReExport+import Data.Time.Moment as ReExport+import Data.Time.Recurrence.Schedule as ReExport
+ src/Data/Time/Recurrence/Schedule.hs view
@@ -0,0 +1,316 @@+-- This module is intended to be imported @qualified!, to avoid name+-- clashes with "Prelude" functions. eg.+--+-- > import qualified Data.Time.Recurrence.Schedule as S+module Data.Time.Recurrence.Schedule+    (+      Schedule -- abstract, instances: Eq, Ord, Show+    , recur+    , starting+    , begin++    , enumMonths+    , enumDays+    , enumWeekDaysInWeek+    , enumWeekDaysInMonth+    , enumYearDays+    , enumHours+    , enumMinutes+    , enumSeconds++    , nthMonth+    , nthDay+    , nthWeekDay+    , nthWeekDayOfWeek+    , nthWeekDayOfMonth+    , nthYearDay+    , nthHour+    , nthMinute+    , nthSecond++    , filterMonths+    , filterDays+    , filterWeekDays+    , filterYearDays+    , filterHours+    , filterMinutes+    , filterSeconds+    )+  where++import Control.Monad.Reader+import Data.List as L+import Data.List.Ordered as O+import Data.Maybe (mapMaybe, fromJust)+import Data.Time.Calendar.Month+import Data.Time.Calendar.WeekDay+import Data.Time.CalendarTime hiding (withDay)+import Data.Time.Moment++type Schedule a = Reader (InitialMoment a) [a]++runSchedule :: Schedule a -> InitialMoment a -> [a]+runSchedule = runReader++repeatSchedule :: +  Moment a  => +  InitialMoment a +  -> ([a] -> Schedule a) +  -> [a]+repeatSchedule im sch = runSchedule (iterateInitialMoment >>= sch) im+  where+    iterateInitialMoment :: Moment a => Schedule a+    iterateInitialMoment = do+      im <- ask+      return $ iterate (next (interval im) (period im)) (moment im)++recur :: a -> a+recur = id++-- | 'starting' is an infinite list of 'Moment's, where no 'Moment' +-- occurrs before the 'InitialMoment'. The list is further refined+-- by the passed in function.+starting :: (Ord a, Moment a) => +  InitialMoment a +  -> a +  -> ([a] -> Schedule a) +  -> [a]+starting im m0 = dropWhile (< m0) . O.nub . repeatSchedule im{moment=m0}++begin :: (Ord a, Moment a) => InitialMoment a -> a -> [a]+begin im m0 = starting im m0 return++-- | Normalize an bounded ordinal index+--   Pass an upper-bound 'ub' and an index 'idx'+--   Converts 'idx' < 0 into valid 'idx' > 0 or+--   Nothing+normalizeOrdinalIndex :: Int -> Int -> Maybe Int+normalizeOrdinalIndex _ 0 = Nothing+normalizeOrdinalIndex ub idx =+  if abs idx > ub+    then Nothing+    else Just $ (idx + ub') `mod` ub'+  where+    ub' = ub + 1++enumYearDays ::+  (CalendarTimeConvertible a, Moment a) =>+  [Int]+  -> [a]+  -> Schedule a+enumYearDays days as = return $ concatMap (enumYearDays' days) as+  where+    enumYearDays' days a = mapMaybe (withYearDay a) (days' a days)+    days' a = mapMaybe $ normalizeOrdinalIndex (daysInYear a)++enumMonths :: +  (CalendarTimeConvertible a, Moment a) => +  [Month] +  -> [a] +  -> Schedule a+enumMonths months as = return $ concatMap (enumMonths' months) as+  where +    enumMonths' months a = mapMaybe (withMonth a) months++enumDays ::+  (CalendarTimeConvertible a, Moment a) =>+  [Int]+  -> [a]+  -> Schedule a+enumDays days as = return $ concatMap (enumDays' days) as+  where +    enumDays' days a = mapMaybe (withDay a) (days' a days)+    days' a = mapMaybe $ normalizeOrdinalIndex (lastDayOfMonth a)++enumWeekDaysInWeek ::+  (CalendarTimeConvertible a, Moment a) =>+  [WeekDay]+  -> [a]+  -> Schedule a+enumWeekDaysInWeek wdays as = return $ concatMap (enumWeekDays' wdays) as+  where+    enumWeekDays' :: (CalendarTimeConvertible a, Moment a) => [WeekDay] -> a -> [a]+    enumWeekDays' wdays a0 = let+      w0     = calendarWeekDay $ toCalendarTime a0+      wdays' = dropWhile (/= w0) $ O.nubSort wdays+      in map (advanceToWeekDay a0) wdays'++enumWeekDaysInMonth ::+  (CalendarTimeConvertible a, Moment a) =>+  [WeekDay]+  -> [a]+  -> Schedule a+enumWeekDaysInMonth wdays as = return $ concatMap (enumWeekDays' wdays) as+  where+    enumWeekDays' wdays a = let+      mdays  = mapMaybe (withDay a) [1 .. lastDayOfMonth a]+      in filter (flip elem wdays . calendarWeekDay . toCalendarTime) mdays+      +enumHours ::+  (CalendarTimeConvertible a, Moment a) =>+  [Int]+  -> [a]+  -> Schedule a+enumHours hours as = return $ concatMap (enumHours' hours) as+  where+    enumHours' hours a = mapMaybe (withHour a) (hours' a hours)+    hours' a = mapMaybe $ normalizeOrdinalIndex 23++enumMinutes ::+  (CalendarTimeConvertible a, Moment a) =>+  [Int]+  -> [a]+  -> Schedule a+enumMinutes ms as = return $ concatMap (enumMinutes' ms) as+  where+    enumMinutes' ms a = mapMaybe (withMinute a) (ms' a ms)+    ms' a = mapMaybe $ normalizeOrdinalIndex 59++enumSeconds ::+  (CalendarTimeConvertible a, Moment a) => +  [Int]+  -> [a]+  -> Schedule a+enumSeconds secs as = return $ concatMap (enumSeconds' secs) as+  where+    enumSeconds' secs a = mapMaybe (withSecond a) (secs' a secs)+    secs' a = mapMaybe $ normalizeOrdinalIndex 60++groupWith :: (Ord b) => (a -> b) -> [a] -> [[a]]+groupWith f = groupBy (\a b -> f a == f b)++nth :: [Int] -> [a] -> [a]+nth ns as = map ((as !!) . pred) $ mapMaybe (normalizeOrdinalIndex (length as)) ns++nth' ::+  Ord b => +  (a -> b)+  -> [Int]+  -> [a]+  -> Schedule a+nth' f ns as = return $ concatMap (nth ns) $ groupWith f as++nthYearDay ::+  CalendarTimeConvertible a =>+  [Int]+  -> [a]+  -> Schedule a+nthYearDay = nth' $ calendarYear . toCalendarTime++nthMonth ::+  CalendarTimeConvertible a =>+  [Int]+  -> [a]+  -> Schedule a+nthMonth = nth' $ calendarYear . toCalendarTime++nthDay ::+  CalendarTimeConvertible a =>+  [Int]+  -> [a]+  -> Schedule a+nthDay = nth' $ calendarMonth . toCalendarTime++nthWeekDayOfWeek ::+  CalendarTimeConvertible a =>+  [Int]+  -> [a]+  -> Schedule a+nthWeekDayOfWeek ns as = do+  sow <- asks startOfWeek+  return $ +    concatMap (nth ns) $+    concatMap (groupWith (weekNumber sow)) $+    groupWith (calendarMonth . toCalendarTime) as ++nthWeekDayOfMonth ::+  CalendarTimeConvertible a =>+  [Int]+  -> [a]+  -> Schedule a+nthWeekDayOfMonth = nth' $ calendarMonth . toCalendarTime++nthWeekDay ::+  CalendarTimeConvertible a =>+  [Int]+  -> [a]+  -> Schedule a+nthWeekDay = nth' $ calendarYear . toCalendarTime++nthHour ::+  CalendarTimeConvertible a =>+  [Int]+  -> [a]+  -> Schedule a+nthHour = nth' $ calendarDay . toCalendarTime++nthMinute ::+  CalendarTimeConvertible a =>+  [Int]+  -> [a]+  -> Schedule a+nthMinute = nth' $ calendarHour . toCalendarTime++nthSecond ::+  CalendarTimeConvertible a =>+  [Int]+  -> [a]+  -> Schedule a+nthSecond = nth' $ calendarMinute . toCalendarTime++filterCalendarTime ::+  (CalendarTimeConvertible a, Eq b) =>+  (CalendarTime -> b)+  -> [b]+  -> [a]+  -> Schedule a+filterCalendarTime f xs as = return $ filter (flip elem xs . f . toCalendarTime) as++filterMonths ::+  CalendarTimeConvertible a =>+  [Month]+  -> [a]+  -> Schedule a+filterMonths = filterCalendarTime calendarMonth++filterYearDays ::+  CalendarTimeConvertible a =>+  [Int]+  -> [a]+  -> Schedule a+filterYearDays = filterCalendarTime calendarYearDay++filterDays ::+  CalendarTimeConvertible a =>+  [Int]+  -> [a]+  -> Schedule a+filterDays = filterCalendarTime calendarDay++filterWeekDays ::+  CalendarTimeConvertible a => +  [WeekDay]+  -> [a]+  -> Schedule a+filterWeekDays = filterCalendarTime calendarWeekDay++filterHours ::+  CalendarTimeConvertible a =>+  [Int]+  -> [a]+  -> Schedule a+filterHours = filterCalendarTime calendarHour++filterMinutes ::+  CalendarTimeConvertible a =>+  [Int]+  -> [a]+  -> Schedule a+filterMinutes = filterCalendarTime calendarMinute++filterSeconds ::+  CalendarTimeConvertible a =>+  [Int]+  -> [a]+  -> Schedule a+filterSeconds = filterCalendarTime calendarSecond
tests/Tests.lhs view
@@ -31,7 +31,7 @@ > 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"+> date4 = parse822Time "Mon, 31 Jan 2000 09:00:00 -0400"  > main :: IO () > main = defaultMain tests@@ -43,19 +43,19 @@ > 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]))+>            (take 10 $ recur daily `begin` date1)+>            (take 10 $ recur monthly `starting` date1 $ enumDays [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)+>            (until date2 $ recur daily `begin` date1)+>            (until date2 $ recur monthly `starting` date1 $ enumWeekDaysInMonth [Monday .. Sunday]) >        , assertBool ("Test every other day from "++ show date1 ++". Cap at 10000")->            (checkDayDist 2 $ take 10000 $ repeatSchedule' dailyUTC{moment = date1, interval = toInterval 2})+>            (checkDayDist 2 $ take 10000 $ recur daily `by` 2 `begin` date1)  >        , 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]))+>            (take 5 $ recur daily `by` 10 `begin` date1)+>            (take 5 $ recur yearly `starting` date1 $ enumMonths [September, October] >=> enumDays [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]))+>            (until date4 $ recur yearly `starting` date3 $ enumMonths [January] >=> enumWeekDaysInMonth [Monday .. Sunday])+>            (until date4 $ recur daily `starting` date3 $ filterMonths [January]) >        ] >      ]
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.4.2+Version:             0.5.2  -- A short (one-line) description of the package. Synopsis:            Generate recurring dates.@@ -64,7 +64,20 @@   ghc-options:         -Wall -fno-warn-name-shadowing    -- Modules exported by the library.-  Exposed-modules:     Data.Time.Recurrence+  Exposed-modules:+     Data.Time.Calendar.Month,+     Data.Time.Calendar.WeekDay,+     Data.Time.CalendarTime,+     Data.Time.Moment,+     Data.Time.Moment.Interval,+     Data.Time.Moment.StartOfWeek,+     Data.Time.Recurrence,+     Data.Time.Recurrence.Schedule+  Other-modules:+     Data.Time.CalendarTime.CalendarTime,+     Data.Time.Moment.Moment,+     Data.Time.Moment.Private,+     Data.Time.Moment.UTC      -- Packages needed in order to build this package.   Build-depends:       base >= 4 && < 5,@@ -85,6 +98,9 @@   main-is:              Tests.lhs   ghc-options:          -Wall -fno-warn-name-shadowing   build-depends:        base >= 4 && < 5,+                        time >= 1.2 && < 1.2.0.6,+                        data-ordlist >= 0.4 && < 0.4.5,+                        mtl >= 2.0.1.0 && < 2.1,                         test-framework >= 0.4.0 && < 0.5,                         test-framework-hunit >= 0.2.6 && < 0.3,                         HUnit >= 1.2.2.3 && < 1.3,