module Data.Time.Patterns(
DatePattern,
day,
mondayWeek,
sundayWeek,
month,
year,
january,
february,
march,
april,
may,
june,
july,
august,
september,
october,
november,
december,
monday,
tuesday,
wednesday,
thursday,
friday,
saturday,
sunday,
never,
every,
shiftBy,
inEach,
take,
skip,
except,
intersect,
union,
until,
elementOf,
instancesFrom,
intervalsFrom
) where
import Data.Time.Calendar (Day, addDays, fromGregorian,
toGregorian)
import Data.Time.Calendar.OrdinalDate (mondayStartWeek,
sundayStartWeek)
import qualified Data.Time.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, until)
type DatePattern = IntervalSequence' Day
month :: DatePattern
month = IntervalSequence $ \t ->
let m = firstOfMonth t in
let m' = addMonths 1 m in
Just (m ... m', month) where
january :: DatePattern
january = monthOfYear 1
february :: DatePattern
february = monthOfYear 2
march :: DatePattern
march = monthOfYear 3
april :: DatePattern
april = monthOfYear 4
may :: DatePattern
may = monthOfYear 5
june :: DatePattern
june = monthOfYear 6
july :: DatePattern
july = monthOfYear 7
august :: DatePattern
august = monthOfYear 8
september :: DatePattern
september = monthOfYear 9
october :: DatePattern
october = monthOfYear 10
november :: DatePattern
november = monthOfYear 11
december :: DatePattern
december = monthOfYear 12
day :: DatePattern
day = IntervalSequence{..} where
nextInterval t = Just (t ... (succ t), day)
monday :: DatePattern
monday = filter (isDayOfWeek 1) day
tuesday :: DatePattern
tuesday = filter (isDayOfWeek 2) day
wednesday :: DatePattern
wednesday = filter (isDayOfWeek 3) day
thursday :: DatePattern
thursday = filter (isDayOfWeek 4) day
friday :: DatePattern
friday = filter (isDayOfWeek 5) day
saturday :: DatePattern
saturday = filter (isDayOfWeek 6) day
sunday :: DatePattern
sunday = filter (isDayOfWeek 7) day
mondayWeek :: DatePattern
mondayWeek = IntervalSequence $ \d -> let m = lastMonday d in
Just (m ... addDays 7 m, mondayWeek)
sundayWeek :: DatePattern
sundayWeek = IntervalSequence $ \d -> let m = lastSunday d in
Just (m ... addDays 7 m, sundayWeek)
year :: DatePattern
year = IntervalSequence $ \d -> let m = jan1 d in
Just (m ... addYears 1 m, year)
inEach :: DatePattern -> DatePattern -> DatePattern
inEach i o = IntervalSequence (inEach' o i i)
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)
shiftBy :: Integer -> DatePattern -> DatePattern
shiftBy n = mapSequence (addDays n)
every :: (Num i, Ord i) => i -> DatePattern -> DatePattern
every = I.every
take :: (Num i, Ord i) => i -> DatePattern -> DatePattern
take = I.take
skip :: (Num i, Ord i) => i -> DatePattern -> DatePattern
skip = I.skip
except :: Day -> DatePattern -> DatePattern
except = I.except
elementOf :: Day -> DatePattern -> Bool
elementOf = I.elementOf
instancesFrom :: Day -> DatePattern -> [Day]
instancesFrom = I.elementsFrom
never :: DatePattern
never = I.never
intersect :: DatePattern -> DatePattern -> DatePattern
intersect = I.intersect
union :: DatePattern -> DatePattern -> DatePattern
union = I.union
intervalsFrom :: Day -> DatePattern -> [Interval Day]
intervalsFrom = I.occurrencesFrom
isDayOfWeek :: Int -> Interval Day -> Bool
isDayOfWeek d i = case (elements i) of
[dt] -> let (_, dayOfWeek) = mondayStartWeek dt in dayOfWeek == d
_ -> False
lastMonday :: Day -> Day
lastMonday d = let (_, dayOfWeek) = mondayStartWeek d in
case dayOfWeek of
1 -> d
_ -> lastMonday $ pred d
lastSunday :: Day -> Day
lastSunday d = let (_, dayOfWeek) = sundayStartWeek d in
case dayOfWeek of
1 -> d
_ -> lastSunday $ pred d
jan1 :: Day -> Day
jan1 d = let (year, _, _) = toGregorian d in
fromGregorian year 1 1
addYears :: Integer -> Day -> Day
addYears n d = let (year, month, day) = toGregorian d in
fromGregorian (year + n) month day
addMonths :: Int -> Day -> Day
addMonths m d =
let (year, month, day) = toGregorian d in
let (years,months) = (month + m) `divMod` 12 in
fromGregorian (year + fromIntegral years) (months) day
firstOfMonth :: Day -> Day
firstOfMonth d =
let (year, month, _) = toGregorian d in
fromGregorian year month 1
get1stOfMonth :: Int -> Day -> Day
get1stOfMonth i d =
let (year, month, day) = toGregorian d in
let y = abs $ (i month) `div` 12 in
fromGregorian (year + fromIntegral y) i 1
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)
until :: DatePattern -> Day -> DatePattern
until = flip I.stopAt'