├── Setup.hs ├── .travis.yml ├── src └── Data │ └── Time │ ├── CalendarTime.hs │ ├── Moment │ ├── Interval.hs │ ├── StartOfWeek.hs │ ├── Private.hs │ ├── UTC.hs │ ├── Moment.hs │ └── FutureMoments.hs │ ├── Recurrence │ ├── AndThen.hs │ ├── Schedule.hs │ └── ScheduleDetails.hs │ ├── Moment.hs │ ├── Calendar │ ├── WeekDay.hs │ └── Month.hs │ ├── Recurrence.hs │ └── CalendarTime │ └── CalendarTime.hs ├── AUTHORS ├── .gitignore ├── stack.yaml ├── time-recurrence.cabal ├── tests └── Tests.lhs ├── LICENSE └── README /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: haskell 2 | ghc: 3 | - 7.10.2 4 | - 7.8 5 | - 7.6 6 | sudo: false 7 | -------------------------------------------------------------------------------- /src/Data/Time/CalendarTime.hs: -------------------------------------------------------------------------------- 1 | module Data.Time.CalendarTime 2 | ( 3 | module Data.Time.CalendarTime.CalendarTime 4 | ) 5 | where 6 | 7 | import Data.Time.CalendarTime.CalendarTime 8 | -------------------------------------------------------------------------------- /AUTHORS: -------------------------------------------------------------------------------- 1 | Initial hacking done by Chris Heller . 2 | 3 | Additional contributions by: 4 | 5 | Conrad Parker 6 | Philip Cunningham 7 | Stephen Diehl 8 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | TAGS -------------------------------------------------------------------------------- /src/Data/Time/Moment/Interval.hs: -------------------------------------------------------------------------------- 1 | module Data.Time.Moment.Interval 2 | ( 3 | -- * Interval 4 | Interval (fromInterval) 5 | , toInterval 6 | ) 7 | where 8 | 9 | import Data.Time.Moment.Private 10 | 11 | toInterval :: Integer -> Interval 12 | toInterval = Interval 13 | -------------------------------------------------------------------------------- /src/Data/Time/Recurrence/AndThen.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FunctionalDependencies, MultiParamTypeClasses #-} 2 | module Data.Time.Recurrence.AndThen 3 | ( 4 | AndThen (..) 5 | ) 6 | where 7 | 8 | infixr 0 >==> 9 | 10 | class AndThen a b c | a b -> c where 11 | (>==>) :: a -> b -> c 12 | -------------------------------------------------------------------------------- /src/Data/Time/Moment.hs: -------------------------------------------------------------------------------- 1 | module Data.Time.Moment 2 | ( 3 | module ReExport 4 | ) 5 | where 6 | 7 | import Data.Time.Moment.FutureMoments as ReExport 8 | import Data.Time.Moment.Interval as ReExport 9 | import Data.Time.Moment.Moment as ReExport 10 | import Data.Time.Moment.StartOfWeek as ReExport 11 | -------------------------------------------------------------------------------- /src/Data/Time/Calendar/WeekDay.hs: -------------------------------------------------------------------------------- 1 | module Data.Time.Calendar.WeekDay 2 | ( 3 | -- * WeekDay 4 | WeekDay(..) 5 | ) 6 | where 7 | 8 | data WeekDay 9 | = Monday 10 | | Tuesday 11 | | Wednesday 12 | | Thursday 13 | | Friday 14 | | Saturday 15 | | Sunday 16 | deriving (Read, Show, Eq, Ord, Enum, Bounded) 17 | -------------------------------------------------------------------------------- /src/Data/Time/Moment/StartOfWeek.hs: -------------------------------------------------------------------------------- 1 | module Data.Time.Moment.StartOfWeek 2 | ( 3 | -- * StartOfWeek 4 | StartOfWeek (fromStartOfWeek) 5 | , toStartOfWeek 6 | ) 7 | where 8 | 9 | import Data.Time.Calendar.WeekDay 10 | import Data.Time.Moment.Private 11 | 12 | toStartOfWeek :: WeekDay -> StartOfWeek 13 | toStartOfWeek = StartOfWeek 14 | -------------------------------------------------------------------------------- /src/Data/Time/Moment/Private.hs: -------------------------------------------------------------------------------- 1 | module Data.Time.Moment.Private 2 | ( 3 | -- * Interval 4 | Interval (..) 5 | 6 | -- * StartOfWeek 7 | , StartOfWeek (..) 8 | ) 9 | where 10 | 11 | import Data.Time.Calendar.WeekDay 12 | 13 | newtype Interval = Interval { fromInterval :: Integer } deriving (Show) 14 | newtype StartOfWeek = StartOfWeek { fromStartOfWeek :: WeekDay } deriving (Show) 15 | -------------------------------------------------------------------------------- /src/Data/Time/Moment/UTC.hs: -------------------------------------------------------------------------------- 1 | module Data.Time.Moment.UTC 2 | ( 3 | ) 4 | where 5 | 6 | import Data.Time 7 | import Data.Time.Moment.Moment 8 | 9 | instance Moment UTCTime where 10 | epoch = UTCTime (toEnum 0) 0 11 | addSeconds utc i = addUTCTime (fromIntegral i) utc 12 | addMonths (UTCTime d t) i = UTCTime (addGregorianMonthsRollOver i d) t 13 | addYears (UTCTime d t) i = UTCTime (addGregorianYearsRollOver i d) t 14 | -------------------------------------------------------------------------------- /src/Data/Time/Recurrence.hs: -------------------------------------------------------------------------------- 1 | module Data.Time.Recurrence 2 | ( 3 | CalendarTime (..) 4 | , M.Moment 5 | , module ReExport 6 | ) 7 | where 8 | 9 | import Data.Time.CalendarTime 10 | import Data.Time.Calendar.Month as ReExport 11 | import Data.Time.Calendar.WeekDay as ReExport 12 | import qualified Data.Time.Moment as M 13 | import Data.Time.Moment.UTC () 14 | import Data.Time.Recurrence.AndThen as ReExport 15 | import Data.Time.Recurrence.Schedule as ReExport 16 | import Data.Time.Recurrence.ScheduleDetails as ReExport hiding (eval) 17 | -------------------------------------------------------------------------------- /src/Data/Time/Calendar/Month.hs: -------------------------------------------------------------------------------- 1 | module Data.Time.Calendar.Month 2 | ( 3 | -- * Month 4 | Month (..) 5 | ) 6 | where 7 | 8 | data Month 9 | = January 10 | | February 11 | | March 12 | | April 13 | | May 14 | | June 15 | | July 16 | | August 17 | | September 18 | | October 19 | | November 20 | | December 21 | deriving (Read, Show, Eq, Ord, Bounded) 22 | 23 | instance Enum Month where 24 | fromEnum January = 1 25 | fromEnum February = 2 26 | fromEnum March = 3 27 | fromEnum April = 4 28 | fromEnum May = 5 29 | fromEnum June = 6 30 | fromEnum July = 7 31 | fromEnum August = 8 32 | fromEnum September = 9 33 | fromEnum October = 10 34 | fromEnum November = 11 35 | fromEnum December = 12 36 | 37 | toEnum 1 = January 38 | toEnum 2 = February 39 | toEnum 3 = March 40 | toEnum 4 = April 41 | toEnum 5 = May 42 | toEnum 6 = June 43 | toEnum 7 = July 44 | toEnum 8 = August 45 | toEnum 9 = September 46 | toEnum 10 = October 47 | toEnum 11 = November 48 | toEnum 12 = December 49 | 50 | toEnum unmatched = error ("Month.toEnum: Cannot match " ++ show unmatched) 51 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # http://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-5.13 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - '.' 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | flags: {} 46 | 47 | # Extra package databases containing global packages 48 | extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.0" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /time-recurrence.cabal: -------------------------------------------------------------------------------- 1 | -- time-recurrence.cabal auto-generated by cabal init. For additional 2 | -- options, see 3 | -- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr. 4 | -- The name of the package. 5 | Name: time-recurrence 6 | 7 | -- The package version. See the Haskell package versioning policy 8 | -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for 9 | -- standards guiding when and how versions should be incremented. 10 | Version: 0.9.3 11 | 12 | -- A short (one-line) description of the package. 13 | Synopsis: Generate recurring dates. 14 | 15 | -- A longer description of the package. 16 | Description: time-recurrence is a library for generating 17 | recurring dates. 18 | 19 | It is based on the iCalendar spec (RFC 5545). 20 | However it makes no attempt to strictly follow 21 | the spec. 22 | 23 | -- URL for the project homepage or repository. 24 | Homepage: http://github.com/hellertime/time-recurrence 25 | 26 | -- The license under which the package is released. 27 | License: LGPL-3 28 | 29 | -- The file containing the license text. 30 | License-file: LICENSE 31 | 32 | -- The package author(s). 33 | Author: Chris Heller 34 | 35 | -- An email address to which users can send suggestions, bug reports, 36 | -- and patches. 37 | Maintainer: hellertime@gmail.com 38 | 39 | -- A copyright notice. 40 | -- Copyright: 41 | 42 | Category: System 43 | 44 | Build-type: Simple 45 | 46 | -- Constraint on the version of Cabal needed to build this package. 47 | Cabal-version: >=1.10 48 | 49 | -- Extra files to be distributed with the package, such as examples or 50 | -- a README. 51 | Extra-source-files: 52 | README, AUTHORS, tests/Tests.lhs 53 | 54 | source-repository head 55 | type: git 56 | location: http://github.com/hellertime/time-recurrence 57 | 58 | flag test-suite 59 | description: Build the test suite 60 | default: False 61 | 62 | Library 63 | hs-source-dirs: src 64 | ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-orphans 65 | 66 | -- Modules exported by the library. 67 | Exposed-modules: 68 | Data.Time.Calendar.Month, 69 | Data.Time.Calendar.WeekDay, 70 | Data.Time.CalendarTime, 71 | Data.Time.Moment, 72 | Data.Time.Recurrence, 73 | Data.Time.Recurrence.AndThen 74 | Data.Time.Recurrence.Schedule 75 | Data.Time.Recurrence.ScheduleDetails 76 | Other-modules: 77 | Data.Time.CalendarTime.CalendarTime, 78 | Data.Time.Moment.Moment, 79 | Data.Time.Moment.FutureMoments 80 | Data.Time.Moment.Interval, 81 | Data.Time.Moment.StartOfWeek, 82 | Data.Time.Moment.Private, 83 | Data.Time.Moment.UTC 84 | 85 | -- Packages needed in order to build this package. 86 | Build-depends: base >= 4 && < 5, 87 | time >= 1.4 && < 1.6, 88 | data-ordlist >= 0.4.5, 89 | mtl >= 2.0 && < 2.3 90 | 91 | Default-Language: Haskell98 92 | -- Modules not exported by this package. 93 | -- Other-modules: 94 | 95 | -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. 96 | -- Build-tools: 97 | 98 | Test-Suite test-time-recurrence 99 | type: exitcode-stdio-1.0 100 | hs-source-dirs: src, tests 101 | main-is: Tests.lhs 102 | ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-orphans 103 | build-depends: base >= 4 && < 5, 104 | time >= 1.4 && < 1.6, 105 | data-ordlist >= 0.4.5, 106 | mtl >= 2.0 && < 2.3, 107 | test-framework >= 0.8, 108 | test-framework-hunit >= 0.3.0, 109 | HUnit >= 1.2 && < 1.4, 110 | old-locale >= 1.0 && < 1.1 111 | other-modules: 112 | Data.Time.Recurrence 113 | default-language: Haskell98 114 | -------------------------------------------------------------------------------- /src/Data/Time/CalendarTime/CalendarTime.hs: -------------------------------------------------------------------------------- 1 | module Data.Time.CalendarTime.CalendarTime 2 | ( 3 | -- * Calendar Time 4 | CalendarTime (..) 5 | , toDay 6 | , withDay 7 | , toTimeOfDay 8 | , daysInYear 9 | , lastDayOfMonth 10 | , weekNumber 11 | 12 | -- * Calendar Time Convertible 13 | , CalendarTimeConvertible (..) 14 | ) 15 | where 16 | 17 | import Data.Time 18 | import Data.Time.Calendar.OrdinalDate 19 | import Data.Time.Calendar.Month 20 | import Data.Time.Calendar.WeekDay 21 | import Data.Time.Moment.StartOfWeek 22 | 23 | -- | A representation of calendar time separated into year, month, day, and so on. 24 | data CalendarTime = CalendarTime 25 | { 26 | calendarSecond :: Int -- 0 .. 61 27 | , calendarMinute :: Int -- 0 .. 59 28 | , calendarHour :: Int -- 0 .. 23 29 | , calendarDay :: Int -- 1 .. 31 30 | , calendarMonth :: Month -- January .. December 31 | , calendarYear :: Integer -- 0 .. 32 | , calendarWeekDay :: WeekDay -- Sunday .. Saturday 33 | , calendarYearDay :: Int -- 1 .. 366 34 | , calendarTimeZone :: TimeZone 35 | } deriving (Eq,Ord,Show) 36 | 37 | -- | The class of types which can be converted to a 'CalendarTime' 38 | class CalendarTimeConvertible t where 39 | -- | Convert to a 'CalendarTime' 40 | toCalendarTime :: t -> CalendarTime 41 | -- | Convert from a 'CalendarTime' 42 | fromCalendarTime :: CalendarTime -> Maybe t 43 | 44 | instance CalendarTimeConvertible CalendarTime where 45 | toCalendarTime = id 46 | fromCalendarTime = Just . id 47 | 48 | -- | Convert to a 'Day' 49 | toDay :: CalendarTime -> Maybe Day 50 | toDay t = fromGregorianValid (calendarYear t) (fromEnum $ calendarMonth t) (calendarDay t) 51 | 52 | -- | Convert to a 'TimeOfDay' 53 | toTimeOfDay :: CalendarTime -> Maybe TimeOfDay 54 | toTimeOfDay t = makeTimeOfDayValid (calendarHour t) (calendarMinute t) (toEnum $ calendarSecond t) 55 | 56 | -- | Change y-m-d in 'CalendarTime' 57 | withDay :: CalendarTime -> Day -> CalendarTime 58 | withDay ct day = ct 59 | { calendarYear = y 60 | , calendarMonth = toEnum m 61 | , calendarDay = d} 62 | where 63 | (y, m, d) = toGregorian day 64 | 65 | dayInfo :: 66 | Day 67 | -> ( Integer -- Year 68 | , Int -- Month 69 | , Int -- Day 70 | , WeekDay -- Week Day 71 | , Int -- Year Day 72 | ) 73 | dayInfo day = let 74 | (y, m, d) = toGregorian day 75 | weekDay = toEnum $ snd (mondayStartWeek day) - 1 76 | yearDay = snd $ toOrdinalDate day 77 | in (y, m, d, weekDay, yearDay) 78 | 79 | 80 | instance CalendarTimeConvertible UTCTime where 81 | toCalendarTime (UTCTime utcDay utcTime) = CalendarTime (truncate ss) mm hh d (toEnum m) y weekDay yearDay utc 82 | where 83 | (TimeOfDay hh mm ss) = timeToTimeOfDay utcTime 84 | (y, m, d, weekDay, yearDay) = dayInfo utcDay 85 | 86 | fromCalendarTime t = do 87 | day <- toDay t 88 | time <- toTimeOfDay t 89 | return $ UTCTime day (timeOfDayToTime time) 90 | 91 | instance CalendarTimeConvertible ZonedTime where 92 | toCalendarTime (ZonedTime (LocalTime day t) tz) = CalendarTime (fromEnum $ todSec t) (todMin t) (todHour t) d (toEnum m) y weekDay yearDay tz 93 | where 94 | (y, m, d, weekDay, yearDay) = dayInfo day 95 | 96 | fromCalendarTime t = do 97 | day <- toDay t 98 | time <- toTimeOfDay t 99 | return $ ZonedTime (LocalTime day time) (calendarTimeZone t) 100 | 101 | daysInYear :: (CalendarTimeConvertible a) => a -> Int 102 | daysInYear t = let ct = toCalendarTime t 103 | in if isLeapYear $ calendarYear ct then 366 else 365 104 | 105 | lastDayOfMonth :: (CalendarTimeConvertible a) => a -> Int 106 | lastDayOfMonth t = let ct = toCalendarTime t 107 | in gregorianMonthLength (calendarYear ct) (fromEnum $ calendarMonth ct) 108 | 109 | weekNumber :: (CalendarTimeConvertible a) => StartOfWeek -> a -> Maybe Int 110 | weekNumber _ t = do 111 | day <- toDay $ toCalendarTime t 112 | return $ fst $ mondayStartWeek day 113 | -------------------------------------------------------------------------------- /tests/Tests.lhs: -------------------------------------------------------------------------------- 1 | > {-# LANGUAGE CPP #-} 2 | 3 | HUnut test suite of example recurrences lifted from RFC 5545 section 3.8.5.3 4 | 5 | > module Main where 6 | 7 | > import Test.Framework (Test, defaultMain, testGroup) 8 | > import Test.Framework.Providers.HUnit 9 | > import Test.HUnit hiding (Test) 10 | 11 | There are various dates used during these tests, some as start dates and 12 | some as end dates. 13 | 14 | The examples are actually all in the America/New_York time zone, but since 15 | a local time instance has not been created yet, all the dates are converted 16 | into UTC. 17 | 18 | #if MIN_VERSION_time(1,5,0) 19 | > import Data.Time 20 | #else 21 | > import Data.Time 22 | > import System.Locale (TimeLocale, defaultTimeLocale, rfc822DateFormat) 23 | #endif 24 | 25 | > import Data.Maybe (fromJust) 26 | > import Prelude hiding (until, filter) 27 | > import Data.Time.Recurrence 28 | 29 | > timeParse :: ParseTime t => TimeLocale -> String -> String -> Maybe t 30 | #if MIN_VERSION_time(1,5,0) 31 | > timeParse = parseTimeM True 32 | #else 33 | > timeParse = parseTime 34 | #endif 35 | 36 | We are certain of the validity of the dates used, and so fromJust is safe 37 | to use. 38 | 39 | > date1, date2, date3, date4 :: UTCTime 40 | > parse822Time :: String -> UTCTime 41 | > parse822Time = zonedTimeToUTC 42 | > . fromJust 43 | > . timeParse defaultTimeLocale rfc822DateFormat 44 | > date1 = parse822Time "Tue, 02 Sep 1997 09:00:00 -0400" 45 | > date2 = parse822Time "Wed, 24 Dec 1997 00:00:00 -0400" 46 | > date3 = parse822Time "Thu, 01 Jan 1998 09:00:00 -0400" 47 | > date4 = parse822Time "Mon, 31 Jan 2000 09:00:00 -0400" 48 | 49 | > main :: IO () 50 | > main = defaultMain tests 51 | 52 | > until :: (Moment a, Ord a) => a -> [a] -> [a] 53 | > until m = takeWhile (<= m) 54 | 55 | > tests :: [Test] 56 | > tests = 57 | > [ testGroup "RFC5445 Examples" $ zipWith (testCase . show) [1::Int ..] 58 | > [ assertEqual ("Test Daily from "++ show date1 ++". 10 Occurrences") 59 | > (take 10 $ starting date1 $ recur daily) 60 | > (take 10 $ starting date1 $ recur monthly >==> enum (Days [2 .. 11])) 61 | > , assertEqual ("Test Daily from "++ show date1 ++". Until "++ show date2) 62 | > (until date2 $ starting date1 $ recur daily) 63 | > (until date2 $ starting date1 $ recur monthly >==> enum (WeekDaysInMonth [Monday .. Sunday])) 64 | > , assertBool ("Test every other day from "++ show date1 ++". Cap at 10000") 65 | > (checkDayDist 2 $ take 10000 $ starting date1 $ recur $ daily `by` 2) 66 | > , assertEqual ("Test every 10 days from "++ show date1 ++". 5 Occurrences") 67 | > (take 5 $ starting date1 $ recur $ daily `by` 10) 68 | > (take 5 $ starting date1 $ recur yearly >==> enum (Months [September, October]) >==> enum (Days [2,12,22])) 69 | > , assertEqual "Test every day in Jan. for 3 years" 70 | > (until date4 $ starting date3 $ recur yearly >==> enum (Months [January]) >==> enum (WeekDaysInMonth [Monday .. Sunday])) 71 | > (until date4 $ starting date3 $ recur daily >==> filter (Months [January])) 72 | > ] 73 | > , testGroup "Tests to ensure Github Issue-1 is fixed" $ zipWith (testCase . show) [1::Int ..] 74 | > [ getCurrentTime >>= \now -> 75 | > assertEqual ("Generate 3 dates on the 0 and 30 minute marks") 76 | > 3 (length $ take 3 . starting now $ recur daily >==> enum (Minutes [0,30])) 77 | > , getCurrentTime >>= \now -> 78 | > assertEqual ("Generate a single date on the 0 minute mark") 79 | > 1 (length $ take 1 . starting now $ recur daily >==> enum (Minutes [0])) 80 | > ] 81 | > ] 82 | 83 | This is the assertion function for testing the number of days between moments. 84 | It will be used in a couple of tests, and requires at least two moments to 85 | operate correctly. 86 | 87 | > dayDist :: [UTCTime] -> [Integer] 88 | > dayDist [] = [] 89 | > dayDist (_:[]) = [] 90 | > dayDist (x:xs) = fst $ foldl go ([], utcDay x) xs 91 | > where 92 | > go acc x = let d = utcDay x in (abs (diffDays d (snd acc)):fst acc, d) 93 | > utcDay (UTCTime d _) = d 94 | > checkDayDist :: Integer -> [UTCTime] -> Bool 95 | > checkDayDist d = all (== d) . dayDist 96 | -------------------------------------------------------------------------------- /src/Data/Time/Recurrence/Schedule.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, StandaloneDeriving, UndecidableInstances #-} 2 | -- This module is intended to be imported @qualified!, to avoid name 3 | -- clashes with "Prelude" functions. eg. 4 | -- 5 | -- > import qualified Data.Time.Recurrence.Schedule as S 6 | module Data.Time.Recurrence.Schedule 7 | ( 8 | -- * Schedule 9 | Schedule (..) 10 | 11 | -- * Freq 12 | , Freq 13 | 14 | -- * Function interface to Recur 15 | , recur 16 | 17 | -- * Adjust Interval 18 | , by 19 | -- * Adjust Start of Week 20 | , withStartOfWeek 21 | 22 | -- * Default Freq 23 | , secondly 24 | , minutely 25 | , hourly 26 | , daily 27 | , weekly 28 | , monthly 29 | , yearly 30 | 31 | -- * evaluate a Schedule into a function 32 | , eval 33 | 34 | -- * run an evaluated Schedule from a moment 35 | , starting 36 | ) 37 | where 38 | 39 | import Data.List.Ordered as O 40 | import Data.Time.Calendar.Month () 41 | import Data.Time.Calendar.WeekDay 42 | import Data.Time.CalendarTime 43 | import Data.Time.Moment hiding (interval, startOfWeek, Period(..)) 44 | import qualified Data.Time.Moment as M (Period(..)) 45 | import Data.Time.Recurrence.AndThen 46 | import Data.Time.Recurrence.ScheduleDetails hiding (eval) 47 | import qualified Data.Time.Recurrence.ScheduleDetails as D (eval) 48 | 49 | data Freq 50 | = Secondly { interval :: Interval, startOfWeek :: StartOfWeek } 51 | | Minutely { interval :: Interval, startOfWeek :: StartOfWeek } 52 | | Hourly { interval :: Interval, startOfWeek :: StartOfWeek } 53 | | Daily { interval :: Interval, startOfWeek :: StartOfWeek } 54 | | Weekly { interval :: Interval, startOfWeek :: StartOfWeek } 55 | | Monthly { interval :: Interval, startOfWeek :: StartOfWeek } 56 | | Yearly { interval :: Interval, startOfWeek :: StartOfWeek } 57 | deriving (Show) 58 | 59 | defaultFreq :: (Interval -> StartOfWeek -> Freq) -> Freq 60 | defaultFreq = flip uncurry (toInterval 1, toStartOfWeek Sunday) 61 | 62 | secondly :: Freq 63 | secondly = defaultFreq Secondly 64 | 65 | minutely :: Freq 66 | minutely = defaultFreq Minutely 67 | 68 | hourly :: Freq 69 | hourly = defaultFreq Hourly 70 | 71 | daily :: Freq 72 | daily = defaultFreq Daily 73 | 74 | weekly :: Freq 75 | weekly = defaultFreq Weekly 76 | 77 | monthly :: Freq 78 | monthly = defaultFreq Monthly 79 | 80 | yearly :: Freq 81 | yearly = defaultFreq Yearly 82 | 83 | -- | Typically called infix on an existing 'Freq', like: 84 | -- 85 | -- > monthly `by` 2 86 | by :: Freq -> Integer -> Freq 87 | by fr i = fr{interval=toInterval i} 88 | 89 | -- | Typically called infix on an existing 'Freq', like: 90 | -- 91 | -- > weekly `withStartOfWeek` Tuesday 92 | withStartOfWeek :: Freq -> WeekDay -> Freq 93 | withStartOfWeek fr sow = fr{startOfWeek=toStartOfWeek sow} 94 | 95 | 96 | data Schedule a where 97 | Recur :: Freq -> Schedule Freq 98 | And :: Schedule Freq -> ScheduleDetails b -> Schedule (ScheduleDetails b) 99 | 100 | deriving instance Show (Schedule a) 101 | 102 | recur :: Freq -> Schedule Freq 103 | recur = Recur 104 | 105 | instance AndThen (Schedule Freq) (ScheduleDetails b) (Schedule (ScheduleDetails b)) where 106 | (>==>) x y = And x y 107 | 108 | eval :: (CalendarTimeConvertible a, Ord a, Moment a) => Schedule b -> (a -> [a]) 109 | eval (And recur details) = flip (startWith $ mkIM recur) $ D.eval details 110 | eval recur@(Recur _) = start $ mkIM recur 111 | 112 | starting :: (CalendarTimeConvertible a, Ord a, Moment a) => a -> Schedule b -> [a] 113 | starting m0 sch = (eval sch) m0 114 | 115 | mkIM :: Moment a => Schedule Freq -> InitialMoment a 116 | mkIM (Recur freq) = 117 | mkIM' (case freq of (Secondly _ _) -> M.Seconds 118 | (Minutely _ _) -> M.Minutes 119 | (Hourly _ _) -> M.Hours 120 | (Daily _ _) -> M.Days 121 | (Weekly _ _) -> M.Weeks 122 | (Monthly _ _) -> M.Months 123 | (Yearly _ _) -> M.Years) (interval freq) (startOfWeek freq) 124 | where 125 | mkIM' :: Moment a => M.Period -> Interval -> StartOfWeek -> InitialMoment a 126 | mkIM' per int sow = InitialMoment per int sow epoch 127 | 128 | -- | 'startWith' is an infinite list of 'Moment's, where no 'Moment' 129 | -- occurrs before the 'InitialMoment'. The list is further refined 130 | -- by the passed in function. 131 | startWith :: (Ord a, Moment a) => 132 | InitialMoment a 133 | -> a 134 | -> ([a] -> FutureMoments a) 135 | -> [a] 136 | startWith im m0 = dropWhile (< m0) . O.nub . iterateFutureMoments im{moment=m0} 137 | 138 | start :: (Ord a, Moment a) => InitialMoment a -> a -> [a] 139 | start im m0 = startWith im m0 return 140 | -------------------------------------------------------------------------------- /src/Data/Time/Moment/Moment.hs: -------------------------------------------------------------------------------- 1 | module Data.Time.Moment.Moment 2 | ( 3 | -- * Moment 4 | Moment (..) 5 | , iterateMoments 6 | , withYearDay 7 | , withWeekNumber 8 | , withSecond 9 | , withMinute 10 | , withHour 11 | , withDay 12 | , withMonth 13 | , withYear 14 | , advanceToWeekDay 15 | 16 | -- * Initial Moment 17 | , InitialMoment (..) 18 | 19 | -- * Period 20 | , Period (..) 21 | ) 22 | where 23 | 24 | import Data.Time.Calendar.Month 25 | import Data.Time.Calendar.OrdinalDate 26 | import Data.Time.Calendar.WeekDay 27 | import Data.Time.CalendarTime hiding (withDay) 28 | import qualified Data.Time.CalendarTime as CT 29 | import Data.Time.Moment.Interval 30 | import Data.Time.Moment.Private 31 | import Data.Time.Moment.StartOfWeek () 32 | 33 | oneSecond :: Integer 34 | oneSecond = 1 35 | 36 | oneMinute :: Integer 37 | oneMinute = 60 * oneSecond 38 | 39 | oneHour :: Integer 40 | oneHour = 60 * oneMinute 41 | 42 | oneDay :: Integer 43 | oneDay = 24 * oneHour 44 | 45 | oneWeek :: Integer 46 | oneWeek = 7 * oneDay 47 | 48 | -- | The @Moment@ class is for representing a instance in time. 49 | -- 50 | -- Instances of @Moment@ can be derived for any user-defined 51 | -- datatype for which can satisfy the minimal complete definition. 52 | -- 53 | -- Minimal complete definition: 'epoch', 'addSeconds', 'addMonths', 'addYears' 54 | 55 | class Moment a where 56 | -- | Provide a default moment. 57 | epoch :: a 58 | addSeconds :: a -> Integer -> a 59 | addMonths :: a -> Integer -> a 60 | addYears :: a -> Integer -> a 61 | 62 | addMinutes :: a -> Integer -> a 63 | addMinutes a = addSeconds a . (* oneMinute) 64 | addHours :: a -> Integer -> a 65 | addHours a = addSeconds a . (* oneHour) 66 | addDays :: a -> Integer -> a 67 | addDays a = addSeconds a . (* oneDay) 68 | addWeeks :: a -> Integer -> a 69 | addWeeks a = addSeconds a . (* oneWeek) 70 | 71 | -- | Produce a new @Moment@ in the future ocurring at (/interval/ * /freq/) 72 | next :: Interval -> Period -> a -> a 73 | next (Interval interval) freq = 74 | case freq of 75 | Seconds -> add oneSecond 76 | Minutes -> add oneMinute 77 | Hours -> add oneHour 78 | Days -> add oneDay 79 | Weeks -> add oneWeek 80 | Months -> flip addMonths interval 81 | Years -> flip addYears interval 82 | where 83 | add x = flip addSeconds (interval * x) 84 | 85 | -- | Produce a new @Moment@ in the past ocurring at (-/interval/ * /freq/) 86 | prev :: Interval -> Period -> a -> a 87 | prev (Interval interval) = next $ Interval (-interval) 88 | 89 | -- | Produce an infinite list from an initial @Moment@ and a step function. 90 | iterateMoments :: Moment a => (a -> a) -> a -> [a] 91 | iterateMoments = iterate 92 | 93 | -- | Possibly produce a 'Moment' with the given week number 94 | withWeekNumber :: 95 | (CalendarTimeConvertible a, Moment a) => 96 | StartOfWeek 97 | -> a 98 | -> Int 99 | -> Maybe a 100 | withWeekNumber _ t wk = do 101 | let ct = toCalendarTime t 102 | day <- fromMondayStartWeekValid (calendarYear ct) wk (fromEnum $ calendarWeekDay ct) 103 | fromCalendarTime $ CT.withDay ct day 104 | 105 | -- | Possibly produce a 'Moment' with the given day of the year 106 | withYearDay :: 107 | (CalendarTimeConvertible a, Moment a) => 108 | a 109 | -> Int 110 | -> Maybe a 111 | withYearDay t yd = do 112 | let ct = toCalendarTime t 113 | day <- fromOrdinalDateValid (calendarYear ct) yd 114 | fromCalendarTime $ CT.withDay ct day 115 | 116 | -- | Possibly produce a 'Moment' with the given second 117 | withSecond :: (CalendarTimeConvertible a, Moment a) => a -> Int -> Maybe a 118 | withSecond t s = fromCalendarTime (toCalendarTime t){calendarSecond = s} 119 | 120 | -- | Possibly produce a 'Moment' with the given minute 121 | withMinute :: (CalendarTimeConvertible a, Moment a) => a -> Int -> Maybe a 122 | withMinute t m = fromCalendarTime (toCalendarTime t){calendarMinute = m} 123 | 124 | -- | Possibly produce a 'Moment' with the given hour 125 | withHour :: (CalendarTimeConvertible a, Moment a) => a -> Int -> Maybe a 126 | withHour t h = fromCalendarTime (toCalendarTime t){calendarHour = h} 127 | 128 | -- | Possibly produce a 'Moment' with the given month day 129 | withDay :: (CalendarTimeConvertible a, Moment a) => a -> Int -> Maybe a 130 | withDay t d = fromCalendarTime (toCalendarTime t){calendarDay = d} 131 | 132 | -- | Possibly produce a 'Moment' with the given month 133 | withMonth :: (CalendarTimeConvertible a, Moment a) => a -> Month -> Maybe a 134 | withMonth t m = fromCalendarTime (toCalendarTime t){calendarMonth = m} 135 | 136 | -- | Possibly produce a 'Moment' with the given year 137 | withYear :: (CalendarTimeConvertible a, Moment a) => a -> Integer -> Maybe a 138 | withYear t y = fromCalendarTime (toCalendarTime t){calendarYear = y} 139 | 140 | advanceToWeekDay :: 141 | (CalendarTimeConvertible a, Moment a) => 142 | a -> 143 | WeekDay -> 144 | a 145 | advanceToWeekDay t d = let 146 | ct = toCalendarTime t 147 | d0 = calendarWeekDay ct 148 | d' = fromEnum d 149 | d0' = fromEnum d0 150 | delta = toInteger $ d' - d0' `mod` 7 151 | in addDays t $ if delta == 0 then 7 else delta 152 | 153 | -- | The @InitialMoment@ datatype 154 | 155 | data InitialMoment a = InitialMoment 156 | { period :: Period 157 | , interval :: Interval 158 | , startOfWeek :: StartOfWeek 159 | , moment :: a 160 | } 161 | deriving (Show) 162 | 163 | -- | @Period@ data type 164 | data Period 165 | = Seconds 166 | | Minutes 167 | | Hours 168 | | Days 169 | | Weeks 170 | | Months 171 | | Years 172 | deriving (Enum, Bounded, Eq, Ord, Show) 173 | -------------------------------------------------------------------------------- /src/Data/Time/Recurrence/ScheduleDetails.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, EmptyDataDecls, FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, RankNTypes, StandaloneDeriving, TypeSynonymInstances,UndecidableInstances #-} 2 | module Data.Time.Recurrence.ScheduleDetails 3 | ( 4 | -- * ScheduleDetails 5 | ScheduleDetails 6 | 7 | , eval 8 | 9 | -- * Functional interface to constructors 10 | , enum 11 | , filter 12 | , select 13 | 14 | -- * Period Filters 15 | , PeriodFilter (..) 16 | , EnumerablePeriodFilter (..) 17 | , FilterablePeriodFilter (..) 18 | , SelectablePeriodFilter (..) 19 | ) 20 | where 21 | 22 | import Prelude hiding (filter) 23 | import Control.Monad ((>=>)) 24 | import Data.Time.Calendar.Month 25 | import Data.Time.Calendar.WeekDay 26 | import Data.Time.CalendarTime 27 | import Data.Time.Moment hiding (Period(..)) 28 | import Data.Time.Recurrence.AndThen 29 | 30 | data ScheduleDetails a where 31 | Enumerate :: EnumerablePeriodFilter -> ScheduleDetails EnumerablePeriodFilter 32 | Filter :: FilterablePeriodFilter -> ScheduleDetails FilterablePeriodFilter 33 | Select :: SelectablePeriodFilter -> ScheduleDetails SelectablePeriodFilter 34 | EPFCons :: ScheduleDetails EnumerablePeriodFilter -> ScheduleDetails EnumerablePeriodFilter -> ScheduleDetails EnumerablePeriodFilter 35 | FPFCons :: ScheduleDetails FilterablePeriodFilter -> ScheduleDetails FilterablePeriodFilter -> ScheduleDetails FilterablePeriodFilter 36 | SPFCons :: ScheduleDetails SelectablePeriodFilter -> ScheduleDetails SelectablePeriodFilter -> ScheduleDetails SelectablePeriodFilter 37 | EPFConsFPF :: ScheduleDetails EnumerablePeriodFilter -> ScheduleDetails FilterablePeriodFilter -> ScheduleDetails FilterablePeriodFilter 38 | FPFConsSPF :: ScheduleDetails FilterablePeriodFilter -> ScheduleDetails SelectablePeriodFilter -> ScheduleDetails SelectablePeriodFilter 39 | EPFConsSPF :: ScheduleDetails EnumerablePeriodFilter -> ScheduleDetails SelectablePeriodFilter -> ScheduleDetails SelectablePeriodFilter 40 | 41 | deriving instance Show (ScheduleDetails a) 42 | 43 | enum :: PeriodFilter Month WeekDay NotEnumerable -> ScheduleDetails EnumerablePeriodFilter 44 | enum = Enumerate . EPF 45 | 46 | filter :: PeriodFilter Month NotFilterable WeekDay -> ScheduleDetails FilterablePeriodFilter 47 | filter = Filter . FPF 48 | 49 | select :: PeriodFilter Int Int Int -> ScheduleDetails SelectablePeriodFilter 50 | select = Select . SPF 51 | 52 | type BareEPF = EnumerablePeriodFilter 53 | type WrapEPF = ScheduleDetails EnumerablePeriodFilter 54 | 55 | instance AndThen BareEPF BareEPF WrapEPF where 56 | (>==>) x y = (Enumerate x) `EPFCons` (Enumerate y) 57 | 58 | instance AndThen BareEPF WrapEPF WrapEPF where 59 | (>==>) x y = (Enumerate x) `EPFCons` y 60 | 61 | instance AndThen WrapEPF WrapEPF WrapEPF where 62 | (>==>) x y = x `EPFCons` y 63 | 64 | type BareFPF = FilterablePeriodFilter 65 | type WrapFPF = ScheduleDetails FilterablePeriodFilter 66 | 67 | instance AndThen BareFPF BareFPF WrapFPF where 68 | (>==>) x y = (Filter x) `FPFCons` (Filter y) 69 | 70 | instance AndThen BareFPF WrapFPF WrapFPF where 71 | (>==>) x y = (Filter x) `FPFCons` y 72 | 73 | instance AndThen WrapFPF WrapFPF WrapFPF where 74 | (>==>) x y = x `FPFCons` y 75 | 76 | type BareSPF = SelectablePeriodFilter 77 | type WrapSPF = ScheduleDetails SelectablePeriodFilter 78 | 79 | instance AndThen BareSPF BareSPF WrapSPF where 80 | (>==>) x y = (Select x) `SPFCons` (Select y) 81 | 82 | instance AndThen BareSPF WrapSPF WrapSPF where 83 | (>==>) x y = (Select x) `SPFCons` y 84 | 85 | instance AndThen WrapSPF WrapSPF WrapSPF where 86 | (>==>) x y = x `SPFCons` y 87 | 88 | instance AndThen WrapEPF WrapFPF WrapFPF where 89 | (>==>) x y = x `EPFConsFPF` y 90 | 91 | instance AndThen WrapFPF WrapSPF WrapSPF where 92 | (>==>) x y = x `FPFConsSPF` y 93 | 94 | instance AndThen WrapEPF WrapSPF WrapSPF where 95 | (>==>) x y = x `EPFConsSPF` y 96 | 97 | data PeriodFilter m e f 98 | = Seconds [Int] 99 | | Minutes [Int] 100 | | Hours [Int] 101 | | Days [Int] 102 | | Weeks [Int] 103 | | WeekDays [f] 104 | | WeekDaysInWeek [e] 105 | | WeekDaysInMonth [e] 106 | | Months [m] 107 | | YearDays [Int] 108 | deriving (Read, Show) 109 | 110 | data NotEnumerable 111 | data NotFilterable 112 | 113 | instance Show NotEnumerable where 114 | show _ = undefined 115 | 116 | instance Read NotEnumerable where 117 | readsPrec _ _ = undefined 118 | 119 | instance Show NotFilterable where 120 | show _ = undefined 121 | 122 | instance Read NotFilterable where 123 | readsPrec _ _ = undefined 124 | 125 | newtype EnumerablePeriodFilter = EPF { fromEPF :: PeriodFilter Month WeekDay NotEnumerable } deriving (Read, Show) 126 | newtype FilterablePeriodFilter = FPF { fromFPF :: PeriodFilter Month NotFilterable WeekDay } deriving (Read, Show) 127 | newtype SelectablePeriodFilter = SPF { fromSPF :: PeriodFilter Int Int Int } deriving (Read, Show) 128 | 129 | eval :: (CalendarTimeConvertible a, Ord a, Moment a) => ScheduleDetails b -> ([a] -> FutureMoments a) 130 | eval (Enumerate x) = case (fromEPF x) of 131 | (Seconds ss) -> enumSeconds ss 132 | (Minutes mm) -> enumMinutes mm 133 | (Hours hh) -> enumHours hh 134 | (WeekDays _) -> undefined 135 | (WeekDaysInWeek ww) -> enumWeekDaysInWeek ww 136 | (WeekDaysInMonth ww) -> enumWeekDaysInMonth ww 137 | (Days dd) -> enumDays dd 138 | (Weeks wk) -> enumWeeks wk 139 | (Months mm) -> enumMonths mm 140 | (YearDays yy) -> enumYearDays yy 141 | eval (Filter x) = case (fromFPF x) of 142 | (Seconds ss) -> filterSeconds ss 143 | (Minutes mm) -> filterMinutes mm 144 | (Hours hh) -> filterHours hh 145 | (WeekDays ww) -> filterWeekDays ww 146 | (WeekDaysInWeek _) -> undefined 147 | (WeekDaysInMonth _) -> undefined 148 | (Days dd) -> filterDays dd 149 | (Weeks wk) -> filterWeeks wk 150 | (Months mm) -> filterMonths mm 151 | (YearDays yy) -> filterYearDays yy 152 | eval (Select x) = case (fromSPF x) of 153 | (Seconds ss) -> nthSecond ss 154 | (Minutes mm) -> nthMinute mm 155 | (Hours hh) -> nthHour hh 156 | (WeekDays ww) -> nthWeekDay ww 157 | (WeekDaysInWeek ww) -> nthWeekDayOfWeek ww 158 | (WeekDaysInMonth ww) -> nthWeekDayOfMonth ww 159 | (Weeks wk) -> nthWeek wk 160 | (Days dd) -> nthDay dd 161 | (Months mm) -> nthDay mm 162 | (YearDays yy) -> nthYearDay yy 163 | eval (EPFCons x y) = eval x >=> eval y 164 | eval (FPFCons x y) = eval x >=> eval y 165 | eval (SPFCons x y) = eval x >=> eval y 166 | eval (EPFConsFPF x y) = eval x >=> eval y 167 | eval (FPFConsSPF x y) = eval x >=> eval y 168 | eval (EPFConsSPF x y) = eval x >=> eval y 169 | 170 | 171 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | GNU LESSER GENERAL PUBLIC LICENSE 2 | Version 3, 29 June 2007 3 | 4 | Copyright (C) 2007 Free Software Foundation, Inc. 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | 9 | This version of the GNU Lesser General Public License incorporates 10 | the terms and conditions of version 3 of the GNU General Public 11 | License, supplemented by the additional permissions listed below. 12 | 13 | 0. Additional Definitions. 14 | 15 | As used herein, "this License" refers to version 3 of the GNU Lesser 16 | General Public License, and the "GNU GPL" refers to version 3 of the GNU 17 | General Public License. 18 | 19 | "The Library" refers to a covered work governed by this License, 20 | other than an Application or a Combined Work as defined below. 21 | 22 | An "Application" is any work that makes use of an interface provided 23 | by the Library, but which is not otherwise based on the Library. 24 | Defining a subclass of a class defined by the Library is deemed a mode 25 | of using an interface provided by the Library. 26 | 27 | A "Combined Work" is a work produced by combining or linking an 28 | Application with the Library. The particular version of the Library 29 | with which the Combined Work was made is also called the "Linked 30 | Version". 31 | 32 | The "Minimal Corresponding Source" for a Combined Work means the 33 | Corresponding Source for the Combined Work, excluding any source code 34 | for portions of the Combined Work that, considered in isolation, are 35 | based on the Application, and not on the Linked Version. 36 | 37 | The "Corresponding Application Code" for a Combined Work means the 38 | object code and/or source code for the Application, including any data 39 | and utility programs needed for reproducing the Combined Work from the 40 | Application, but excluding the System Libraries of the Combined Work. 41 | 42 | 1. Exception to Section 3 of the GNU GPL. 43 | 44 | You may convey a covered work under sections 3 and 4 of this License 45 | without being bound by section 3 of the GNU GPL. 46 | 47 | 2. Conveying Modified Versions. 48 | 49 | If you modify a copy of the Library, and, in your modifications, a 50 | facility refers to a function or data to be supplied by an Application 51 | that uses the facility (other than as an argument passed when the 52 | facility is invoked), then you may convey a copy of the modified 53 | version: 54 | 55 | a) under this License, provided that you make a good faith effort to 56 | ensure that, in the event an Application does not supply the 57 | function or data, the facility still operates, and performs 58 | whatever part of its purpose remains meaningful, or 59 | 60 | b) under the GNU GPL, with none of the additional permissions of 61 | this License applicable to that copy. 62 | 63 | 3. Object Code Incorporating Material from Library Header Files. 64 | 65 | The object code form of an Application may incorporate material from 66 | a header file that is part of the Library. You may convey such object 67 | code under terms of your choice, provided that, if the incorporated 68 | material is not limited to numerical parameters, data structure 69 | layouts and accessors, or small macros, inline functions and templates 70 | (ten or fewer lines in length), you do both of the following: 71 | 72 | a) Give prominent notice with each copy of the object code that the 73 | Library is used in it and that the Library and its use are 74 | covered by this License. 75 | 76 | b) Accompany the object code with a copy of the GNU GPL and this license 77 | document. 78 | 79 | 4. Combined Works. 80 | 81 | You may convey a Combined Work under terms of your choice that, 82 | taken together, effectively do not restrict modification of the 83 | portions of the Library contained in the Combined Work and reverse 84 | engineering for debugging such modifications, if you also do each of 85 | the following: 86 | 87 | a) Give prominent notice with each copy of the Combined Work that 88 | the Library is used in it and that the Library and its use are 89 | covered by this License. 90 | 91 | b) Accompany the Combined Work with a copy of the GNU GPL and this license 92 | document. 93 | 94 | c) For a Combined Work that displays copyright notices during 95 | execution, include the copyright notice for the Library among 96 | these notices, as well as a reference directing the user to the 97 | copies of the GNU GPL and this license document. 98 | 99 | d) Do one of the following: 100 | 101 | 0) Convey the Minimal Corresponding Source under the terms of this 102 | License, and the Corresponding Application Code in a form 103 | suitable for, and under terms that permit, the user to 104 | recombine or relink the Application with a modified version of 105 | the Linked Version to produce a modified Combined Work, in the 106 | manner specified by section 6 of the GNU GPL for conveying 107 | Corresponding Source. 108 | 109 | 1) Use a suitable shared library mechanism for linking with the 110 | Library. A suitable mechanism is one that (a) uses at run time 111 | a copy of the Library already present on the user's computer 112 | system, and (b) will operate properly with a modified version 113 | of the Library that is interface-compatible with the Linked 114 | Version. 115 | 116 | e) Provide Installation Information, but only if you would otherwise 117 | be required to provide such information under section 6 of the 118 | GNU GPL, and only to the extent that such information is 119 | necessary to install and execute a modified version of the 120 | Combined Work produced by recombining or relinking the 121 | Application with a modified version of the Linked Version. (If 122 | you use option 4d0, the Installation Information must accompany 123 | the Minimal Corresponding Source and Corresponding Application 124 | Code. If you use option 4d1, you must provide the Installation 125 | Information in the manner specified by section 6 of the GNU GPL 126 | for conveying Corresponding Source.) 127 | 128 | 5. Combined Libraries. 129 | 130 | You may place library facilities that are a work based on the 131 | Library side by side in a single library together with other library 132 | facilities that are not Applications and are not covered by this 133 | License, and convey such a combined library under terms of your 134 | choice, if you do both of the following: 135 | 136 | a) Accompany the combined library with a copy of the same work based 137 | on the Library, uncombined with any other library facilities, 138 | conveyed under the terms of this License. 139 | 140 | b) Give prominent notice with the combined library that part of it 141 | is a work based on the Library, and explaining where to find the 142 | accompanying uncombined form of the same work. 143 | 144 | 6. Revised Versions of the GNU Lesser General Public License. 145 | 146 | The Free Software Foundation may publish revised and/or new versions 147 | of the GNU Lesser General Public License from time to time. Such new 148 | versions will be similar in spirit to the present version, but may 149 | differ in detail to address new problems or concerns. 150 | 151 | Each version is given a distinguishing version number. If the 152 | Library as you received it specifies that a certain numbered version 153 | of the GNU Lesser General Public License "or any later version" 154 | applies to it, you have the option of following the terms and 155 | conditions either of that published version or of any later version 156 | published by the Free Software Foundation. If the Library as you 157 | received it does not specify a version number of the GNU Lesser 158 | General Public License, you may choose any version of the GNU Lesser 159 | General Public License ever published by the Free Software Foundation. 160 | 161 | If the Library as you received it specifies that a proxy can decide 162 | whether future versions of the GNU Lesser General Public License shall 163 | apply, that proxy's public statement of acceptance of any version is 164 | permanent authorization for you to choose that version for the 165 | Library. 166 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | time-recurrence is a Haskell library for working with recurring date/times. 2 | 3 | The iCalendar Specifcation (RFC 5545) is used for inspiration of this 4 | library, however the library does not make an effort to track the RFC 5 | at all times. A future Data.Time.Recurrence.RFC5545 library would be 6 | a useful add-on for those in need of strict RFC compliance. 7 | 8 | Examples: 9 | 10 | > parse822Time :: String -> UTCTime 11 | > parse822Time = ... 12 | 13 | > nov1996 = parse822Time "Tue, 05 Nov 1996 09:00:00 -0400" 14 | > mar1997 = parse822Time "Mon, 10 Mar 1997 09:00:00 -0400" 15 | > sep1997 = parse822Time "Tue, 02 Sep 1997 09:00:00 -0400" 16 | > oct1997 = parse822Time "Fri, 10 Oct 1997 00:00:00 -0400" 17 | > dec1997 = parse822Time "Wed, 24 Dec 1997 00:00:00 -0400" 18 | > jan1998 = parse822Time "Thu, 01 Jan 1998 09:00:00 -0400" 19 | > jan2000 = parse822Time "Mon, 31 Jan 2000 09:00:00 -0400" 20 | 21 | Daily for 10 occurrences: 22 | 23 | > take 10 $ starting sep1997 $ recur daily 24 | 25 | Daily until Dec. 24, 1997: 26 | 27 | > takeWhile (<= dec1997) $ starting sep1997 $ recur daily 28 | 29 | Every other day - forever: 30 | 31 | > starting sep1997 $ recur daily `by` 2 32 | 33 | Every 10 days, 5 occurrences: 34 | 35 | > take 5 $ starting sep1997 $ recur daily `by` 10 36 | 37 | Every day in January, for 3 years: 38 | 39 | > takeWhile (<= jan2000) $ starting jan1998 $ 40 | > recur yearly 41 | > >==> enum (Months [January]) 42 | > >==> filter (WeekDays [Monday .. Sunday]) 43 | 44 | > takeWhile (<= jan2000) $ starting jan1998 $ 45 | > recur daily 46 | > >==> enum (Months [January]) 47 | 48 | Weekly for 10 occurrences: 49 | 50 | > take 10 $ starting sep1997 $ recur weekly 51 | 52 | Weekly until Dec. 24, 1997: 53 | 54 | > takeWhile (<= dec1997) $ starting sep1997 $ 55 | > recur weekly `withStartOfWeek` Sunday 56 | 57 | Every other week - forever: 58 | 59 | > starting sep1997 $ recur weekly `by` 2 60 | 61 | Weekly on Tuesday and Thursday for five weeks: 62 | 63 | > takeUntil (<= oct1997) $ starting sep1997 $ 64 | > recur weekly `withStartOfWeek` Sunday 65 | > >==> enum (WeekDaysInWeek [Tuesday, Thursday]) 66 | 67 | or 68 | 69 | > take 10 $ starting sep1997 $ 70 | > recur weekly `withStartOfWeek` Sunday 71 | > >==> enum (WeekDaysInWeek [Tuesday, Thursday]) 72 | 73 | Every other week (Monday, Wednesday, Firday) until Dec. 24, 1997: 74 | 75 | > takeWhile (<= dec1997) $ starting sep1997 $ 76 | > recur weekly `withStartOfWeek` Sunday `by` 2 77 | > >==> enum (WeekDaysInWeek [Monday, Wednesday, Friday]) 78 | 79 | > Every other week on Tuesday and Thursday, for 8 occurrences: 80 | 81 | > take 8 $ starting sep1997 $ 82 | > recur weekly `by` 2 `withStartOfWeek` Sunday 83 | > >==> enum (WeekDaysInWeek [Tuesday, Thursday]) 84 | 85 | Monthly on the first Friday for 10 occurrences: 86 | 87 | > take 10 $ starting sep1997 $ 88 | > recur monthly 89 | > >==> enum (WeekDaysInMonth [Friday]) 90 | > >==> select (WeekDaysInMonth [1]) 91 | 92 | Monthly on the first Friday until Dec. 24, 1997 93 | 94 | > takeWhile (<= dec1997) $ starting sep1997 $ 95 | > recur monthly 96 | > >==> enum (WeekDaysInMonth [Friday]) 97 | > >==> select (WeekDaysInMonth [1]) 98 | 99 | Every other month on the first and last Sunday of the month for 10 occurrences: 100 | 101 | > take 10 $ starting sep1997 $ 102 | > recur monthly 103 | > >==> enum (WeekDaysInMonth [Sunday]) 104 | > >==> select (WeekDaysInMonth [1,-1]) 105 | 106 | Monthly on the second-to-last Monday of the month for 6 months: 107 | 108 | > take 6 $ starting sep1997 $ 109 | > recur monthly 110 | > >==> enum (WeekDaysInMonth [Monday]) 111 | > >==> select (WeekDaysInMonth [-2]) 112 | 113 | Monthly on the third-to-last day of the month, forever: 114 | 115 | > starting sep1997 $ 116 | > recur monthly 117 | > >==> enum (Days [-3]) 118 | 119 | Monthly on the 2nd and 15th of the month for 10 occurrences: 120 | 121 | > take 10 $ starting sep1997 $ 122 | > recur monthly 123 | > >==> enum (Days [2,15]) 124 | 125 | Monthly on the first and last day of the month for 10 occurrences: 126 | 127 | > take 10 $ starting sep1997 $ 128 | > recur monthly 129 | > >==> enum (Days [1,-1]) 130 | 131 | Every 18 months on the 10th thru 15th of the month for 10 occurrences: 132 | 133 | > take 10 $ starting sep1997 $ 134 | > recur monthly 135 | > >==> enum (Days [10 .. 15]) 136 | 137 | Every Tuesday, every other month: 138 | 139 | > starting sep1997 $ 140 | > recur monthly `by` 2 141 | > >==> enum (WeekDaysInMonth [Tuesday]) 142 | 143 | Yearly in June and July for 10 occurrences: 144 | 145 | > take 10 $ starting sep1997 $ 146 | > recur yearly 147 | > >==> enum (Months [June, July]) 148 | 149 | Every other year on January thru March for 10 occurrences: 150 | 151 | > take 10 $ starting mar1997 $ 152 | > recur yearly `by` 2 153 | > >==> enum (Months [January .. March]) 154 | > >==> enum (WeekDaysInMonth [Monday .. Sunday]) 155 | 156 | Every third year on the 1st, 100th, and 200th day for 10 occurrences: 157 | 158 | > take 10 $ starting sep1997 $ 159 | > recur yearly `by` 3 160 | > >==> enum (YearDays [1,100,200]) 161 | 162 | Every 20th Monday of the year, forever: 163 | 164 | > starting sep1997 $ 165 | > recur montly 166 | > >==> enum (WeekDaysInMonth [Monday]) 167 | > >==> select (WeekDays [20]) 168 | 169 | Monday of week number 20, forever: 170 | 171 | > starting mar1997 $ 172 | > recur yearly 173 | > >==> enum (Weeks [20]) 174 | > >==> filter (WeekDays [Monday]) 175 | 176 | or 177 | 178 | > starting mar1997 $ 179 | > recur weekly 180 | > >==> filter (Weeks [20]) 181 | > >==> filter (WeekDays [Monday]) 182 | 183 | Every Thursday in March, forever: 184 | 185 | > starting mar1997 $ 186 | > recur yearly 187 | > >==> enum (Months [March]) 188 | > >==> enum (WeekDaysInMonth [Thursday]) 189 | 190 | Every Thursday, but only during June thru August, forever: 191 | 192 | > starting mar1997 $ 193 | > recur yearly 194 | > >==> enum (Months [June .. August]) 195 | > >==> enum (WeekDaysInMonth [Thursday]) 196 | 197 | Friday the 13th, Forever: 198 | 199 | > starting sep1997 200 | > recur monthly 201 | > >==> enum (Days [13]) 202 | > >==> filter (WeekDays [Friday]) 203 | 204 | The first Saturday that follows the first Sunday of the month, forever: 205 | 206 | > recur monthly sep1997 $ 207 | > enumDays [7 .. 13] >=> 208 | > filterWeekDays [Saturday] 209 | 210 | U.S. Presidential Election Day: 211 | Every 4 years, the first Tuesday after a Monday in November, forever: 212 | 213 | > starting nov1996 $ 214 | > recur yearly `by` 4 215 | > >==> enum (Months [November]) 216 | > >==> enum (Days [2 .. 8]) 217 | > >==> filter (WeekDays [Tuesday]) 218 | 219 | The third instance into the month of one of Tuesday, Wednesday, or Thursday, for the next 3 months. 220 | 221 | > take 3 $ starting sep1997 $ 222 | > recur monthly 223 | > >==> enum (WeekDaysInMonth [Tuesday .. Thursday]) 224 | > >==> select (WeekDaysInMonth [3]) 225 | 226 | The second-to-last weekday of the month: 227 | 228 | > starting sep1997 $ 229 | > recur monthly 230 | > >==> enum (WeekDaysInMonth [Monday .. Friday]) 231 | > >==> select (WeekDaysInMonth [-2]) 232 | 233 | Every 3 hours from 9:00 AM to 5:00 PM on a specific day: 234 | 235 | > takeWhile (<= addSeconds sep1997 (8 * oneHour)) $ 236 | > starting sep1997 $ 237 | > recur hourly `by` 3 238 | 239 | Every 15 minutes for 6 occurrences: 240 | 241 | > take 6 $ starting sep1997 $ 242 | > recur minutely `by` 15 243 | 244 | Every hour and a half for 4 occurrences: 245 | 246 | > take 4 $ starting sep1997 $ recur minutely `by` 90 247 | 248 | Every 20 minutes from 9:00 AM to 4:40 PM every day: 249 | 250 | > staring sep1997 $ 251 | > recur daily $ 252 | > >==> enum (Hours [9 .. 16]) 253 | > >==> enum (Minutes [0,20,40]) 254 | 255 | or 256 | 257 | > starting sep1997 $ 258 | > recur minutely `by` 20 259 | > >==> enum (Hours [9 .. 16]) 260 | 261 | The following two examples will generate different results due to changes in the start of the week. 262 | 263 | > take 4 $ 264 | > recur weekly `by` 2 `withStartOfWeek` Monday 265 | > >==> enum (WeekDaysInWeek [Tuesday, Sunday]) 266 | 267 | vs 268 | 269 | > take 4 $ 270 | > recur weekly `by` 2 `withStartOfWeek` Sunday 271 | > >==> enum (WeekDaysInWeek [Tuesday, Sunday]) 272 | 273 | An example where an invalid date (Feb. 30) is ignored: 274 | 275 | > take 5 $ starting jan2000 $ 276 | > recur monthly 277 | > >==> enum (Days [15,30]) 278 | 279 | The 15th and the 30th of the month, forever: 280 | 281 | > starting sep1997 $ 282 | > recur monthly 283 | > >==> enum (Days [15,30]) 284 | 285 | The 15th and the 30th of the month, but only during the work week: 286 | 287 | > starting sep1997 $ 288 | > recur monthly 289 | > >==> enum (Days [15,30]) 290 | > >==> filter (WeekDays [Monday .. Friday]) 291 | -------------------------------------------------------------------------------- /src/Data/Time/Moment/FutureMoments.hs: -------------------------------------------------------------------------------- 1 | module Data.Time.Moment.FutureMoments 2 | ( 3 | FutureMoments -- abstract, instances: Eq, Ord, Show 4 | 5 | -- * Drive the Moment computation 6 | , iterateFutureMoments 7 | 8 | , enumMonths 9 | , enumWeeks 10 | , enumDays 11 | , enumWeekDaysInWeek 12 | , enumWeekDaysInMonth 13 | , enumYearDays 14 | , enumHours 15 | , enumMinutes 16 | , enumSeconds 17 | 18 | , nthMonth 19 | , nthDay 20 | , nthWeek 21 | , nthWeekDay 22 | , nthWeekDayOfWeek 23 | , nthWeekDayOfMonth 24 | , nthYearDay 25 | , nthHour 26 | , nthMinute 27 | , nthSecond 28 | 29 | , filterMonths 30 | , filterWeeks 31 | , filterDays 32 | , filterWeekDays 33 | , filterYearDays 34 | , filterHours 35 | , filterMinutes 36 | , filterSeconds 37 | 38 | ) 39 | where 40 | 41 | import Control.Monad.Reader 42 | import Data.Maybe (fromMaybe, mapMaybe) 43 | import Data.List 44 | import Data.List.Ordered as O 45 | import Data.Time.Calendar.Month 46 | import Data.Time.Calendar.WeekDay 47 | import Data.Time.CalendarTime hiding (withDay) 48 | import Data.Time.Moment.Moment 49 | 50 | type FutureMoments a = Reader (InitialMoment a) [a] 51 | 52 | iterateFutureMoments :: 53 | Moment a => 54 | InitialMoment a 55 | -> ([a] -> FutureMoments a) 56 | -> [a] 57 | iterateFutureMoments im sch = runReader (iterateInitialMoment >>= sch) im 58 | where 59 | iterateInitialMoment :: Moment a => FutureMoments a 60 | iterateInitialMoment = do 61 | im <- ask 62 | return $ iterate (next (interval im) (period im)) (moment im) 63 | 64 | -- | Normalize an bounded ordinal index between a lower and upper bound 65 | -- Negative indexes are allowed and index from the upper bound to the lower 66 | -- Any other value returns Nothing 67 | normalizeOrdinalIndex :: Int -> Int -> Int -> Maybe Int 68 | normalizeOrdinalIndex lb ub idx = 69 | if abx < lb || abx > ub 70 | then Nothing 71 | else Just $ (idx + ub') `mod` ub' 72 | where 73 | abx = abs idx 74 | ub' = ub + 1 75 | 76 | enumYearDays :: 77 | (CalendarTimeConvertible a, Moment a) => 78 | [Int] 79 | -> [a] 80 | -> FutureMoments a 81 | enumYearDays days as = return $ concatMap (enumYearDays' days) as 82 | where 83 | enumYearDays' days a = mapMaybe (withYearDay a) (days' a days) 84 | days' a = mapMaybe $ normalizeOrdinalIndex 1 (daysInYear a) 85 | 86 | enumMonths :: 87 | (CalendarTimeConvertible a, Moment a) => 88 | [Month] 89 | -> [a] 90 | -> FutureMoments a 91 | enumMonths months as = return $ concatMap (enumMonths' months) as 92 | where 93 | enumMonths' months a = mapMaybe (withMonth a) months 94 | 95 | enumWeeks :: 96 | (CalendarTimeConvertible a, Moment a) => 97 | [Int] 98 | -> [a] 99 | -> FutureMoments a 100 | enumWeeks weeks as = do 101 | sow <- asks startOfWeek 102 | return $ concatMap (enumWeeks' sow weeks) as 103 | where 104 | enumWeeks' sow weeks a = mapMaybe (withWeekNumber sow a) weeks 105 | 106 | enumDays :: 107 | (CalendarTimeConvertible a, Moment a) => 108 | [Int] 109 | -> [a] 110 | -> FutureMoments a 111 | enumDays days as = return $ concatMap (enumDays' days) as 112 | where 113 | enumDays' days a = mapMaybe (withDay a) (days' a days) 114 | days' a = mapMaybe $ normalizeOrdinalIndex 1 (lastDayOfMonth a) 115 | 116 | enumWeekDaysInWeek :: 117 | (CalendarTimeConvertible a, Moment a) => 118 | [WeekDay] 119 | -> [a] 120 | -> FutureMoments a 121 | enumWeekDaysInWeek wdays as = return $ concatMap (enumWeekDays' wdays) as 122 | where 123 | enumWeekDays' :: (CalendarTimeConvertible a, Moment a) => [WeekDay] -> a -> [a] 124 | enumWeekDays' wdays a0 = let 125 | w0 = calendarWeekDay $ toCalendarTime a0 126 | wdays' = dropWhile (/= w0) $ O.nubSort wdays 127 | in map (advanceToWeekDay a0) wdays' 128 | 129 | enumWeekDaysInMonth :: 130 | (CalendarTimeConvertible a, Moment a) => 131 | [WeekDay] 132 | -> [a] 133 | -> FutureMoments a 134 | enumWeekDaysInMonth wdays as = return $ concatMap (enumWeekDays' wdays) as 135 | where 136 | enumWeekDays' wdays a = let 137 | mdays = mapMaybe (withDay a) [1 .. lastDayOfMonth a] 138 | in filter (flip elem wdays . calendarWeekDay . toCalendarTime) mdays 139 | 140 | enumHours :: 141 | (CalendarTimeConvertible a, Moment a) => 142 | [Int] 143 | -> [a] 144 | -> FutureMoments a 145 | enumHours hours as = return $ concatMap (enumHours' hours) as 146 | where 147 | enumHours' hours a = mapMaybe (withHour a) (hours' a hours) 148 | hours' _ = mapMaybe $ normalizeOrdinalIndex 0 23 149 | 150 | enumMinutes :: 151 | (CalendarTimeConvertible a, Moment a) => 152 | [Int] 153 | -> [a] 154 | -> FutureMoments a 155 | enumMinutes ms as = return $ concatMap (enumMinutes' ms) as 156 | where 157 | enumMinutes' ms a = mapMaybe (withMinute a) (ms' a ms) 158 | ms' _ = mapMaybe $ normalizeOrdinalIndex 0 59 159 | 160 | enumSeconds :: 161 | (CalendarTimeConvertible a, Moment a) => 162 | [Int] 163 | -> [a] 164 | -> FutureMoments a 165 | enumSeconds secs as = return $ concatMap (enumSeconds' secs) as 166 | where 167 | enumSeconds' secs a = mapMaybe (withSecond a) (secs' a secs) 168 | secs' _ = mapMaybe $ normalizeOrdinalIndex 0 61 169 | 170 | groupWith :: (Ord b) => (a -> b) -> [a] -> [[a]] 171 | groupWith f = groupBy (\a b -> f a == f b) 172 | 173 | nth :: [Int] -> [a] -> [a] 174 | nth ns as = map ((as !!) . pred) $ mapMaybe (normalizeOrdinalIndex 0 (length as)) ns 175 | 176 | nth' :: 177 | (Ord b) => 178 | (a -> b) 179 | -> [Int] 180 | -> [a] 181 | -> FutureMoments a 182 | nth' f ns as = return $ concatMap (nth ns) $ groupWith f as 183 | 184 | nthYearDay :: 185 | CalendarTimeConvertible a => 186 | [Int] 187 | -> [a] 188 | -> FutureMoments a 189 | nthYearDay = nth' $ calendarYear . toCalendarTime 190 | 191 | nthMonth :: 192 | CalendarTimeConvertible a => 193 | [Int] 194 | -> [a] 195 | -> FutureMoments a 196 | nthMonth = nth' $ calendarYear . toCalendarTime 197 | 198 | nthDay :: 199 | CalendarTimeConvertible a => 200 | [Int] 201 | -> [a] 202 | -> FutureMoments a 203 | nthDay = nth' $ calendarMonth . toCalendarTime 204 | 205 | nthWeek :: 206 | CalendarTimeConvertible a => 207 | [Int] 208 | -> [a] 209 | -> FutureMoments a 210 | nthWeek ns as = do 211 | sow <- asks startOfWeek 212 | return $ 213 | concatMap (nth ns) $ 214 | groupWith (weekNumber sow . toCalendarTime) as 215 | 216 | nthWeekDayOfWeek :: 217 | CalendarTimeConvertible a => 218 | [Int] 219 | -> [a] 220 | -> FutureMoments a 221 | nthWeekDayOfWeek ns as = do 222 | sow <- asks startOfWeek 223 | return $ 224 | concatMap (nth ns) $ 225 | concatMap (groupWith (weekNumber sow)) $ 226 | groupWith (calendarMonth . toCalendarTime) as 227 | 228 | nthWeekDayOfMonth :: 229 | CalendarTimeConvertible a => 230 | [Int] 231 | -> [a] 232 | -> FutureMoments a 233 | nthWeekDayOfMonth = nth' $ calendarMonth . toCalendarTime 234 | 235 | nthWeekDay :: 236 | CalendarTimeConvertible a => 237 | [Int] 238 | -> [a] 239 | -> FutureMoments a 240 | nthWeekDay = nth' $ calendarYear . toCalendarTime 241 | 242 | nthHour :: 243 | CalendarTimeConvertible a => 244 | [Int] 245 | -> [a] 246 | -> FutureMoments a 247 | nthHour = nth' $ calendarDay . toCalendarTime 248 | 249 | nthMinute :: 250 | CalendarTimeConvertible a => 251 | [Int] 252 | -> [a] 253 | -> FutureMoments a 254 | nthMinute = nth' $ calendarHour . toCalendarTime 255 | 256 | nthSecond :: 257 | CalendarTimeConvertible a => 258 | [Int] 259 | -> [a] 260 | -> FutureMoments a 261 | nthSecond = nth' $ calendarMinute . toCalendarTime 262 | 263 | filterCalendarTime' :: 264 | (CalendarTimeConvertible a, Eq b) => 265 | (CalendarTime -> b) 266 | -> [b] 267 | -> [a] 268 | -> [a] 269 | filterCalendarTime' f xs as = filter (flip elem xs . f . toCalendarTime) as 270 | 271 | filterCalendarTime :: 272 | (CalendarTimeConvertible a, Eq b) => 273 | (CalendarTime -> b) 274 | -> [b] 275 | -> [a] 276 | -> FutureMoments a 277 | filterCalendarTime f xs as = return $ filterCalendarTime' f xs as 278 | 279 | filterMonths :: 280 | CalendarTimeConvertible a => 281 | [Month] 282 | -> [a] 283 | -> FutureMoments a 284 | filterMonths = filterCalendarTime calendarMonth 285 | 286 | filterYearDays :: 287 | CalendarTimeConvertible a => 288 | [Int] 289 | -> [a] 290 | -> FutureMoments a 291 | filterYearDays = filterCalendarTime calendarYearDay 292 | 293 | filterDays :: 294 | CalendarTimeConvertible a => 295 | [Int] 296 | -> [a] 297 | -> FutureMoments a 298 | filterDays = filterCalendarTime calendarDay 299 | 300 | filterWeeks :: 301 | CalendarTimeConvertible a => 302 | [Int] 303 | -> [a] 304 | -> FutureMoments a 305 | filterWeeks wks as = do 306 | sow <- asks startOfWeek 307 | return $ filterCalendarTime' (fromMaybe 0 . weekNumber sow) (filter (>0) wks) as 308 | 309 | filterWeekDays :: 310 | CalendarTimeConvertible a => 311 | [WeekDay] 312 | -> [a] 313 | -> FutureMoments a 314 | filterWeekDays = filterCalendarTime calendarWeekDay 315 | 316 | filterHours :: 317 | CalendarTimeConvertible a => 318 | [Int] 319 | -> [a] 320 | -> FutureMoments a 321 | filterHours = filterCalendarTime calendarHour 322 | 323 | filterMinutes :: 324 | CalendarTimeConvertible a => 325 | [Int] 326 | -> [a] 327 | -> FutureMoments a 328 | filterMinutes = filterCalendarTime calendarMinute 329 | 330 | filterSeconds :: 331 | CalendarTimeConvertible a => 332 | [Int] 333 | -> [a] 334 | -> FutureMoments a 335 | filterSeconds = filterCalendarTime calendarSecond 336 | --------------------------------------------------------------------------------