diff --git a/README b/README --- a/README +++ b/README @@ -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] diff --git a/src/Data/Time/Calendar/Month.hs b/src/Data/Time/Calendar/Month.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/Calendar/Month.hs @@ -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) diff --git a/src/Data/Time/Calendar/WeekDay.hs b/src/Data/Time/Calendar/WeekDay.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/Calendar/WeekDay.hs @@ -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) diff --git a/src/Data/Time/CalendarTime.hs b/src/Data/Time/CalendarTime.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/CalendarTime.hs @@ -0,0 +1,7 @@ +module Data.Time.CalendarTime + ( + module Data.Time.CalendarTime.CalendarTime + ) + where + +import Data.Time.CalendarTime.CalendarTime diff --git a/src/Data/Time/CalendarTime/CalendarTime.hs b/src/Data/Time/CalendarTime/CalendarTime.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/CalendarTime/CalendarTime.hs @@ -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 diff --git a/src/Data/Time/Moment.hs b/src/Data/Time/Moment.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/Moment.hs @@ -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 diff --git a/src/Data/Time/Moment/Interval.hs b/src/Data/Time/Moment/Interval.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/Moment/Interval.hs @@ -0,0 +1,12 @@ +module Data.Time.Moment.Interval + ( + -- * Interval + Interval (fromInterval) + , toInterval + ) + where + +import Data.Time.Moment.Private + +toInterval :: Integer -> Interval +toInterval = Interval diff --git a/src/Data/Time/Moment/Moment.hs b/src/Data/Time/Moment/Moment.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/Moment/Moment.hs @@ -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) diff --git a/src/Data/Time/Moment/Private.hs b/src/Data/Time/Moment/Private.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/Moment/Private.hs @@ -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) diff --git a/src/Data/Time/Moment/StartOfWeek.hs b/src/Data/Time/Moment/StartOfWeek.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/Moment/StartOfWeek.hs @@ -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 diff --git a/src/Data/Time/Moment/UTC.hs b/src/Data/Time/Moment/UTC.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/Moment/UTC.hs @@ -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 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 @@ -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 diff --git a/src/Data/Time/Recurrence/Schedule.hs b/src/Data/Time/Recurrence/Schedule.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/Recurrence/Schedule.hs @@ -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 diff --git a/tests/Tests.lhs b/tests/Tests.lhs --- a/tests/Tests.lhs +++ b/tests/Tests.lhs @@ -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]) > ] > ] 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.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,