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