time-patterns (empty) → 0.1.0.2

raw patch · 5 files changed

+572/−0 lines, 5 filesdep +basedep +intervalsdep +lenssetup-changed

Dependencies added: base, intervals, lens, thyme, vector-space

Files

LICENSE +30/−0
Setup.hs +2/−0
src/Data/Time/Patterns.hs +326/−0
src/Data/Time/Patterns/Internal.hs +174/−0
time-patterns.cabal +40/−0

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2013, Jann Mueller
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Jann Mueller nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple
+main = defaultMain

+ src/Data/Time/Patterns.hs view

@@ -0,0 +1,326 @@+{-# 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 re-occurring 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+-- >+----------------------------------------------------------------------------+module Data.Time.Patterns(+    -- * Date Patterns+    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)+import qualified Prelude as P++-- | An event that occurs every month.+month :: DatePattern+month = IntervalSequence $ \t -> +        let m = firstOfMonth t in+        let m' = addMonths 1 m in+        Just (I 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 (I 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 (I m $ addDays 7 m, mondayWeek)++-- | Weeks, starting on Sunday.+sundayWeek :: DatePattern+sundayWeek = IntervalSequence $ \d -> let m = lastSunday d in +    Just (I m $ addDays 7 m, sundayWeek)++-- | Years, starting from Jan. 1+year :: DatePattern+year = IntervalSequence $ \d -> let m = jan1 d in+    Just (I 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 sq = mapS (addDays n) sq++-- | 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 :: Int -> DatePattern -> DatePattern+every = I.every++-- | Stop after n occurrences+take :: Int -> DatePattern -> DatePattern+take = I.take++-- | Skip the first n occurrences+skip :: Int -> 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

@@ -0,0 +1,174 @@+{-# 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 where++import Numeric.Interval+import Data.Thyme.Calendar (Day)+import Data.Thyme.Clock (UTCTime)+import Prelude hiding (cycle, elem, filter, take)++-- | If the argument to nextOccurrence is part of an interval, then the result should be the interval containing it.+-- The interval should be closed at the first parameter and open at the second, so that repeated calls of+-- nextOccurrence yield a sequence of occurrences.+newtype IntervalSequence t = IntervalSequence { nextInterval :: t -> Maybe (Interval t, IntervalSequence t)}++type DatePattern = IntervalSequence Day+type TimePattern = IntervalSequence UTCTime -- TimePattern should cycle throu+++-- | A sequence with no occurrences+never :: IntervalSequence t+never = IntervalSequence $ const $ Nothing++-- | Take every nth occurrence+every :: Int -> 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+++-- | Repeat a point infinitely+cycle :: Interval t -> IntervalSequence t+cycle i = IntervalSequence $ const $ Just (i, cycle i)++-- | 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++elements :: Enum a => Interval a -> [a]+elements i = enumFromTo (inf i) (pred $ sup i)++-- | End a sequence after n occurrences+take :: Int -> IntervalSequence t -> IntervalSequence t+take n IntervalSequence{..} +    | n < 1     = never+    | otherwise = IntervalSequence $ \d -> +        nextInterval d >>= \r -> Just (fst r, take (pred n) $ snd r)++-- | Skip the first n occurrences of a sequence+skip :: Int -> 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)++-- | Take occurrences until an interval is reached+stopAt :: Ord t => Interval t -> IntervalSequence t -> IntervalSequence t+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)++stopAt' :: Ord t => t -> IntervalSequence t -> IntervalSequence t+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 t => Interval t -> IntervalSequence t -> IntervalSequence t+before p IntervalSequence{..} = IntervalSequence ni' where+    ni' d = nextInterval d >>= \(p', q) -> case (p >=! p') of+        False -> Nothing+        True  -> return (p', stopAt p q)++skipUntil :: Ord t => Interval t -> IntervalSequence t -> IntervalSequence t+skipUntil fr sq = IntervalSequence $ nextOcc $ nextInterval sq where+    nextOcc ni d = ni d >>= \(p', q) -> case (fr <=! p') of+        False -> nextOcc (nextInterval q) (sup p')+        True  -> return (p', q)++-- | 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++-- | Apply a function to the results of an interval sequence+mapS :: (t -> t) -> IntervalSequence t -> IntervalSequence t+mapS f IntervalSequence{..} = IntervalSequence nOcc' where+    nOcc' d = nextInterval d >>= \r -> return (fmap f $ fst r, snd r)++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++-- | Merge two sequences into one by switching between them+diag :: IntervalSequence t -> IntervalSequence t -> IntervalSequence t+diag a b = IntervalSequence (nOcc' a b) where+    nOcc' a' b' d = do+        (na, sa) <- nextInterval a' d+        return (na, diag b' sa)++-- | Occurrences from both intervals.+union :: Ord t => IntervalSequence t -> IntervalSequence t -> IntervalSequence t+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)++-- | Prepend an interval to an interval sequence+andThen :: Interval t -> IntervalSequence t -> IntervalSequence t+andThen i sq = IntervalSequence $ \_ -> Just (i, sq)+

+ time-patterns.cabal view

@@ -0,0 +1,40 @@+-- Initial time-patterns.cabal generated by cabal init.  For further +-- documentation, see http://haskell.org/cabal/users-guide/++name:                time-patterns+version:             0.1.0.2+synopsis:            Patterns of re-occurring events    +license:             BSD3+license-file:        LICENSE+author:              Jann Müller+maintainer:          j.mueller.11@ucl.ac.uk+copyright:           Copyright (C) 2013 Jann Müller+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 re-occurring 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]++source-repository head+  type: git+  location: git@bitbucket.org:jfmueller/time-patterns.git++library+  exposed-modules:     Data.Time.Patterns+  other-modules:       Data.Time.Patterns.Internal+  build-depends:       base >=4.6 && <4.7,+                       intervals == 0.4,+                       lens >= 3.9,+                       thyme == 0.3.*,+                       vector-space == 0.8.6+  hs-source-dirs:      src+  default-language:    Haskell2010