time-patterns 0.1.3.1 → 0.1.3.2
raw patch · 3 files changed
+605/−598 lines, 3 filesdep ~basedep ~lens
Dependency ranges changed: base, lens
Files
- src/Data/Time/Patterns.hs +343/−336
- src/Data/Time/Patterns/Internal.hs +221/−221
- time-patterns.cabal +41/−41
src/Data/Time/Patterns.hs view
@@ -1,336 +1,343 @@-{-# LANGUAGE RecordWildCards #-} ------------------------------------------------------------------------------ --- | --- Module : Data.Time.Patterns --- Copyright : (C) 2013 Jann Mueller --- License : BSD3 (see the file LICENSE) --- Maintainer : j.mueller.11@ucl.ac.uk --- Stability : experimental --- Patterns for recurring events. Use the @DatePattern@ type to build up --- a pattern, and the functions @elementOf@, @instancesFrom@ and --- @intervalsFrom@ to evaluate it. --- Simple example: --- --- > import Control.Lens --- > import Data.Thyme.Calendar --- > import Data.Time.Patterns --- > import qualified Prelude as P --- > Module Main where --- > --- > main = do --- > -- get the 6th of April for the next ten years --- > let april6 = (take 1 $ skip 5 day) `inEach` april --- > let today = (YearMonthDay 2013 12 01)^.from gregorian --- > print $ P.take 10 $ instancesFrom today april6 --- --- @DatePattern@s can be combined using @union@, @intersect@ with their --- obvious meanings and @inEach@ which repeats one pattern inside another one. --- For example, --- --- > ((take 1 day) `inEach` august) `intersect` sunday --- --- will give the 1st of August in years when it falls on a Sunday. ----------------------------------------------------------------------------- -module Data.Time.Patterns( - -- * Date Patterns - DatePattern, - day, - mondayWeek, - sundayWeek, - month, - year, - -- ** Months - january, - february, - march, - april, - may, - june, - july, - august, - september, - october, - november, - december, - -- ** Days - monday, - tuesday, - wednesday, - thursday, - friday, - saturday, - sunday, - -- * Operations on date patterns - never, - every, - shiftBy, - inEach, - take, - skip, - except, - intersect, - union, - -- * Queries - elementOf, - instancesFrom, - intervalsFrom - ) where - -import Numeric.Interval -import Control.Lens hiding (elementOf, elements, contains, (...)) -import Data.Thyme.Calendar (Day, Days, Months, YearMonthDay(..), gregorian, modifiedJulianDay, _ymdYear, _ymdMonth, _ymdDay) -import Data.Thyme.Calendar.WeekDate (_mwDay, _swDay) -import qualified Data.Thyme.Calendar.WeekDate as W -import Data.Time.Patterns.Internal hiding (elementOf, every, never, take, skip, except, intersect, occurrencesFrom, union) -import qualified Data.Time.Patterns.Internal as I -import Prelude hiding (cycle, elem, filter, take) - --- | A DatePattern describes a sequence of intervals of type Data.Thyme.Day. -type DatePattern = IntervalSequence' Day - --- | An event that occurs every month. -month :: DatePattern -month = IntervalSequence $ \t -> - let m = firstOfMonth t in - let m' = addMonths 1 m in - Just (m ... m', month) where - --- | Every January. -january :: DatePattern -january = monthOfYear 1 - --- | Every February. -february :: DatePattern -february = monthOfYear 2 - --- | Every March. -march :: DatePattern -march = monthOfYear 3 - --- | Every April. -april :: DatePattern -april = monthOfYear 4 - --- | Every May. -may :: DatePattern -may = monthOfYear 5 - --- | Every June. -june :: DatePattern -june = monthOfYear 6 - --- | Every July. -july :: DatePattern -july = monthOfYear 7 - --- | Every August. -august :: DatePattern -august = monthOfYear 8 - --- | Every September. -september :: DatePattern -september = monthOfYear 9 - --- | Every October. -october :: DatePattern -october = monthOfYear 10 - --- | Every November. -november :: DatePattern -november = monthOfYear 11 - --- | Every December. -december :: DatePattern -december = monthOfYear 12 - --- | An event that occurs every day. -day :: DatePattern -day = IntervalSequence{..} where - nextInterval t = Just (t ... (succ t), day) - --- | Every Monday. -monday :: DatePattern -monday = filter (isDayOfWeek 1) day - --- | Every Tuesday. -tuesday :: DatePattern -tuesday = filter (isDayOfWeek 2) day - --- | Every Wednesday. -wednesday :: DatePattern -wednesday = filter (isDayOfWeek 3) day - --- | Every Thursday. -thursday :: DatePattern -thursday = filter (isDayOfWeek 4) day - --- | Every Friday. -friday :: DatePattern -friday = filter (isDayOfWeek 5) day - --- | Every Saturday. -saturday :: DatePattern -saturday = filter (isDayOfWeek 6) day - --- | Every Sunday. -sunday :: DatePattern -sunday = filter (isDayOfWeek 7) day - --- | Weeks, starting on Monday -mondayWeek :: DatePattern -mondayWeek = IntervalSequence $ \d -> let m = lastMonday d in - Just (m ... addDays 7 m, mondayWeek) - --- | Weeks, starting on Sunday. -sundayWeek :: DatePattern -sundayWeek = IntervalSequence $ \d -> let m = lastSunday d in - Just (m ... addDays 7 m, sundayWeek) - --- | Years, starting from Jan. 1 -year :: DatePattern -year = IntervalSequence $ \d -> let m = jan1 d in - Just (m ... addYears 1 m, year) - --- | The first pattern repeated for each interval of the --- second pattern. E.g.: --- --- > (take 3 $ every 4 monday) `inEach` year --- --- will give the fourth, eighth and twelveth Monday in each year -inEach :: DatePattern -> DatePattern -> DatePattern -inEach i o = IntervalSequence (inEach' o i i) - --- | like inEach, except that the ``inner`` DatePattern is replaced by a sequence of DatePatterns --- so that for every new outer interval, the next element from the sequence will be used. -inEach' :: DatePattern -> DatePattern -> DatePattern -> Day -> Maybe (Interval Day, DatePattern) -inEach' outer inner orig d = do - (o1, outer') <- nextInterval outer d - let inner' = stopAt' (sup o1) inner - case (firstOccurrenceIn (max d $ inf o1) o1 inner') of - Nothing -> inEach' outer' orig orig $ sup o1 - Just (i1,inner'') -> return (i1, IntervalSequence $ inEach' outer inner'' orig) - --- | Shift all the results by a number of day -shiftBy :: Days -> DatePattern -> DatePattern -shiftBy n = mapSequence (addDays n) - --- | Add a number of day to a day -addDays :: Days -> Day -> Day -addDays n d = (d^.modifiedJulianDay + n)^.from modifiedJulianDay - --- | Take every nth occurrence -every :: (Num i, Ord i) => i -> DatePattern -> DatePattern -every = I.every - --- | Stop after n occurrences -take :: (Num i, Ord i) => i -> DatePattern -> DatePattern -take = I.take - --- | Skip the first n occurrences -skip :: (Num i, Ord i) => i -> DatePattern -> DatePattern -skip = I.skip - --- | Skip over all occurrences of a day. --- If the pattern describes a period longer --- than a day, the entire period will be --- skipped. -except :: Day -> DatePattern -> DatePattern -except = I.except - --- | Check if a date is covered by a DatePattern -elementOf :: Day -> DatePattern -> Bool -elementOf = I.elementOf - --- | Get occurrences of an event starting with a given day -instancesFrom :: Day -> DatePattern -> [Day] -instancesFrom = I.elementsFrom - --- | An event that never occurs -never :: DatePattern -never = I.never - --- | Return only occurrences that are present in both patterns --- --- > let myBirthday = (take 1 day) `inEach` august --- > let s = intersect myBirthday sunday --- --- Will return August 1 in years when it falls on a Sunday -intersect :: DatePattern -> DatePattern -> DatePattern -intersect = I.intersect - --- | Occurrences of both patterns. --- --- > union april june --- --- Will return the months April and June in each year --- --- > let fifteenth = (take 1 $ skip 14 day) `inEach` month --- > let third = (take 1 $ skip 2 day) `inEach` month --- > union fifteenth third --- --- Will return the 3rd and the 15th of each month -union :: DatePattern -> DatePattern -> DatePattern -union = I.union - --- | Get the date intervals described by the pattern, starting --- from the specified date. --- --- The intervals range from the first --- day included by the pattern to the first day after it, so --- a single day @d@ would be described as @(d ... succ d)@ and --- the interval for a month will go from the 1st of the month --- to the 1st of the next month. -intervalsFrom :: Day -> DatePattern -> [Interval Day] -intervalsFrom = I.occurrencesFrom - --- | Check if a day interval covers exactly a given weekday --- with Monday = 1, Tuesday = 2, etc. -isDayOfWeek :: Int -> Interval Day -> Bool -isDayOfWeek d i = case (elements i) of - [dt] -> dt^. W.mondayWeek . _mwDay == d - _ -> False - --- | Get the last Monday before or on the date -lastMonday :: Day -> Day -lastMonday d = case (d^.W.mondayWeek._mwDay) of - 1 -> d - _ -> lastMonday $ pred d - - --- | Get the last Monday before or on the date -lastSunday :: Day -> Day -lastSunday d = case (d^.W.sundayWeek._swDay) of - 1 -> d - _ -> lastSunday $ pred d - --- | Get the beginning of a year -jan1 :: Day -> Day -jan1 d = let d' = d^.gregorian in - (YearMonthDay (d'^._ymdYear) 1 1)^.from gregorian - -addYears :: Int -> Day -> Day -addYears n d = let d' = d^.gregorian in - (YearMonthDay (d'^._ymdYear + n) (d'^._ymdMonth) (d'^._ymdDay))^.from gregorian - -addMonths :: Months -> Day -> Day -addMonths m d = let d' = d^.gregorian in - let (years,months) = (d'^._ymdMonth + m) `divMod` 12 in - (YearMonthDay (d'^._ymdYear + years) months (d'^._ymdDay))^.from gregorian - -firstOfMonth :: Day -> Day -firstOfMonth d = let d' = d^.gregorian in - (YearMonthDay (d'^._ymdYear) (d'^._ymdMonth) 1)^.from gregorian - -get1stOfMonth :: Int -> Day -> Day -get1stOfMonth i d = - let d' = d^.gregorian in - let y = abs $ (i - d'^._ymdMonth) `div` 12 in - (YearMonthDay (d'^._ymdYear + y) i 1)^.from gregorian - -getMonth :: Int -> Day -> Interval Day -getMonth i d = (d' ... addMonths 1 d') - where - d' = get1stOfMonth i d - -monthOfYear :: Int -> DatePattern -monthOfYear i = IntervalSequence $ \d -> Just (getMonth i d, monthOfYear i) +{-# LANGUAGE RecordWildCards #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Time.Patterns+-- Copyright : (C) 2013 Jann Mueller+-- License : BSD3 (see the file LICENSE)+-- Maintainer : j.mueller.11@ucl.ac.uk+-- Stability : experimental+-- Patterns for recurring events. Use the @DatePattern@ type to build up+-- a pattern, and the functions @elementOf@, @instancesFrom@ and+-- @intervalsFrom@ to evaluate it.+-- Simple example:+--+-- > import Control.Lens+-- > import Data.Thyme.Calendar+-- > import Data.Time.Patterns+-- > import qualified Prelude as P+-- > Module Main where+-- >+-- > main = do+-- > -- get the 6th of April for the next ten years+-- > let april6 = (take 1 $ skip 5 day) `inEach` april+-- > let today = (YearMonthDay 2013 12 01)^.from gregorian+-- > print $ P.take 10 $ instancesFrom today april6+--+-- @DatePattern@s can be combined using @union@, @intersect@ with their+-- obvious meanings and @inEach@ which repeats one pattern inside another one.+-- For example,+--+-- > ((take 1 day) `inEach` august) `intersect` sunday+--+-- will give the 1st of August in years when it falls on a Sunday.+----------------------------------------------------------------------------+module Data.Time.Patterns(+ -- * Date Patterns+ DatePattern,+ day,+ mondayWeek,+ sundayWeek,+ month,+ year,+ -- ** Months+ january,+ february,+ march,+ april,+ may,+ june,+ july,+ august,+ september,+ october,+ november,+ december,+ -- ** Days+ monday,+ tuesday,+ wednesday,+ thursday,+ friday,+ saturday,+ sunday,+ -- * Operations on date patterns+ never,+ every,+ shiftBy,+ inEach,+ take,+ skip,+ except,+ intersect,+ union,+ -- * Queries+ elementOf,+ instancesFrom,+ intervalsFrom+ ) where++import Control.Lens hiding (contains, elementOf,+ elements, (...))+import Data.Thyme.Calendar (Day, Days, Months,+ YearMonthDay (..), gregorian,+ modifiedJulianDay, _ymdDay,+ _ymdMonth, _ymdYear)+import Data.Thyme.Calendar.WeekDate (_mwDay, _swDay)+import qualified Data.Thyme.Calendar.WeekDate as W+import Data.Time.Patterns.Internal hiding (elementOf, every, except,+ intersect, never,+ occurrencesFrom, skip, take,+ union)+import qualified Data.Time.Patterns.Internal as I+import Numeric.Interval+import Prelude hiding (cycle, elem, filter, take)++-- | A DatePattern describes a sequence of intervals of type Data.Thyme.Day.+type DatePattern = IntervalSequence' Day++-- | An event that occurs every month.+month :: DatePattern+month = IntervalSequence $ \t ->+ let m = firstOfMonth t in+ let m' = addMonths 1 m in+ Just (m ... m', month) where++-- | Every January.+january :: DatePattern+january = monthOfYear 1++-- | Every February.+february :: DatePattern+february = monthOfYear 2++-- | Every March.+march :: DatePattern+march = monthOfYear 3++-- | Every April.+april :: DatePattern+april = monthOfYear 4++-- | Every May.+may :: DatePattern+may = monthOfYear 5++-- | Every June.+june :: DatePattern+june = monthOfYear 6++-- | Every July.+july :: DatePattern+july = monthOfYear 7++-- | Every August.+august :: DatePattern+august = monthOfYear 8++-- | Every September.+september :: DatePattern+september = monthOfYear 9++-- | Every October.+october :: DatePattern+october = monthOfYear 10++-- | Every November.+november :: DatePattern+november = monthOfYear 11++-- | Every December.+december :: DatePattern+december = monthOfYear 12++-- | An event that occurs every day.+day :: DatePattern+day = IntervalSequence{..} where+ nextInterval t = Just (t ... (succ t), day)++-- | Every Monday.+monday :: DatePattern+monday = filter (isDayOfWeek 1) day++-- | Every Tuesday.+tuesday :: DatePattern+tuesday = filter (isDayOfWeek 2) day++-- | Every Wednesday.+wednesday :: DatePattern+wednesday = filter (isDayOfWeek 3) day++-- | Every Thursday.+thursday :: DatePattern+thursday = filter (isDayOfWeek 4) day++-- | Every Friday.+friday :: DatePattern+friday = filter (isDayOfWeek 5) day++-- | Every Saturday.+saturday :: DatePattern+saturday = filter (isDayOfWeek 6) day++-- | Every Sunday.+sunday :: DatePattern+sunday = filter (isDayOfWeek 7) day++-- | Weeks, starting on Monday+mondayWeek :: DatePattern+mondayWeek = IntervalSequence $ \d -> let m = lastMonday d in+ Just (m ... addDays 7 m, mondayWeek)++-- | Weeks, starting on Sunday.+sundayWeek :: DatePattern+sundayWeek = IntervalSequence $ \d -> let m = lastSunday d in+ Just (m ... addDays 7 m, sundayWeek)++-- | Years, starting from Jan. 1+year :: DatePattern+year = IntervalSequence $ \d -> let m = jan1 d in+ Just (m ... addYears 1 m, year)++-- | The first pattern repeated for each interval of the+-- second pattern. E.g.:+--+-- > (take 3 $ every 4 monday) `inEach` year+--+-- will give the fourth, eighth and twelveth Monday in each year+inEach :: DatePattern -> DatePattern -> DatePattern+inEach i o = IntervalSequence (inEach' o i i)++-- | like inEach, except that the ``inner`` DatePattern is replaced by a sequence of DatePatterns+-- so that for every new outer interval, the next element from the sequence will be used.+inEach' :: DatePattern -> DatePattern -> DatePattern -> Day -> Maybe (Interval Day, DatePattern)+inEach' outer inner orig d = do+ (o1, outer') <- nextInterval outer d+ let inner' = stopAt' (sup o1) inner+ case (firstOccurrenceIn (max d $ inf o1) o1 inner') of+ Nothing -> inEach' outer' orig orig $ sup o1+ Just (i1,inner'') -> return (i1, IntervalSequence $ inEach' outer inner'' orig)++-- | Shift all the results by a number of day+shiftBy :: Days -> DatePattern -> DatePattern+shiftBy n = mapSequence (addDays n)++-- | Add a number of day to a day+addDays :: Days -> Day -> Day+addDays n d = (d^.modifiedJulianDay + n)^.from modifiedJulianDay++-- | Take every nth occurrence+every :: (Num i, Ord i) => i -> DatePattern -> DatePattern+every = I.every++-- | Stop after n occurrences+take :: (Num i, Ord i) => i -> DatePattern -> DatePattern+take = I.take++-- | Skip the first n occurrences+skip :: (Num i, Ord i) => i -> DatePattern -> DatePattern+skip = I.skip++-- | Skip over all occurrences of a day.+-- If the pattern describes a period longer+-- than a day, the entire period will be+-- skipped.+except :: Day -> DatePattern -> DatePattern+except = I.except++-- | Check if a date is covered by a DatePattern+elementOf :: Day -> DatePattern -> Bool+elementOf = I.elementOf++-- | Get occurrences of an event starting with a given day+instancesFrom :: Day -> DatePattern -> [Day]+instancesFrom = I.elementsFrom++-- | An event that never occurs+never :: DatePattern+never = I.never++-- | Return only occurrences that are present in both patterns+--+-- > let myBirthday = (take 1 day) `inEach` august+-- > let s = intersect myBirthday sunday+--+-- Will return August 1 in years when it falls on a Sunday+intersect :: DatePattern -> DatePattern -> DatePattern+intersect = I.intersect++-- | Occurrences of both patterns.+--+-- > union april june+--+-- Will return the months April and June in each year+--+-- > let fifteenth = (take 1 $ skip 14 day) `inEach` month+-- > let third = (take 1 $ skip 2 day) `inEach` month+-- > union fifteenth third+--+-- Will return the 3rd and the 15th of each month+union :: DatePattern -> DatePattern -> DatePattern+union = I.union++-- | Get the date intervals described by the pattern, starting+-- from the specified date.+--+-- The intervals range from the first+-- day included by the pattern to the first day after it, so+-- a single day @d@ would be described as @(d ... succ d)@ and+-- the interval for a month will go from the 1st of the month+-- to the 1st of the next month.+intervalsFrom :: Day -> DatePattern -> [Interval Day]+intervalsFrom = I.occurrencesFrom++-- | Check if a day interval covers exactly a given weekday+-- with Monday = 1, Tuesday = 2, etc.+isDayOfWeek :: Int -> Interval Day -> Bool+isDayOfWeek d i = case (elements i) of+ [dt] -> dt^. W.mondayWeek . _mwDay == d+ _ -> False++-- | Get the last Monday before or on the date+lastMonday :: Day -> Day+lastMonday d = case (d^.W.mondayWeek._mwDay) of+ 1 -> d+ _ -> lastMonday $ pred d+++-- | Get the last Monday before or on the date+lastSunday :: Day -> Day+lastSunday d = case (d^.W.sundayWeek._swDay) of+ 1 -> d+ _ -> lastSunday $ pred d++-- | Get the beginning of a year+jan1 :: Day -> Day+jan1 d = let d' = d^.gregorian in+ (YearMonthDay (d'^._ymdYear) 1 1)^.from gregorian++addYears :: Int -> Day -> Day+addYears n d = let d' = d^.gregorian in+ (YearMonthDay (d'^._ymdYear + n) (d'^._ymdMonth) (d'^._ymdDay))^.from gregorian++addMonths :: Months -> Day -> Day+addMonths m d = let d' = d^.gregorian in+ let (years,months) = (d'^._ymdMonth + m) `divMod` 12 in+ (YearMonthDay (d'^._ymdYear + years) months (d'^._ymdDay))^.from gregorian++firstOfMonth :: Day -> Day+firstOfMonth d = let d' = d^.gregorian in+ (YearMonthDay (d'^._ymdYear) (d'^._ymdMonth) 1)^.from gregorian++get1stOfMonth :: Int -> Day -> Day+get1stOfMonth i d =+ let d' = d^.gregorian in+ let y = abs $ (i - d'^._ymdMonth) `div` 12 in+ (YearMonthDay (d'^._ymdYear + y) i 1)^.from gregorian++getMonth :: Int -> Day -> Interval Day+getMonth i d = (d' ... addMonths 1 d')+ where+ d' = get1stOfMonth i d++monthOfYear :: Int -> DatePattern+monthOfYear i = IntervalSequence $ \d -> Just (getMonth i d, monthOfYear i)
src/Data/Time/Patterns/Internal.hs view
@@ -1,221 +1,221 @@-{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleInstances #-} ------------------------------------------------------------------------------ --- | --- Module : Data.Time.Patterns.Internal --- Copyright : (C) 2013 Jann Mueller --- License : BSD3 (see the file LICENSE) --- Maintainer : j.mueller.11@ucl.ac.uk --- Stability : experimental --- Internal stuff for time patterns ----------------------------------------------------------------------------- -module Data.Time.Patterns.Internal( - -- * Types - IntervalSequence(..), - IntervalSequence', - -- * General combinators - never, - union, - diag, - take, - cycle, - stopAt, - stopAt', - before, - andThen, - -- * Combinators for IntervalSequence' - every, - filter, - elementOf, - occurrencesFrom, - elementsFrom, - mapSequence, - skip, - skipUntil, - except, - except', - firstOccurrenceIn, - intersect, - -- * Other - elements - ) where - -import Numeric.Interval -import Numeric.Interval.Internal -import Data.Monoid (Monoid(..)) -import Prelude hiding (cycle, elem, filter, take) - --- | A sequence of intervals, starting from a point. --- If the argument to @nextInterval@ is part of an interval, then the result --- should be the interval containing it. -newtype IntervalSequence t s = IntervalSequence { nextInterval :: t -> Maybe (Interval s, IntervalSequence t s)} - --- | IntervalSequences that can be evaluated repeatedly. -type IntervalSequence' t = IntervalSequence t t - -instance (Ord s) => Monoid (IntervalSequence t s) where - mappend = union - mempty = never - - -mapSequence :: (a -> b) -> IntervalSequence t a -> IntervalSequence t b -mapSequence f s = - IntervalSequence (\t -> - nextInterval s t >>= \t' -> - return (mapInterval f (fst t'), - mapSequence f (snd t'))) - where mapInterval f' (I a b) = I (f' a) (f' b) - mapInterval _ Empty = Empty - --- | A sequence with no occurrences -never :: IntervalSequence t s -never = IntervalSequence $ const $ Nothing - --- | Occurrences from both intervals. --- The difference between @union@ and @diag@ is that @union@ preserves --- the order of the results -union :: Ord s => IntervalSequence t s -> IntervalSequence t s -> IntervalSequence t s -union a b = IntervalSequence $ \d -> - case (nextInterval a d, nextInterval b d) of - (Nothing, Nothing) -> Nothing - (Nothing, b') -> b' - (a', Nothing) -> a' - (Just (ia, sa), Just (ib, sb)) -> - case (sup ia <= sup ib) of - True -> return (ia, union sa (ib `andThen` sb)) - False -> return (ib, union (ia `andThen` sa) sb) - --- | Merge two sequences into one by switching between them -diag :: IntervalSequence t s -> IntervalSequence t s -> IntervalSequence t s -diag a b = IntervalSequence (nOcc' a b) where - nOcc' a' b' d = do - (na, sa) <- nextInterval a' d - return (na, diag b' sa) - --- | End a sequence after n occurrences -take :: (Num i, Ord i) => i -> IntervalSequence t s -> IntervalSequence t s -take n IntervalSequence{..} - | n < 1 = never - | otherwise = IntervalSequence $ \d -> - nextInterval d >>= \r -> Just (fst r, take (n - 1) $ snd r) - --- | Repeat a point infinitely -cycle :: Interval s -> IntervalSequence t s -cycle i = IntervalSequence $ const $ Just (i, cycle i) - --- | Take occurrences until an interval containing the argument is reached -stopAt :: Ord s => Interval s -> IntervalSequence t s -> IntervalSequence t s -stopAt p IntervalSequence{..} = IntervalSequence ni' where - ni' d = nextInterval d >>= \(p', q) -> case (p' `contains` p) of - True -> Nothing - False -> return (p', stopAt p q) - --- | Take occurrences until an interval whose supremum is greater than the --- argument is reached. -stopAt' :: Ord s => s -> IntervalSequence t s -> IntervalSequence t s -stopAt' p IntervalSequence{..} = IntervalSequence ni' where - ni' d = nextInterval d >>= \(p', q) -> case (sup p' >= p) of - True -> Nothing - False -> return (p', stopAt' p q) - --- | Stop as soon as a result greater than or equal to the parameter --- is produced -before :: Ord s => Interval s -> IntervalSequence t s -> IntervalSequence t s -before p IntervalSequence{..} = IntervalSequence ni' where - ni' d = nextInterval d >>= \(p', q) -> case (p >=! p') of - False -> Nothing - True -> return (p', stopAt p q) - --- | Prepend an interval to an interval sequence -andThen :: Interval s -> IntervalSequence t s -> IntervalSequence t s -andThen i sq = IntervalSequence $ \_ -> Just (i, sq) - --- | Take every nth occurrence -every :: (Num i, Ord i) => i -> IntervalSequence' t -> IntervalSequence' t -every n sq@IntervalSequence{..} - | n < 1 = never - | otherwise = IntervalSequence $ nextOcc 1 - where - nextOcc n' d - | n' == n = nextInterval d >>= \s -> return (fst s, every n sq) - | otherwise = nextInterval d >>= nextOcc (n' + 1) . sup . fst - --- | Accept results which satisfy a condition -filter :: (Interval t -> Bool) -> IntervalSequence' t -> IntervalSequence' t -filter f IntervalSequence{..} = IntervalSequence nOcc' where - nOcc' t = nextInterval t >>= checkCondition - checkCondition (p,q) = case (f p) of - True -> Just (p, filter f q) - False -> nOcc' $ sup p - --- | Check if a point is covered by an interval sequence -elementOf :: Ord t => t -> IntervalSequence' t -> Bool -elementOf t IntervalSequence{..} = maybe False (\(p,_) -> (elem t p) && (<) t (sup p)) (nextInterval t) - --- | The sequence of occurrences from an initial point. -occurrencesFrom :: t -> IntervalSequence' t -> [Interval t] -occurrencesFrom start IntervalSequence{..} = case (nextInterval start) of - Nothing -> [] - Just (res, sq') -> res : occurrencesFrom (sup res) sq' - --- | Elements covered by an interval sequence from an initial point. -elementsFrom :: Enum t => t -> IntervalSequence' t -> [t] -elementsFrom start sq = concat $ fmap elements $ occurrencesFrom start sq - --- | Skip the first n occurrences of a sequence -skip :: (Num i, Ord i) => i -> IntervalSequence' t -> IntervalSequence' t -skip n sq - | n < 0 = never - | otherwise = IntervalSequence $ nextOcc (nextInterval sq) n - where - nextOcc ni n' d - | n' < 1 = ni d - | otherwise = ni d >>= \(p, q) -> nextOcc (nextInterval q) (n' - 1) (sup p) - --- | Skip intervals until the infimum of the argument is reached. --- --- If the intervals in the sequence are not ordered, then this function might --- not terminate. -skipUntil :: Ord t => Interval t -> IntervalSequence' t -> IntervalSequence' t -skipUntil = stopAt' . inf - --- | Skip over a point in the sequence. All occurrences of this --- datum are removed. -except :: (Enum t, Ord t) => t -> IntervalSequence' t -> IntervalSequence' t -except p = except' (p ... succ p) - --- | Skip over all intervals which contain the parameter -except' :: Ord t => Interval t -> IntervalSequence' t -> IntervalSequence' t -except' p IntervalSequence{..} = IntervalSequence ni' where - ni' d = nextInterval d >>= \(p', q) -> case (p' `contains` p) of - False -> return (p', except' p q) - True -> ni' $ sup p - --- | Search for the first result within the specified interval, starting from --- a point. --- --- If the intervals in the sequence are not ordered, then this function might --- not terminate. -firstOccurrenceIn :: (Enum t, Ord t) => t -> Interval t -> IntervalSequence' t -> Maybe (Interval t, IntervalSequence' t) -firstOccurrenceIn s i IntervalSequence{..} = firstOcc s where - firstOcc start = do - (p, q) <- nextInterval start - case (i `contains` p) of - True -> return (p, q) - False -> case (sup p < sup i) of - True -> firstOcc $ sup p - False -> Nothing - --- | Return intervals that are exactly the same -intersect :: (Ord t, Enum t) => IntervalSequence' t -> IntervalSequence' t -> IntervalSequence' t -intersect a b = IntervalSequence (nOcc' a b) where - nOcc' a' b' d = do - (ia, sa) <- nextInterval a' d - (ib, sb) <- nextInterval b' $ inf ia - case ((sup ia == sup ib) && (inf ia == inf ib)) of - True -> return (ib, intersect sa sb) - False -> nOcc' b' sa $ sup ia -- mix up a' and b' to search in both directions evenly - -elements :: Enum a => Interval a -> [a] -elements i = enumFromTo (inf i) (pred $ sup i) +{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Time.Patterns.Internal+-- Copyright : (C) 2013 Jann Mueller+-- License : BSD3 (see the file LICENSE)+-- Maintainer : j.mueller.11@ucl.ac.uk+-- Stability : experimental+-- Internal stuff for time patterns+----------------------------------------------------------------------------+module Data.Time.Patterns.Internal(+ -- * Types+ IntervalSequence(..),+ IntervalSequence',+ -- * General combinators+ never,+ union,+ diag,+ take,+ cycle,+ stopAt,+ stopAt',+ before,+ andThen,+ -- * Combinators for IntervalSequence'+ every,+ filter,+ elementOf,+ occurrencesFrom,+ elementsFrom,+ mapSequence,+ skip,+ skipUntil,+ except,+ except',+ firstOccurrenceIn,+ intersect,+ -- * Other+ elements+ ) where++import Data.Monoid (Monoid (..))+import Numeric.Interval+import Numeric.Interval.Internal+import Prelude hiding (cycle, elem, filter, take)++-- | A sequence of intervals, starting from a point.+-- If the argument to @nextInterval@ is part of an interval, then the result+-- should be the interval containing it.+newtype IntervalSequence t s = IntervalSequence { nextInterval :: t -> Maybe (Interval s, IntervalSequence t s)}++-- | IntervalSequences that can be evaluated repeatedly.+type IntervalSequence' t = IntervalSequence t t++instance (Ord s) => Monoid (IntervalSequence t s) where+ mappend = union+ mempty = never+++mapSequence :: (a -> b) -> IntervalSequence t a -> IntervalSequence t b+mapSequence f s =+ IntervalSequence (\t ->+ nextInterval s t >>= \t' ->+ return (mapInterval f (fst t'),+ mapSequence f (snd t')))+ where mapInterval f' (I a b) = I (f' a) (f' b)+ mapInterval _ Empty = Empty++-- | A sequence with no occurrences+never :: IntervalSequence t s+never = IntervalSequence $ const $ Nothing++-- | Occurrences from both intervals.+-- The difference between @union@ and @diag@ is that @union@ preserves+-- the order of the results+union :: Ord s => IntervalSequence t s -> IntervalSequence t s -> IntervalSequence t s+union a b = IntervalSequence $ \d ->+ case (nextInterval a d, nextInterval b d) of+ (Nothing, Nothing) -> Nothing+ (Nothing, b') -> b'+ (a', Nothing) -> a'+ (Just (ia, sa), Just (ib, sb)) ->+ case (sup ia <= sup ib) of+ True -> return (ia, union sa (ib `andThen` sb))+ False -> return (ib, union (ia `andThen` sa) sb)++-- | Merge two sequences into one by switching between them+diag :: IntervalSequence t s -> IntervalSequence t s -> IntervalSequence t s+diag a b = IntervalSequence (nOcc' a b) where+ nOcc' a' b' d = do+ (na, sa) <- nextInterval a' d+ return (na, diag b' sa)++-- | End a sequence after n occurrences+take :: (Num i, Ord i) => i -> IntervalSequence t s -> IntervalSequence t s+take n IntervalSequence{..}+ | n < 1 = never+ | otherwise = IntervalSequence $ \d ->+ nextInterval d >>= \r -> Just (fst r, take (n - 1) $ snd r)++-- | Repeat a point infinitely+cycle :: Interval s -> IntervalSequence t s+cycle i = IntervalSequence $ const $ Just (i, cycle i)++-- | Take occurrences until an interval containing the argument is reached+stopAt :: Ord s => Interval s -> IntervalSequence t s -> IntervalSequence t s+stopAt p IntervalSequence{..} = IntervalSequence ni' where+ ni' d = nextInterval d >>= \(p', q) -> case (p' `contains` p) of+ True -> Nothing+ False -> return (p', stopAt p q)++-- | Take occurrences until an interval whose supremum is greater than the+-- argument is reached.+stopAt' :: Ord s => s -> IntervalSequence t s -> IntervalSequence t s+stopAt' p IntervalSequence{..} = IntervalSequence ni' where+ ni' d = nextInterval d >>= \(p', q) -> case (sup p' >= p) of+ True -> Nothing+ False -> return (p', stopAt' p q)++-- | Stop as soon as a result greater than or equal to the parameter+-- is produced+before :: Ord s => Interval s -> IntervalSequence t s -> IntervalSequence t s+before p IntervalSequence{..} = IntervalSequence ni' where+ ni' d = nextInterval d >>= \(p', q) -> case (p >=! p') of+ False -> Nothing+ True -> return (p', stopAt p q)++-- | Prepend an interval to an interval sequence+andThen :: Interval s -> IntervalSequence t s -> IntervalSequence t s+andThen i sq = IntervalSequence $ \_ -> Just (i, sq)++-- | Take every nth occurrence+every :: (Num i, Ord i) => i -> IntervalSequence' t -> IntervalSequence' t+every n sq@IntervalSequence{..}+ | n < 1 = never+ | otherwise = IntervalSequence $ nextOcc 1+ where+ nextOcc n' d+ | n' == n = nextInterval d >>= \s -> return (fst s, every n sq)+ | otherwise = nextInterval d >>= nextOcc (n' + 1) . sup . fst++-- | Accept results which satisfy a condition+filter :: (Interval t -> Bool) -> IntervalSequence' t -> IntervalSequence' t+filter f IntervalSequence{..} = IntervalSequence nOcc' where+ nOcc' t = nextInterval t >>= checkCondition+ checkCondition (p,q) = case (f p) of+ True -> Just (p, filter f q)+ False -> nOcc' $ sup p++-- | Check if a point is covered by an interval sequence+elementOf :: Ord t => t -> IntervalSequence' t -> Bool+elementOf t IntervalSequence{..} = maybe False (\(p,_) -> (elem t p) && (<) t (sup p)) (nextInterval t)++-- | The sequence of occurrences from an initial point.+occurrencesFrom :: t -> IntervalSequence' t -> [Interval t]+occurrencesFrom start IntervalSequence{..} = case (nextInterval start) of+ Nothing -> []+ Just (res, sq') -> res : occurrencesFrom (sup res) sq'++-- | Elements covered by an interval sequence from an initial point.+elementsFrom :: Enum t => t -> IntervalSequence' t -> [t]+elementsFrom start sq = concat $ fmap elements $ occurrencesFrom start sq++-- | Skip the first n occurrences of a sequence+skip :: (Num i, Ord i) => i -> IntervalSequence' t -> IntervalSequence' t+skip n sq+ | n < 0 = never+ | otherwise = IntervalSequence $ nextOcc (nextInterval sq) n+ where+ nextOcc ni n' d+ | n' < 1 = ni d+ | otherwise = ni d >>= \(p, q) -> nextOcc (nextInterval q) (n' - 1) (sup p)++-- | Skip intervals until the infimum of the argument is reached.+--+-- If the intervals in the sequence are not ordered, then this function might+-- not terminate.+skipUntil :: Ord t => Interval t -> IntervalSequence' t -> IntervalSequence' t+skipUntil = stopAt' . inf++-- | Skip over a point in the sequence. All occurrences of this+-- datum are removed.+except :: (Enum t, Ord t) => t -> IntervalSequence' t -> IntervalSequence' t+except p = except' (p ... succ p)++-- | Skip over all intervals which contain the parameter+except' :: Ord t => Interval t -> IntervalSequence' t -> IntervalSequence' t+except' p IntervalSequence{..} = IntervalSequence ni' where+ ni' d = nextInterval d >>= \(p', q) -> case (p' `contains` p) of+ False -> return (p', except' p q)+ True -> ni' $ sup p++-- | Search for the first result within the specified interval, starting from+-- a point.+--+-- If the intervals in the sequence are not ordered, then this function might+-- not terminate.+firstOccurrenceIn :: (Enum t, Ord t) => t -> Interval t -> IntervalSequence' t -> Maybe (Interval t, IntervalSequence' t)+firstOccurrenceIn s i IntervalSequence{..} = firstOcc s where+ firstOcc start = do+ (p, q) <- nextInterval start+ case (i `contains` p) of+ True -> return (p, q)+ False -> case (sup p < sup i) of+ True -> firstOcc $ sup p+ False -> Nothing++-- | Return intervals that are exactly the same+intersect :: (Ord t, Enum t) => IntervalSequence' t -> IntervalSequence' t -> IntervalSequence' t+intersect a b = IntervalSequence (nOcc' a b) where+ nOcc' a' b' d = do+ (ia, sa) <- nextInterval a' d+ (ib, sb) <- nextInterval b' $ inf ia+ case ((sup ia == sup ib) && (inf ia == inf ib)) of+ True -> return (ib, intersect sa sb)+ False -> nOcc' b' sa $ sup ia -- mix up a' and b' to search in both directions evenly++elements :: Enum a => Interval a -> [a]+elements i = enumFromTo (inf i) (pred $ sup i)
time-patterns.cabal view
@@ -1,41 +1,41 @@--- Initial time-patterns.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ - -name: time-patterns -version: 0.1.3.1 -synopsis: Patterns for recurring events -license: BSD3 -license-file: LICENSE -author: Jann Müller, Moritz Kiefer -maintainer: j.mueller.11@ucl.ac.uk -copyright: Copyright (C) 2013-2015 Jann Müller, (C) 2015 Moritz Kiefer -category: Data, Time -build-type: Simple -cabal-version: >= 1.10 -homepage: https://bitbucket.org/jfmueller/time-patterns -bug-reports: https://bitbucket.org/jfmueller/time-patterns/issues -synopsis: Patterns for recurring events. -description: - This package contains a set of primitives and combinators for event patterns. Example: - . - > >> import qualified Prelude as P - > >> let sundays = every 2 sunday - > >> let today = (YearMonthDay 2013 12 01)^.from gregorian - > >> P.take 2 $ instancesFrom today sundays - > [2013-12-08, 2013-12-22] - . - See @Data.Time.Patterns@ for more examples. -source-repository head - type: git - location: git@bitbucket.org:jfmueller/time-patterns.git - -library - exposed-modules: Data.Time.Patterns, - Data.Time.Patterns.Internal - build-depends: base >=4.6 && <4.8, - intervals >= 0.7 && <0.8, - lens >= 3.9 && <4.8, - thyme >= 0.3 && <0.4, - vector-space >= 0.9 && <1.0 - hs-source-dirs: src - default-language: Haskell2010 +-- Initial time-patterns.cabal generated by cabal init. For further+-- documentation, see http://haskell.org/cabal/users-guide/++name: time-patterns+version: 0.1.3.2+synopsis: Patterns for recurring events+license: BSD3+license-file: LICENSE+author: Jann Müller, Moritz Kiefer+maintainer: j.mueller.11@ucl.ac.uk+copyright: Copyright (C) 2013-2016 Jann Müller, (C) 2015 Moritz Kiefer+category: Data, Time+build-type: Simple+cabal-version: >= 1.10+homepage: https://bitbucket.org/jfmueller/time-patterns+bug-reports: https://bitbucket.org/jfmueller/time-patterns/issues+synopsis: Patterns for recurring events.+description:+ This package contains a set of primitives and combinators for event patterns. Example:+ .+ > >> import qualified Prelude as P+ > >> let sundays = every 2 sunday+ > >> let today = (YearMonthDay 2013 12 01)^.from gregorian+ > >> P.take 2 $ instancesFrom today sundays+ > [2013-12-08, 2013-12-22]+ .+ See @Data.Time.Patterns@ for more examples.+source-repository head+ type: git+ location: git@github.com:j-mueller/time-patterns.git++library+ exposed-modules: Data.Time.Patterns,+ Data.Time.Patterns.Internal+ build-depends: base >=4.6 && <5,+ intervals >= 0.7 && <0.8,+ lens >= 4 && <5,+ thyme >= 0.3 && <0.4,+ vector-space >= 0.9 && <1.0+ hs-source-dirs: src+ default-language: Haskell2010