{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoMonoLocalBinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Hledger.Data.Dates (
fromEFDay,
modifyEFDay,
getCurrentDay,
getCurrentMonth,
getCurrentYear,
nulldate,
spanContainsDate,
periodContainsDate,
parsedateM,
showDate,
showEFDate,
showDateSpan,
showDateSpanDebug,
showDateSpanMonthAbbrev,
elapsedSeconds,
prevday,
periodexprp,
parsePeriodExpr,
parsePeriodExpr',
nulldatespan,
emptydatespan,
datesepchar,
datesepchars,
isDateSepChar,
spanStart,
spanEnd,
spanStartYear,
spanEndYear,
spanYears,
spansSpan,
spanIntersect,
spansIntersect,
spanDefaultsFrom,
spanUnion,
spansUnion,
daysSpan,
latestSpanContaining,
smartdate,
splitSpan,
spansFromBoundaries,
groupByDateSpan,
fixSmartDate,
fixSmartDateStr,
fixSmartDateStrEither,
fixSmartDateStrEither',
yearp,
daysInSpan,
tests_Dates
, intervalBoundaryBefore)
where
import Prelude hiding (Applicative(..))
import Control.Applicative (Applicative(..))
import Control.Applicative.Permutations
import Control.Monad (guard, unless)
import qualified Control.Monad.Fail as Fail (MonadFail, fail)
import Data.Char (digitToInt, isDigit, ord)
import Data.Default (def)
import Data.Foldable (asum)
import Data.Function (on)
import Data.Functor (($>))
import Data.List (elemIndex, group, sort, sortBy)
import Data.Maybe (catMaybes, fromMaybe, isJust, mapMaybe)
import Data.Ord (comparing)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Format hiding (months)
import Data.Time.Calendar
(Day, addDays, addGregorianYearsClip, addGregorianMonthsClip, diffDays,
fromGregorian, fromGregorianValid, toGregorian)
import Data.Time.Calendar.OrdinalDate (fromMondayStartWeek, mondayStartWeek)
import Data.Time.Clock (UTCTime, diffUTCTime)
import Data.Time.LocalTime (getZonedTime, localDay, zonedTimeToLocalTime)
import Safe (headMay, lastMay, maximumMay, minimumMay)
import Text.Megaparsec
import Text.Megaparsec.Char (char, char', digitChar, string, string')
import Text.Megaparsec.Char.Lexer (decimal, signed)
import Text.Printf (printf)
import Hledger.Data.Types
import Hledger.Data.Period
import Hledger.Utils
instance Show DateSpan where
show :: DateSpan -> [Char]
show DateSpan
s = [Char]
"DateSpan " forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack (DateSpan -> Text
showDateSpan DateSpan
s)
showDate :: Day -> Text
showDate :: Day -> Text
showDate = [Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show
showEFDate :: EFDay -> Text
showEFDate :: EFDay -> Text
showEFDate = Day -> Text
showDate forall b c a. (b -> c) -> (a -> b) -> a -> c
. EFDay -> Day
fromEFDay
showDateSpan :: DateSpan -> Text
showDateSpan :: DateSpan -> Text
showDateSpan = Period -> Text
showPeriod forall b c a. (b -> c) -> (a -> b) -> a -> c
. DateSpan -> Period
dateSpanAsPeriod
showDateSpanDebug :: DateSpan -> String
showDateSpanDebug :: DateSpan -> [Char]
showDateSpanDebug (DateSpan Maybe EFDay
b Maybe EFDay
e)= [Char]
"DateSpan (" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Maybe EFDay
b forall a. Semigroup a => a -> a -> a
<> [Char]
") (" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Maybe EFDay
e forall a. Semigroup a => a -> a -> a
<> [Char]
")"
showDateSpanMonthAbbrev :: DateSpan -> Text
showDateSpanMonthAbbrev :: DateSpan -> Text
showDateSpanMonthAbbrev = Period -> Text
showPeriodMonthAbbrev forall b c a. (b -> c) -> (a -> b) -> a -> c
. DateSpan -> Period
dateSpanAsPeriod
getCurrentDay :: IO Day
getCurrentDay :: IO Day
getCurrentDay = LocalTime -> Day
localDay forall b c a. (b -> c) -> (a -> b) -> a -> c
. ZonedTime -> LocalTime
zonedTimeToLocalTime forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ZonedTime
getZonedTime
getCurrentMonth :: IO Int
getCurrentMonth :: IO Int
getCurrentMonth = forall {a} {b} {c}. (a, b, c) -> b
second3 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> (Integer, Int, Int)
toGregorian forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Day
getCurrentDay
getCurrentYear :: IO Integer
getCurrentYear :: IO Integer
getCurrentYear = forall {a} {b} {c}. (a, b, c) -> a
first3 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> (Integer, Int, Int)
toGregorian forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Day
getCurrentDay
elapsedSeconds :: Fractional a => UTCTime -> UTCTime -> a
elapsedSeconds :: forall a. Fractional a => UTCTime -> UTCTime -> a
elapsedSeconds UTCTime
t1 = forall a b. (Real a, Fractional b) => a -> b
realToFrac forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
t1
spanStart :: DateSpan -> Maybe Day
spanStart :: DateSpan -> Maybe Day
spanStart (DateSpan Maybe EFDay
d Maybe EFDay
_) = EFDay -> Day
fromEFDay forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe EFDay
d
spanEnd :: DateSpan -> Maybe Day
spanEnd :: DateSpan -> Maybe Day
spanEnd (DateSpan Maybe EFDay
_ Maybe EFDay
d) = EFDay -> Day
fromEFDay forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe EFDay
d
spanStartDate :: DateSpan -> Maybe EFDay
spanStartDate :: DateSpan -> Maybe EFDay
spanStartDate (DateSpan Maybe EFDay
d Maybe EFDay
_) = Maybe EFDay
d
spanEndDate :: DateSpan -> Maybe EFDay
spanEndDate :: DateSpan -> Maybe EFDay
spanEndDate (DateSpan Maybe EFDay
_ Maybe EFDay
d) = Maybe EFDay
d
spanStartYear :: DateSpan -> Maybe Year
spanStartYear :: DateSpan -> Maybe Integer
spanStartYear (DateSpan Maybe EFDay
d Maybe EFDay
_) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall {a} {b} {c}. (a, b, c) -> a
first3 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> (Integer, Int, Int)
toGregorian forall b c a. (b -> c) -> (a -> b) -> a -> c
. EFDay -> Day
fromEFDay) Maybe EFDay
d
spanEndYear :: DateSpan -> Maybe Year
spanEndYear :: DateSpan -> Maybe Integer
spanEndYear (DateSpan Maybe EFDay
d Maybe EFDay
_) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall {a} {b} {c}. (a, b, c) -> a
first3 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> (Integer, Int, Int)
toGregorianforall b c a. (b -> c) -> (a -> b) -> a -> c
. EFDay -> Day
fromEFDay) Maybe EFDay
d
spanYears :: DateSpan -> [Year]
spanYears :: DateSpan -> [Integer]
spanYears (DateSpan Maybe EFDay
ma Maybe EFDay
mb) = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall {a} {b} {c}. (a, b, c) -> a
first3 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> (Integer, Int, Int)
toGregorianforall b c a. (b -> c) -> (a -> b) -> a -> c
. EFDay -> Day
fromEFDay)) [Maybe EFDay
ma,Maybe EFDay
mb]
spansSpan :: [DateSpan] -> DateSpan
spansSpan :: [DateSpan] -> DateSpan
spansSpan [DateSpan]
spans = Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (DateSpan -> Maybe EFDay
spanStartDate forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. [a] -> Maybe a
headMay [DateSpan]
spans) (DateSpan -> Maybe EFDay
spanEndDate forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. [a] -> Maybe a
lastMay [DateSpan]
spans)
splitSpan :: Bool -> Interval -> DateSpan -> [DateSpan]
splitSpan :: Bool -> Interval -> DateSpan -> [DateSpan]
splitSpan Bool
_ Interval
_ (DateSpan Maybe EFDay
Nothing Maybe EFDay
Nothing) = [Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan forall a. Maybe a
Nothing forall a. Maybe a
Nothing]
splitSpan Bool
_ Interval
_ DateSpan
ds | DateSpan -> Bool
isEmptySpan DateSpan
ds = []
splitSpan Bool
_ Interval
_ ds :: DateSpan
ds@(DateSpan (Just EFDay
s) (Just EFDay
e)) | EFDay
s forall a. Eq a => a -> a -> Bool
== EFDay
e = [DateSpan
ds]
splitSpan Bool
_ Interval
NoInterval DateSpan
ds = [DateSpan
ds]
splitSpan Bool
_ (Days Int
n) DateSpan
ds = (Day -> Day)
-> (Integer -> Day -> Day) -> Int -> DateSpan -> [DateSpan]
splitspan forall a. a -> a
id Integer -> Day -> Day
addDays Int
n DateSpan
ds
splitSpan Bool
adjust (Weeks Int
n) DateSpan
ds = (Day -> Day)
-> (Integer -> Day -> Day) -> Int -> DateSpan -> [DateSpan]
splitspan (if Bool
adjust then Day -> Day
startofweek else forall a. a -> a
id) Integer -> Day -> Day
addDays (Int
7forall a. Num a => a -> a -> a
*Int
n) DateSpan
ds
splitSpan Bool
adjust (Months Int
n) DateSpan
ds = (Day -> Day)
-> (Integer -> Day -> Day) -> Int -> DateSpan -> [DateSpan]
splitspan (if Bool
adjust then Day -> Day
startofmonth else forall a. a -> a
id) Integer -> Day -> Day
addGregorianMonthsClip Int
n DateSpan
ds
splitSpan Bool
adjust (Quarters Int
n) DateSpan
ds = (Day -> Day)
-> (Integer -> Day -> Day) -> Int -> DateSpan -> [DateSpan]
splitspan (if Bool
adjust then Day -> Day
startofquarter else forall a. a -> a
id) Integer -> Day -> Day
addGregorianMonthsClip (Int
3forall a. Num a => a -> a -> a
*Int
n) DateSpan
ds
splitSpan Bool
adjust (Years Int
n) DateSpan
ds = (Day -> Day)
-> (Integer -> Day -> Day) -> Int -> DateSpan -> [DateSpan]
splitspan (if Bool
adjust then Day -> Day
startofyear else forall a. a -> a
id) Integer -> Day -> Day
addGregorianYearsClip Int
n DateSpan
ds
splitSpan Bool
_ (DayOfMonth Int
n) DateSpan
ds = (Day -> Day)
-> (Integer -> Day -> Day) -> Int -> DateSpan -> [DateSpan]
splitspan (Int -> Day -> Day
nthdayofmonthcontaining Int
n) Integer -> Day -> Day
addGregorianMonthsClip Int
1 DateSpan
ds
splitSpan Bool
_ (DayOfYear Int
m Int
n) DateSpan
ds = (Day -> Day)
-> (Integer -> Day -> Day) -> Int -> DateSpan -> [DateSpan]
splitspan (Int -> Int -> Day -> Day
nthdayofyearcontaining Int
m Int
n) Integer -> Day -> Day
addGregorianYearsClip Int
1 DateSpan
ds
splitSpan Bool
_ (WeekdayOfMonth Int
n Int
wd) DateSpan
ds = (Day -> Day)
-> (Integer -> Day -> Day) -> Int -> DateSpan -> [DateSpan]
splitspan (Int -> Int -> Day -> Day
nthweekdayofmonthcontaining Int
n Int
wd) Integer -> Day -> Day
advancemonths Int
1 DateSpan
ds
where
advancemonths :: Integer -> Day -> Day
advancemonths Integer
0 = forall a. a -> a
id
advancemonths Integer
w = Int -> Int -> Day -> Day
advancetonthweekday Int
n Int
wd forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> Day
startofmonth forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Day -> Day
addGregorianMonthsClip Integer
w
splitSpan Bool
_ (DaysOfWeek []) DateSpan
ds = [DateSpan
ds]
splitSpan Bool
_ (DaysOfWeek days :: [Int]
days@(Int
n:[Int]
_)) DateSpan
ds = Day -> [Day] -> [DateSpan]
spansFromBoundaries Day
e [Day]
bdrys
where
(Day
s, Day
e) = (Day -> Day) -> (Day -> Day) -> DateSpan -> (Day, Day)
dateSpanSplitLimits (Int -> Day -> Day
nthdayofweekcontaining Int
n) Day -> Day
nextday DateSpan
ds
bdrys :: [Day]
bdrys = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map [Day]
starts forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Day -> Day
addDays) [Integer
0,Integer
7..]
starts :: [Day]
starts = forall a b. (a -> b) -> [a] -> [b]
map (\Int
d -> Integer -> Day -> Day
addDays (forall a. Integral a => a -> Integer
toInteger forall a b. (a -> b) -> a -> b
$ Int
d forall a. Num a => a -> a -> a
- Int
n) forall a b. (a -> b) -> a -> b
$ Int -> Day -> Day
nthdayofweekcontaining Int
n Day
s) [Int]
days
splitspan :: (Day -> Day) -> (Integer -> Day -> Day) -> Int -> DateSpan -> [DateSpan]
splitspan :: (Day -> Day)
-> (Integer -> Day -> Day) -> Int -> DateSpan -> [DateSpan]
splitspan Day -> Day
start Integer -> Day -> Day
addInterval Int
mult DateSpan
ds = Day -> [Day] -> [DateSpan]
spansFromBoundaries Day
e [Day]
bdrys
where
(Day
s, Day
e) = (Day -> Day) -> (Day -> Day) -> DateSpan -> (Day, Day)
dateSpanSplitLimits Day -> Day
start (Integer -> Day -> Day
addInterval (forall a. Integral a => a -> Integer
toInteger Int
mult)) DateSpan
ds
bdrys :: [Day]
bdrys = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Integer -> Day -> Day
addInterval forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Integral a => a -> Integer
toInteger) [Int
0,Int
mult..] forall a b. (a -> b) -> a -> b
$ Day -> Day
start Day
s
dateSpanSplitLimits :: (Day -> Day) -> (Day -> Day) -> DateSpan -> (Day, Day)
dateSpanSplitLimits :: (Day -> Day) -> (Day -> Day) -> DateSpan -> (Day, Day)
dateSpanSplitLimits Day -> Day
start Day -> Day
_ (DateSpan (Just EFDay
s) (Just EFDay
e)) = (Day -> Day
start forall a b. (a -> b) -> a -> b
$ EFDay -> Day
fromEFDay EFDay
s, EFDay -> Day
fromEFDay EFDay
e)
dateSpanSplitLimits Day -> Day
start Day -> Day
next (DateSpan (Just EFDay
s) Maybe EFDay
Nothing) = (Day -> Day
start forall a b. (a -> b) -> a -> b
$ EFDay -> Day
fromEFDay EFDay
s, Day -> Day
next forall a b. (a -> b) -> a -> b
$ Day -> Day
start forall a b. (a -> b) -> a -> b
$ EFDay -> Day
fromEFDay EFDay
s)
dateSpanSplitLimits Day -> Day
start Day -> Day
next (DateSpan Maybe EFDay
Nothing (Just EFDay
e)) = (Day -> Day
start forall a b. (a -> b) -> a -> b
$ EFDay -> Day
fromEFDay EFDay
e, Day -> Day
next forall a b. (a -> b) -> a -> b
$ Day -> Day
start forall a b. (a -> b) -> a -> b
$ EFDay -> Day
fromEFDay EFDay
e)
dateSpanSplitLimits Day -> Day
_ Day -> Day
_ (DateSpan Maybe EFDay
Nothing Maybe EFDay
Nothing) = forall a. HasCallStack => [Char] -> a
error [Char]
"dateSpanSplitLimits: should not be nulldatespan"
spansFromBoundaries :: Day -> [Day] -> [DateSpan]
spansFromBoundaries :: Day -> [Day] -> [DateSpan]
spansFromBoundaries Day
e [Day]
bdrys = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> EFDay
Exact)) (forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Ord a => a -> a -> Bool
< Day
e) [Day]
bdrys) forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop Int
1 [Day]
bdrys
daysInSpan :: DateSpan -> Maybe Integer
daysInSpan :: DateSpan -> Maybe Integer
daysInSpan (DateSpan (Just EFDay
d1) (Just EFDay
d2)) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Day -> Day -> Integer
diffDays (EFDay -> Day
fromEFDay EFDay
d2) (EFDay -> Day
fromEFDay EFDay
d1)
daysInSpan DateSpan
_ = forall a. Maybe a
Nothing
isEmptySpan :: DateSpan -> Bool
isEmptySpan :: DateSpan -> Bool
isEmptySpan (DateSpan (Just EFDay
s) (Just EFDay
e)) = EFDay
e forall a. Ord a => a -> a -> Bool
<= EFDay
s
isEmptySpan DateSpan
_ = Bool
False
spanContainsDate :: DateSpan -> Day -> Bool
spanContainsDate :: DateSpan -> Day -> Bool
spanContainsDate (DateSpan Maybe EFDay
Nothing Maybe EFDay
Nothing) Day
_ = Bool
True
spanContainsDate (DateSpan Maybe EFDay
Nothing (Just EFDay
e)) Day
d = Day
d forall a. Ord a => a -> a -> Bool
< EFDay -> Day
fromEFDay EFDay
e
spanContainsDate (DateSpan (Just EFDay
b) Maybe EFDay
Nothing) Day
d = Day
d forall a. Ord a => a -> a -> Bool
>= EFDay -> Day
fromEFDay EFDay
b
spanContainsDate (DateSpan (Just EFDay
b) (Just EFDay
e)) Day
d = Day
d forall a. Ord a => a -> a -> Bool
>= EFDay -> Day
fromEFDay EFDay
b Bool -> Bool -> Bool
&& Day
d forall a. Ord a => a -> a -> Bool
< EFDay -> Day
fromEFDay EFDay
e
periodContainsDate :: Period -> Day -> Bool
periodContainsDate :: Period -> Day -> Bool
periodContainsDate Period
p = DateSpan -> Day -> Bool
spanContainsDate (Period -> DateSpan
periodAsDateSpan Period
p)
groupByDateSpan :: Bool -> (a -> Day) -> [DateSpan] -> [a] -> [(DateSpan, [a])]
groupByDateSpan :: forall a.
Bool -> (a -> Day) -> [DateSpan] -> [a] -> [(DateSpan, [a])]
groupByDateSpan Bool
showempty a -> Day
date [DateSpan]
colspans =
[DateSpan] -> [(Day, a)] -> [(DateSpan, [a])]
groupByCols [DateSpan]
colspans
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Day -> Bool
beforeStart forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall a b. (a, b) -> a
fst)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\a
x -> (a -> Day
date a
x, a
x))
where
groupByCols :: [DateSpan] -> [(Day, a)] -> [(DateSpan, [a])]
groupByCols [] [(Day, a)]
_ = []
groupByCols (DateSpan
c:[DateSpan]
cs) [] = if Bool
showempty then (DateSpan
c, []) forall a. a -> [a] -> [a]
: [DateSpan] -> [(Day, a)] -> [(DateSpan, [a])]
groupByCols [DateSpan]
cs [] else []
groupByCols (DateSpan
c:[DateSpan]
cs) [(Day, a)]
ps = (DateSpan
c, forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Day, a)]
matches) forall a. a -> [a] -> [a]
: [DateSpan] -> [(Day, a)] -> [(DateSpan, [a])]
groupByCols [DateSpan]
cs [(Day, a)]
later
where ([(Day, a)]
matches, [(Day, a)]
later) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((DateSpan -> Maybe Day
spanEnd DateSpan
c forall a. Ord a => a -> a -> Bool
>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Day, a)]
ps
beforeStart :: Day -> Bool
beforeStart = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> b -> a
const Bool
True) forall a. Ord a => a -> a -> Bool
(>) forall a b. (a -> b) -> a -> b
$ DateSpan -> Maybe Day
spanStart forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. [a] -> Maybe a
headMay [DateSpan]
colspans
spansIntersect :: [DateSpan] -> DateSpan
spansIntersect [] = DateSpan
nulldatespan
spansIntersect [DateSpan
d] = DateSpan
d
spansIntersect (DateSpan
d:[DateSpan]
ds) = DateSpan
d DateSpan -> DateSpan -> DateSpan
`spanIntersect` ([DateSpan] -> DateSpan
spansIntersect [DateSpan]
ds)
spanIntersect :: DateSpan -> DateSpan -> DateSpan
spanIntersect (DateSpan Maybe EFDay
b1 Maybe EFDay
e1) (DateSpan Maybe EFDay
b2 Maybe EFDay
e2) = Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan Maybe EFDay
b Maybe EFDay
e
where
b :: Maybe EFDay
b = forall {a}. Ord a => Maybe a -> Maybe a -> Maybe a
latest Maybe EFDay
b1 Maybe EFDay
b2
e :: Maybe EFDay
e = forall {a}. Ord a => Maybe a -> Maybe a -> Maybe a
earliest Maybe EFDay
e1 Maybe EFDay
e2
spanDefaultsFrom :: DateSpan -> DateSpan -> DateSpan
spanDefaultsFrom (DateSpan Maybe EFDay
a1 Maybe EFDay
b1) (DateSpan Maybe EFDay
a2 Maybe EFDay
b2) = Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan Maybe EFDay
a Maybe EFDay
b
where a :: Maybe EFDay
a = if forall a. Maybe a -> Bool
isJust Maybe EFDay
a1 then Maybe EFDay
a1 else Maybe EFDay
a2
b :: Maybe EFDay
b = if forall a. Maybe a -> Bool
isJust Maybe EFDay
b1 then Maybe EFDay
b1 else Maybe EFDay
b2
spansUnion :: [DateSpan] -> DateSpan
spansUnion [] = DateSpan
nulldatespan
spansUnion [DateSpan
d] = DateSpan
d
spansUnion (DateSpan
d:[DateSpan]
ds) = DateSpan
d DateSpan -> DateSpan -> DateSpan
`spanUnion` ([DateSpan] -> DateSpan
spansUnion [DateSpan]
ds)
spanUnion :: DateSpan -> DateSpan -> DateSpan
spanUnion (DateSpan Maybe EFDay
b1 Maybe EFDay
e1) (DateSpan Maybe EFDay
b2 Maybe EFDay
e2) = Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan Maybe EFDay
b Maybe EFDay
e
where
b :: Maybe EFDay
b = forall {a}. Ord a => Maybe a -> Maybe a -> Maybe a
earliest Maybe EFDay
b1 Maybe EFDay
b2
e :: Maybe EFDay
e = forall {a}. Ord a => Maybe a -> Maybe a -> Maybe a
latest Maybe EFDay
e1 Maybe EFDay
e2
latest :: Maybe a -> Maybe a -> Maybe a
latest Maybe a
d Maybe a
Nothing = Maybe a
d
latest Maybe a
Nothing Maybe a
d = Maybe a
d
latest (Just a
d1) (Just a
d2) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a
max a
d1 a
d2
earliest :: Maybe a -> Maybe a -> Maybe a
earliest Maybe a
d Maybe a
Nothing = Maybe a
d
earliest Maybe a
Nothing Maybe a
d = Maybe a
d
earliest (Just a
d1) (Just a
d2) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a
min a
d1 a
d2
daysSpan :: [Day] -> DateSpan
daysSpan :: [Day] -> DateSpan
daysSpan [Day]
ds = Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (Day -> EFDay
Exact forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Ord a => [a] -> Maybe a
minimumMay [Day]
ds) (Day -> EFDay
Exact forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Day -> Day
addDays Integer
1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Ord a => [a] -> Maybe a
maximumMay [Day]
ds)
latestSpanContaining :: [DateSpan] -> Day -> Maybe DateSpan
latestSpanContaining :: [DateSpan] -> Day -> Maybe DateSpan
latestSpanContaining [DateSpan]
datespans = Day -> Maybe DateSpan
go
where
go :: Day -> Maybe DateSpan
go Day
day = do
DateSpan
spn <- forall a. Ord a => a -> Set a -> Maybe a
Set.lookupLT DateSpan
supSpan Set DateSpan
spanSet
forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ DateSpan -> Day -> Bool
spanContainsDate DateSpan
spn Day
day
forall (m :: * -> *) a. Monad m => a -> m a
return DateSpan
spn
where
supSpan :: DateSpan
supSpan = Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addDays Integer
1 Day
day) forall a. Maybe a
Nothing
spanSet :: Set DateSpan
spanSet = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. DateSpan -> Bool
isEmptySpan) [DateSpan]
datespans
parsePeriodExpr
:: Day -> Text -> Either HledgerParseErrors (Interval, DateSpan)
parsePeriodExpr :: Day -> Text -> Either HledgerParseErrors (Interval, DateSpan)
parsePeriodExpr Day
refdate Text
s = forall e a.
Parsec e Text a -> Text -> Either (ParseErrorBundle Text e) a
parsewith (forall (m :: * -> *). Day -> TextParser m (Interval, DateSpan)
periodexprp Day
refdate forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) (Text -> Text
T.toLower Text
s)
parsePeriodExpr' :: Day -> Text -> (Interval, DateSpan)
parsePeriodExpr' :: Day -> Text -> (Interval, DateSpan)
parsePeriodExpr' Day
refdate Text
s =
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. [Char] -> a
error' forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"failed to parse:" forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. HledgerParseErrors -> [Char]
customErrorBundlePretty) forall a. a -> a
id forall a b. (a -> b) -> a -> b
$
Day -> Text -> Either HledgerParseErrors (Interval, DateSpan)
parsePeriodExpr Day
refdate Text
s
spanFromSmartDate :: Day -> SmartDate -> DateSpan
spanFromSmartDate :: Day -> SmartDate -> DateSpan
spanFromSmartDate Day
refdate SmartDate
sdate = Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (forall a. a -> Maybe a
Just EFDay
b) (forall a. a -> Maybe a
Just EFDay
e)
where
(Integer
ry,Int
rm,Int
_) = Day -> (Integer, Int, Int)
toGregorian Day
refdate
(EFDay
b,EFDay
e) = SmartDate -> (EFDay, EFDay)
span' SmartDate
sdate
where
span' :: SmartDate -> (EFDay, EFDay)
span' :: SmartDate -> (EFDay, EFDay)
span' (SmartCompleteDate Day
day) = (Day -> EFDay
Exact Day
day, Day -> EFDay
Exact forall a b. (a -> b) -> a -> b
$ Day -> Day
nextday Day
day)
span' (SmartAssumeStart Integer
y Maybe Int
Nothing) = (Day -> EFDay
Flex forall a b. (a -> b) -> a -> b
$ Day -> Day
startofyear Day
day, Day -> EFDay
Flex forall a b. (a -> b) -> a -> b
$ Day -> Day
nextyear Day
day) where day :: Day
day = Integer -> Int -> Int -> Day
fromGregorian Integer
y Int
1 Int
1
span' (SmartAssumeStart Integer
y (Just Int
m)) = (Day -> EFDay
Flex forall a b. (a -> b) -> a -> b
$ Day -> Day
startofmonth Day
day, Day -> EFDay
Flex forall a b. (a -> b) -> a -> b
$ Day -> Day
nextmonth Day
day) where day :: Day
day = Integer -> Int -> Int -> Day
fromGregorian Integer
y Int
m Int
1
span' (SmartFromReference Maybe Int
m Int
d) = (Day -> EFDay
Exact Day
day, Day -> EFDay
Exact forall a b. (a -> b) -> a -> b
$ Day -> Day
nextday Day
day) where day :: Day
day = Integer -> Int -> Int -> Day
fromGregorian Integer
ry (forall a. a -> Maybe a -> a
fromMaybe Int
rm Maybe Int
m) Int
d
span' (SmartMonth Int
m) = (Day -> EFDay
Flex forall a b. (a -> b) -> a -> b
$ Day -> Day
startofmonth Day
day, Day -> EFDay
Flex forall a b. (a -> b) -> a -> b
$ Day -> Day
nextmonth Day
day) where day :: Day
day = Integer -> Int -> Int -> Day
fromGregorian Integer
ry Int
m Int
1
span' (SmartRelative Integer
n SmartInterval
Day) = (Day -> EFDay
Exact forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addDays Integer
n Day
refdate, Day -> EFDay
Exact forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addDays (Integer
nforall a. Num a => a -> a -> a
+Integer
1) Day
refdate)
span' (SmartRelative Integer
n SmartInterval
Week) = (Day -> EFDay
Flex forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addDays (Integer
7forall a. Num a => a -> a -> a
*Integer
n) Day
d, Day -> EFDay
Flex forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addDays (Integer
7forall a. Num a => a -> a -> a
*Integer
nforall a. Num a => a -> a -> a
+Integer
7) Day
d) where d :: Day
d = Day -> Day
thisweek Day
refdate
span' (SmartRelative Integer
n SmartInterval
Month) = (Day -> EFDay
Flex forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addGregorianMonthsClip Integer
n Day
d, Day -> EFDay
Flex forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addGregorianMonthsClip (Integer
nforall a. Num a => a -> a -> a
+Integer
1) Day
d) where d :: Day
d = Day -> Day
thismonth Day
refdate
span' (SmartRelative Integer
n SmartInterval
Quarter) = (Day -> EFDay
Flex forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addGregorianMonthsClip (Integer
3forall a. Num a => a -> a -> a
*Integer
n) Day
d, Day -> EFDay
Flex forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addGregorianMonthsClip (Integer
3forall a. Num a => a -> a -> a
*Integer
nforall a. Num a => a -> a -> a
+Integer
3) Day
d) where d :: Day
d = Day -> Day
thisquarter Day
refdate
span' (SmartRelative Integer
n SmartInterval
Year) = (Day -> EFDay
Flex forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addGregorianYearsClip Integer
n Day
d, Day -> EFDay
Flex forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addGregorianYearsClip (Integer
nforall a. Num a => a -> a -> a
+Integer
1) Day
d) where d :: Day
d = Day -> Day
thisyear Day
refdate
fixSmartDateStr :: Day -> Text -> Text
fixSmartDateStr :: Day -> Text -> Text
fixSmartDateStr Day
d Text
s =
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. [Char] -> a
error' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. PrintfType r => [Char] -> r
printf [Char]
"could not parse date %s %s" (forall a. Show a => a -> [Char]
show Text
s) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show) forall a. a -> a
id forall a b. (a -> b) -> a -> b
$
(Day -> Text -> Either HledgerParseErrors Text
fixSmartDateStrEither Day
d Text
s :: Either HledgerParseErrors Text)
fixSmartDateStrEither :: Day -> Text -> Either HledgerParseErrors Text
fixSmartDateStrEither :: Day -> Text -> Either HledgerParseErrors Text
fixSmartDateStrEither Day
d = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap EFDay -> Text
showEFDate forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> Text -> Either HledgerParseErrors EFDay
fixSmartDateStrEither' Day
d
fixSmartDateStrEither'
:: Day -> Text -> Either HledgerParseErrors EFDay
fixSmartDateStrEither' :: Day -> Text -> Either HledgerParseErrors EFDay
fixSmartDateStrEither' Day
d Text
s = case forall e a.
Parsec e Text a -> Text -> Either (ParseErrorBundle Text e) a
parsewith forall (m :: * -> *). TextParser m SmartDate
smartdateonly (Text -> Text
T.toLower Text
s) of
Right SmartDate
sd -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Day -> SmartDate -> EFDay
fixSmartDate Day
d SmartDate
sd
Left HledgerParseErrors
e -> forall a b. a -> Either a b
Left HledgerParseErrors
e
fixSmartDate :: Day -> SmartDate -> EFDay
fixSmartDate :: Day -> SmartDate -> EFDay
fixSmartDate Day
refdate = SmartDate -> EFDay
fix
where
fix :: SmartDate -> EFDay
fix :: SmartDate -> EFDay
fix (SmartCompleteDate Day
d) = Day -> EFDay
Exact Day
d
fix (SmartAssumeStart Integer
y Maybe Int
m) = Day -> EFDay
Flex forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
y (forall a. a -> Maybe a -> a
fromMaybe Int
1 Maybe Int
m) Int
1
fix (SmartFromReference Maybe Int
m Int
d) = Day -> EFDay
Exact forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
ry (forall a. a -> Maybe a -> a
fromMaybe Int
rm Maybe Int
m) Int
d
fix (SmartMonth Int
m) = Day -> EFDay
Flex forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
ry Int
m Int
1
fix (SmartRelative Integer
n SmartInterval
Day) = Day -> EFDay
Exact forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addDays Integer
n Day
refdate
fix (SmartRelative Integer
n SmartInterval
Week) = Day -> EFDay
Flex forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addDays (Integer
7forall a. Num a => a -> a -> a
*Integer
n) forall a b. (a -> b) -> a -> b
$ Day -> Day
thisweek Day
refdate
fix (SmartRelative Integer
n SmartInterval
Month) = Day -> EFDay
Flex forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addGregorianMonthsClip Integer
n forall a b. (a -> b) -> a -> b
$ Day -> Day
thismonth Day
refdate
fix (SmartRelative Integer
n SmartInterval
Quarter) = Day -> EFDay
Flex forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addGregorianMonthsClip (Integer
3forall a. Num a => a -> a -> a
*Integer
n) forall a b. (a -> b) -> a -> b
$ Day -> Day
thisquarter Day
refdate
fix (SmartRelative Integer
n SmartInterval
Year) = Day -> EFDay
Flex forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addGregorianYearsClip Integer
n forall a b. (a -> b) -> a -> b
$ Day -> Day
thisyear Day
refdate
(Integer
ry, Int
rm, Int
_) = Day -> (Integer, Int, Int)
toGregorian Day
refdate
prevday :: Day -> Day
prevday :: Day -> Day
prevday = Integer -> Day -> Day
addDays (-Integer
1)
nextday :: Day -> Day
nextday = Integer -> Day -> Day
addDays Integer
1
thisweek :: Day -> Day
thisweek = Day -> Day
startofweek
prevweek :: Day -> Day
prevweek = Day -> Day
startofweek forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Day -> Day
addDays (-Integer
7)
nextweek :: Day -> Day
nextweek = Day -> Day
startofweek forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Day -> Day
addDays Integer
7
startofweek :: Day -> Day
startofweek Day
day = Integer -> Int -> Int -> Day
fromMondayStartWeek Integer
y Int
w Int
1
where
(Integer
y,Int
_,Int
_) = Day -> (Integer, Int, Int)
toGregorian Day
day
(Int
w,Int
_) = Day -> (Int, Int)
mondayStartWeek Day
day
thismonth :: Day -> Day
thismonth = Day -> Day
startofmonth
prevmonth :: Day -> Day
prevmonth = Day -> Day
startofmonth forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Day -> Day
addGregorianMonthsClip (-Integer
1)
nextmonth :: Day -> Day
nextmonth = Day -> Day
startofmonth forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Day -> Day
addGregorianMonthsClip Integer
1
startofmonth :: Day -> Day
startofmonth Day
day = Integer -> Int -> Int -> Day
fromGregorian Integer
y Int
m Int
1 where (Integer
y,Int
m,Int
_) = Day -> (Integer, Int, Int)
toGregorian Day
day
nthdayofmonth :: Int -> Day -> Day
nthdayofmonth Int
d Day
day = Integer -> Int -> Int -> Day
fromGregorian Integer
y Int
m Int
d where (Integer
y,Int
m,Int
_) = Day -> (Integer, Int, Int)
toGregorian Day
day
thisquarter :: Day -> Day
thisquarter = Day -> Day
startofquarter
startofquarter :: Day -> Day
startofquarter Day
day = Integer -> Int -> Int -> Day
fromGregorian Integer
y (forall {a}. Integral a => a -> a
firstmonthofquarter Int
m) Int
1
where
(Integer
y,Int
m,Int
_) = Day -> (Integer, Int, Int)
toGregorian Day
day
firstmonthofquarter :: a -> a
firstmonthofquarter a
m2 = ((a
m2forall a. Num a => a -> a -> a
-a
1) forall a. Integral a => a -> a -> a
`div` a
3) forall a. Num a => a -> a -> a
* a
3 forall a. Num a => a -> a -> a
+ a
1
thisyear :: Day -> Day
thisyear = Day -> Day
startofyear
prevyear :: Day -> Day
prevyear = Day -> Day
startofyear forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Day -> Day
addGregorianYearsClip (-Integer
1)
nextyear :: Day -> Day
nextyear = Day -> Day
startofyear forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Day -> Day
addGregorianYearsClip Integer
1
startofyear :: Day -> Day
startofyear Day
day = Integer -> Int -> Int -> Day
fromGregorian Integer
y Int
1 Int
1 where (Integer
y,Int
_,Int
_) = Day -> (Integer, Int, Int)
toGregorian Day
day
intervalBoundaryBefore :: Interval -> Day -> Day
intervalBoundaryBefore :: Interval -> Day -> Day
intervalBoundaryBefore Interval
i Day
d =
case Bool -> Interval -> DateSpan -> [DateSpan]
splitSpan Bool
True Interval
i (Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact Day
d) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addDays Integer
1 Day
d)) of
(DateSpan (Just EFDay
start) Maybe EFDay
_:[DateSpan]
_) -> EFDay -> Day
fromEFDay EFDay
start
[DateSpan]
_ -> Day
d
nthdayofyearcontaining :: Month -> MonthDay -> Day -> Day
nthdayofyearcontaining :: Int -> Int -> Day -> Day
nthdayofyearcontaining Int
m Int
mdy Day
date
| Bool -> Bool
not (Int -> Bool
validMonth Int
m) = forall a. [Char] -> a
error' forall a b. (a -> b) -> a -> b
$ [Char]
"nthdayofyearcontaining: invalid month "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> [Char]
show Int
m
| Bool -> Bool
not (Int -> Bool
validDay Int
mdy) = forall a. [Char] -> a
error' forall a b. (a -> b) -> a -> b
$ [Char]
"nthdayofyearcontaining: invalid day " forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> [Char]
show Int
mdy
| Day
mmddOfSameYear forall a. Ord a => a -> a -> Bool
<= Day
date = Day
mmddOfSameYear
| Bool
otherwise = Day
mmddOfPrevYear
where mmddOfSameYear :: Day
mmddOfSameYear = Integer -> Day -> Day
addDays (forall a. Integral a => a -> Integer
toInteger Int
mdyforall a. Num a => a -> a -> a
-Integer
1) forall a b. (a -> b) -> a -> b
$ forall a. Int -> (a -> a) -> a -> a
applyN (Int
mforall a. Num a => a -> a -> a
-Int
1) Day -> Day
nextmonth Day
s
mmddOfPrevYear :: Day
mmddOfPrevYear = Integer -> Day -> Day
addDays (forall a. Integral a => a -> Integer
toInteger Int
mdyforall a. Num a => a -> a -> a
-Integer
1) forall a b. (a -> b) -> a -> b
$ forall a. Int -> (a -> a) -> a -> a
applyN (Int
mforall a. Num a => a -> a -> a
-Int
1) Day -> Day
nextmonth forall a b. (a -> b) -> a -> b
$ Day -> Day
prevyear Day
s
s :: Day
s = Day -> Day
startofyear Day
date
nthdayofmonthcontaining :: MonthDay -> Day -> Day
nthdayofmonthcontaining :: Int -> Day -> Day
nthdayofmonthcontaining Int
mdy Day
date
| Bool -> Bool
not (Int -> Bool
validDay Int
mdy) = forall a. [Char] -> a
error' forall a b. (a -> b) -> a -> b
$ [Char]
"nthdayofmonthcontaining: invalid day " forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> [Char]
show Int
mdy
| Day
nthOfSameMonth forall a. Ord a => a -> a -> Bool
<= Day
date = Day
nthOfSameMonth
| Bool
otherwise = Day
nthOfPrevMonth
where nthOfSameMonth :: Day
nthOfSameMonth = Int -> Day -> Day
nthdayofmonth Int
mdy Day
s
nthOfPrevMonth :: Day
nthOfPrevMonth = Int -> Day -> Day
nthdayofmonth Int
mdy forall a b. (a -> b) -> a -> b
$ Day -> Day
prevmonth Day
s
s :: Day
s = Day -> Day
startofmonth Day
date
nthdayofweekcontaining :: WeekDay -> Day -> Day
nthdayofweekcontaining :: Int -> Day -> Day
nthdayofweekcontaining Int
n Day
d | Day
nthOfSameWeek forall a. Ord a => a -> a -> Bool
<= Day
d = Day
nthOfSameWeek
| Bool
otherwise = Day
nthOfPrevWeek
where nthOfSameWeek :: Day
nthOfSameWeek = Integer -> Day -> Day
addDays (forall a. Integral a => a -> Integer
toInteger Int
nforall a. Num a => a -> a -> a
-Integer
1) Day
s
nthOfPrevWeek :: Day
nthOfPrevWeek = Integer -> Day -> Day
addDays (forall a. Integral a => a -> Integer
toInteger Int
nforall a. Num a => a -> a -> a
-Integer
1) forall a b. (a -> b) -> a -> b
$ Day -> Day
prevweek Day
s
s :: Day
s = Day -> Day
startofweek Day
d
nthweekdayofmonthcontaining :: Int -> WeekDay -> Day -> Day
nthweekdayofmonthcontaining :: Int -> Int -> Day -> Day
nthweekdayofmonthcontaining Int
n Int
wd Day
d | Day
nthWeekdaySameMonth forall a. Ord a => a -> a -> Bool
<= Day
d = Day
nthWeekdaySameMonth
| Bool
otherwise = Day
nthWeekdayPrevMonth
where nthWeekdaySameMonth :: Day
nthWeekdaySameMonth = Int -> Int -> Day -> Day
advancetonthweekday Int
n Int
wd forall a b. (a -> b) -> a -> b
$ Day -> Day
startofmonth Day
d
nthWeekdayPrevMonth :: Day
nthWeekdayPrevMonth = Int -> Int -> Day -> Day
advancetonthweekday Int
n Int
wd forall a b. (a -> b) -> a -> b
$ Day -> Day
prevmonth Day
d
advancetonthweekday :: Int -> WeekDay -> Day -> Day
advancetonthweekday :: Int -> Int -> Day -> Day
advancetonthweekday Int
n Int
wd Day
s =
forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall {a}. a
err (forall {a}. Integral a => a -> Day -> Day
addWeeks (Int
nforall a. Num a => a -> a -> a
-Int
1)) forall a b. (a -> b) -> a -> b
$ forall {a}. (a -> Bool) -> [a] -> Maybe a
firstMatch (forall a. Ord a => a -> a -> Bool
>=Day
s) forall a b. (a -> b) -> a -> b
$ forall a. (a -> a) -> a -> [a]
iterate (forall {a}. Integral a => a -> Day -> Day
addWeeks Integer
1) forall a b. (a -> b) -> a -> b
$ Day -> Day
firstweekday Day
s
where
err :: a
err = forall a. [Char] -> a
error' [Char]
"advancetonthweekday: should not happen"
addWeeks :: a -> Day -> Day
addWeeks a
k = Integer -> Day -> Day
addDays (Integer
7 forall a. Num a => a -> a -> a
* forall a. Integral a => a -> Integer
toInteger a
k)
firstMatch :: (a -> Bool) -> [a] -> Maybe a
firstMatch a -> Bool
p = forall a. [a] -> Maybe a
headMay forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Bool
p)
firstweekday :: Day -> Day
firstweekday = Integer -> Day -> Day
addDays (forall a. Integral a => a -> Integer
toInteger Int
wdforall a. Num a => a -> a -> a
-Integer
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> Day
startofweek
parsedateM :: String -> Maybe Day
parsedateM :: [Char] -> Maybe Day
parsedateM [Char]
s = forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum [
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> [Char] -> [Char] -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale [Char]
"%Y-%m-%d" [Char]
s,
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> [Char] -> [Char] -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale [Char]
"%Y/%m/%d" [Char]
s,
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> [Char] -> [Char] -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale [Char]
"%Y.%m.%d" [Char]
s
]
smartdate :: TextParser m SmartDate
smartdate :: forall (m :: * -> *). TextParser m SmartDate
smartdate = forall (m :: * -> *) a. [TextParser m a] -> TextParser m a
choice'
[ TextParser m SmartDate
relativeP
, forall (m :: * -> *). TextParser m SmartDate
yyyymmdd, forall (m :: * -> *). TextParser m SmartDate
ymd
, (\(Int
m,Int
d) -> Maybe Int -> Int -> SmartDate
SmartFromReference (forall a. a -> Maybe a
Just Int
m) Int
d) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). TextParser m (Int, Int)
md
, forall (m :: * -> *). MonadFail m => SmartDate -> m SmartDate
failIfInvalidDate forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Int -> Int -> SmartDate
SmartFromReference forall a. Maybe a
Nothing forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal
, Int -> SmartDate
SmartMonth forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (m :: * -> *). TextParser m Int
month forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *). TextParser m Int
mon)
, Integer -> SmartInterval -> SmartDate
SmartRelative Integer
0 SmartInterval
Day forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"today"
, Integer -> SmartInterval -> SmartDate
SmartRelative (-Integer
1) SmartInterval
Day forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"yesterday"
, Integer -> SmartInterval -> SmartDate
SmartRelative Integer
1 SmartInterval
Day forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"tomorrow"
]
where
relativeP :: TextParser m SmartDate
relativeP = do
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"in" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces
Integer
num <- forall {m :: * -> *}. ParsecT HledgerParseErrorData Text m Integer
seqP forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces
SmartInterval
interval <- ParsecT HledgerParseErrorData Text m SmartInterval
intervalP forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces
Integer -> Integer
sign <- forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
choice [forall a. Num a => a -> a
negate forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"ago", forall a. a -> a
id forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"ahead", forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. a -> a
id]
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Integer -> SmartInterval -> SmartDate
SmartRelative (Integer -> Integer
sign Integer
num) SmartInterval
interval
seqP :: ParsecT HledgerParseErrorData Text m Integer
seqP = forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
choice [ Integer
0 forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"this", -Integer
1 forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"last", Integer
1 forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"next", forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m () -> m a -> m a
signed forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal ]
intervalP :: ParsecT HledgerParseErrorData Text m SmartInterval
intervalP = forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
choice [ SmartInterval
Day forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"day", SmartInterval
Week forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"week", SmartInterval
Month forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"month"
, SmartInterval
Quarter forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"quarter", SmartInterval
Year forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"year" ] forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char' Char
's')
smartdateonly :: TextParser m SmartDate
smartdateonly :: forall (m :: * -> *). TextParser m SmartDate
smartdateonly = forall (m :: * -> *). TextParser m SmartDate
smartdate forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *). MonadParsec e s m => m ()
eof
datesepchars :: String
datesepchars :: [Char]
datesepchars = [Char]
"/-."
datesepchar :: TextParser m Char
datesepchar :: forall (m :: * -> *). TextParser m Char
datesepchar = forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
isDateSepChar
isDateSepChar :: Char -> Bool
isDateSepChar :: Char -> Bool
isDateSepChar Char
c = Char
c forall a. Eq a => a -> a -> Bool
== Char
'-' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'/' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'.'
validMonth, validDay :: Int -> Bool
validMonth :: Int -> Bool
validMonth Int
n = Int
n forall a. Ord a => a -> a -> Bool
>= Int
1 Bool -> Bool -> Bool
&& Int
n forall a. Ord a => a -> a -> Bool
<= Int
12
validDay :: Int -> Bool
validDay Int
n = Int
n forall a. Ord a => a -> a -> Bool
>= Int
1 Bool -> Bool -> Bool
&& Int
n forall a. Ord a => a -> a -> Bool
<= Int
31
failIfInvalidDate :: Fail.MonadFail m => SmartDate -> m SmartDate
failIfInvalidDate :: forall (m :: * -> *). MonadFail m => SmartDate -> m SmartDate
failIfInvalidDate SmartDate
s = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isValid (forall (m :: * -> *) a. MonadFail m => [Char] -> m a
Fail.fail forall a b. (a -> b) -> a -> b
$ [Char]
"bad smart date: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show SmartDate
s) forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> SmartDate
s
where isValid :: Bool
isValid = case SmartDate
s of
SmartAssumeStart Integer
_ (Just Int
m) -> Int -> Bool
validMonth Int
m
SmartFromReference Maybe Int
mm Int
d -> forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Maybe Day
fromGregorianValid Integer
2004 (forall a. a -> Maybe a -> a
fromMaybe Int
1 Maybe Int
mm) Int
d
SmartMonth Int
m -> Int -> Bool
validMonth Int
m
SmartDate
_ -> Bool
True
showBadDate :: Integer -> Int -> Int -> String
showBadDate :: Integer -> Int -> Int -> [Char]
showBadDate Integer
y Int
m Int
d = [Char]
"bad smart date: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Integer
y forall a. [a] -> [a] -> [a]
++ [Char]
"-" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
m forall a. [a] -> [a] -> [a]
++ [Char]
"-" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
d
yyyymmdd :: TextParser m SmartDate
yyyymmdd :: forall (m :: * -> *). TextParser m SmartDate
yyyymmdd = do
Integer
y <- forall a. Read a => [Char] -> a
read forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count Int
4 forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar
Int
m <- forall a. Read a => [Char] -> a
read forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count Int
2 forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar
Maybe Int
mdy <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a b. (a -> b) -> a -> b
$ forall a. Read a => [Char] -> a
read forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count Int
2 forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar
case Maybe Int
mdy of
Maybe Int
Nothing -> forall (m :: * -> *). MonadFail m => SmartDate -> m SmartDate
failIfInvalidDate forall a b. (a -> b) -> a -> b
$ Integer -> Maybe Int -> SmartDate
SmartAssumeStart Integer
y (forall a. a -> Maybe a
Just Int
m)
Just Int
d -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadFail m => [Char] -> m a
Fail.fail forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> [Char]
showBadDate Integer
y Int
m Int
d) (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> SmartDate
SmartCompleteDate) forall a b. (a -> b) -> a -> b
$
Integer -> Int -> Int -> Maybe Day
fromGregorianValid Integer
y Int
m Int
d
ymd :: TextParser m SmartDate
ymd :: forall (m :: * -> *). TextParser m SmartDate
ymd = do
Integer
y <- forall {m :: * -> *}. ParsecT HledgerParseErrorData Text m Integer
yearp
Maybe (Either Int Day)
emd <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ do
Char
sep <- forall (m :: * -> *). TextParser m Char
datesepchar
Int
m <- forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int -> Bool
validMonth Int
m) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => [Char] -> m a
Fail.fail ([Char]
"Bad month " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Int
m)
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option (forall a b. a -> Either a b
Left Int
m) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
Token Text
_ <- forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
sep
Int
d <- forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadFail m => [Char] -> m a
Fail.fail forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> [Char]
showBadDate Integer
y Int
m Int
d) forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Maybe Day
fromGregorianValid Integer
y Int
m Int
d
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Maybe (Either Int Day)
emd of
Maybe (Either Int Day)
Nothing -> Integer -> Maybe Int -> SmartDate
SmartAssumeStart Integer
y forall a. Maybe a
Nothing
Just (Left Int
m) -> Integer -> Maybe Int -> SmartDate
SmartAssumeStart Integer
y (forall a. a -> Maybe a
Just Int
m)
Just (Right Day
day) -> Day -> SmartDate
SmartCompleteDate Day
day
md :: TextParser m (Month, MonthDay)
md :: forall (m :: * -> *). TextParser m (Int, Int)
md = do
Int
m <- forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal
forall (m :: * -> *). TextParser m Char
datesepchar
Int
d <- forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal
SmartDate
_ <- forall (m :: * -> *). MonadFail m => SmartDate -> m SmartDate
failIfInvalidDate forall a b. (a -> b) -> a -> b
$ Maybe Int -> Int -> SmartDate
SmartFromReference (forall a. a -> Maybe a
Just Int
m) Int
d
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
m, Int
d)
yearp :: TextParser m Integer
yearp :: forall {m :: * -> *}. ParsecT HledgerParseErrorData Text m Integer
yearp = do
Text
year <- forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe [Char] -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P (forall a. a -> Maybe a
Just [Char]
"year") Char -> Bool
isDigit
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Int
T.length Text
year forall a. Ord a => a -> a -> Bool
>= Int
4) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadFail m => [Char] -> m a
Fail.fail forall a b. (a -> b) -> a -> b
$ [Char]
"Year must contain at least 4 digits: " forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
year
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> Integer
readDecimal Text
year
months :: [Tokens Text]
months = [Tokens Text
"january",Tokens Text
"february",Tokens Text
"march",Tokens Text
"april",Tokens Text
"may",Tokens Text
"june",
Tokens Text
"july",Tokens Text
"august",Tokens Text
"september",Tokens Text
"october",Tokens Text
"november",Tokens Text
"december"]
monthabbrevs :: [Tokens Text]
monthabbrevs = [Tokens Text
"jan",Tokens Text
"feb",Tokens Text
"mar",Tokens Text
"apr",Tokens Text
"may",Tokens Text
"jun",Tokens Text
"jul",Tokens Text
"aug",Tokens Text
"sep",Tokens Text
"oct",Tokens Text
"nov",Tokens Text
"dec"]
weekdays :: [Tokens Text]
weekdays = [Tokens Text
"monday",Tokens Text
"tuesday",Tokens Text
"wednesday",Tokens Text
"thursday",Tokens Text
"friday",Tokens Text
"saturday",Tokens Text
"sunday"]
weekdayabbrevs :: [Tokens Text]
weekdayabbrevs = [Tokens Text
"mon",Tokens Text
"tue",Tokens Text
"wed",Tokens Text
"thu",Tokens Text
"fri",Tokens Text
"sat",Tokens Text
"sun"]
month, mon :: TextParser m Month
month :: forall (m :: * -> *). TextParser m Int
month = forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
choice forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
i Tokens Text
m -> Int
i forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
m) [Int
1..Int
12] [Tokens Text]
months
mon :: forall (m :: * -> *). TextParser m Int
mon = forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
choice forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
i Tokens Text
m -> Int
i forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
m) [Int
1..Int
12] [Tokens Text]
monthabbrevs
weekday :: TextParser m Int
weekday :: forall (m :: * -> *). TextParser m Int
weekday = do
Text
wday <- Text -> Text
T.toLower forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
choice forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' forall a b. (a -> b) -> a -> b
$ [Tokens Text]
weekdays forall a. [a] -> [a] -> [a]
++ [Tokens Text]
weekdayabbrevs)
case forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ [Text
wday forall a. Eq a => a -> [a] -> Maybe Int
`elemIndex` [Tokens Text]
weekdays, Text
wday forall a. Eq a => a -> [a] -> Maybe Int
`elemIndex` [Tokens Text]
weekdayabbrevs] of
(Int
i:[Int]
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return (Int
iforall a. Num a => a -> a -> a
+Int
1)
[] -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
Fail.fail forall a b. (a -> b) -> a -> b
$ [Char]
"weekday: should not happen: attempted to find " forall a. Semigroup a => a -> a -> a
<>
forall a. Show a => a -> [Char]
show Text
wday forall a. Semigroup a => a -> a -> a
<> [Char]
" in " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show ([Tokens Text]
weekdays forall a. [a] -> [a] -> [a]
++ [Tokens Text]
weekdayabbrevs)
weekdaysp :: TextParser m [Int]
weekdaysp :: forall (m :: * -> *). TextParser m [Int]
weekdaysp = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [[a]]
group forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> [a]
sort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
sepBy1 forall (m :: * -> *). TextParser m Int
weekday (forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
",")
periodexprp :: Day -> TextParser m (Interval, DateSpan)
periodexprp :: forall (m :: * -> *). Day -> TextParser m (Interval, DateSpan)
periodexprp Day
rdate = do
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces
forall (m :: * -> *) a. [TextParser m a] -> TextParser m a
choice' [ forall (m :: * -> *). Day -> TextParser m (Interval, DateSpan)
intervalanddateperiodexprp Day
rdate
, (,) Interval
NoInterval forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Day -> TextParser m DateSpan
periodexprdatespanp Day
rdate
]
intervalanddateperiodexprp :: Day -> TextParser m (Interval, DateSpan)
intervalanddateperiodexprp :: forall (m :: * -> *). Day -> TextParser m (Interval, DateSpan)
intervalanddateperiodexprp Day
rdate = do
Interval
i <- forall (m :: * -> *). TextParser m Interval
reportingintervalp
DateSpan
s <- forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option forall a. Default a => a
def forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ do
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces
forall (m :: * -> *). Day -> TextParser m DateSpan
periodexprdatespanp Day
rdate
forall (m :: * -> *) a. Monad m => a -> m a
return (Interval
i,DateSpan
s)
reportingintervalp :: TextParser m Interval
reportingintervalp :: forall (m :: * -> *). TextParser m Interval
reportingintervalp = forall (m :: * -> *) a. [TextParser m a] -> TextParser m a
choice'
[ forall (m :: * -> *).
Text -> Text -> (Int -> Interval) -> TextParser m Interval
tryinterval Text
"day" Text
"daily" Int -> Interval
Days
, forall (m :: * -> *).
Text -> Text -> (Int -> Interval) -> TextParser m Interval
tryinterval Text
"month" Text
"monthly" Int -> Interval
Months
, forall (m :: * -> *).
Text -> Text -> (Int -> Interval) -> TextParser m Interval
tryinterval Text
"quarter" Text
"quarterly" Int -> Interval
Quarters
, forall (m :: * -> *).
Text -> Text -> (Int -> Interval) -> TextParser m Interval
tryinterval Text
"year" Text
"yearly" Int -> Interval
Years
, Int -> Interval
Weeks Int
2 forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"biweekly"
, Int -> Interval
Weeks Int
2 forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"fortnightly"
, Int -> Interval
Months Int
2 forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"bimonthly"
, forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"every" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. [TextParser m a] -> TextParser m a
choice'
[ [Int] -> Interval
DaysOfWeek forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT HledgerParseErrorData Text m Int
nth forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"day" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall {s} {m :: * -> *}.
(Token s ~ Char, Stream s, FoldCase (Tokens s),
IsString (Tokens s)) =>
Tokens s -> ParsecT HledgerParseErrorData s m (Tokens s)
of_ Text
"week")
, Int -> Interval
DayOfMonth forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT HledgerParseErrorData Text m Int
nth forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"day" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall {s} {m :: * -> *}.
(Token s ~ Char, Stream s, FoldCase (Tokens s),
IsString (Tokens s)) =>
Tokens s -> ParsecT HledgerParseErrorData s m (Maybe (Tokens s))
optOf_ Text
"month")
, forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Int -> Int -> Interval
WeekdayOfMonth ParsecT HledgerParseErrorData Text m Int
nth forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *). TextParser m Int
weekday forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall {s} {m :: * -> *}.
(Token s ~ Char, Stream s, FoldCase (Tokens s),
IsString (Tokens s)) =>
Tokens s -> ParsecT HledgerParseErrorData s m (Maybe (Tokens s))
optOf_ Text
"month"
, forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Int -> Interval
DayOfYear forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (m :: * -> *). TextParser m (Int, Int)
md forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall {s} {m :: * -> *}.
(Token s ~ Char, Stream s, FoldCase (Tokens s),
IsString (Tokens s)) =>
Tokens s -> ParsecT HledgerParseErrorData s m (Maybe (Tokens s))
optOf_ Text
"year")
, [Int] -> Interval
DaysOfWeek forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). TextParser m [Int]
weekdaysp
, [Int] -> Interval
DaysOfWeek [Int
1..Int
5] forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"weekday"
, [Int] -> Interval
DaysOfWeek [Int
6..Int
7] forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"weekendday"
, TextParser m Interval
d_o_y forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall {s} {m :: * -> *}.
(Token s ~ Char, Stream s, FoldCase (Tokens s),
IsString (Tokens s)) =>
Tokens s -> ParsecT HledgerParseErrorData s m (Maybe (Tokens s))
optOf_ Text
"year"
]
, forall (m :: * -> *).
Text -> Text -> (Int -> Interval) -> TextParser m Interval
tryinterval Text
"week" Text
"weekly" Int -> Interval
Weeks
]
where
of_ :: Tokens s -> ParsecT HledgerParseErrorData s m (Tokens s)
of_ Tokens s
period =
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens s
"of" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens s
period
optOf_ :: Tokens s -> ParsecT HledgerParseErrorData s m (Maybe (Tokens s))
optOf_ Tokens s
period = forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ forall {s} {m :: * -> *}.
(Token s ~ Char, Stream s, FoldCase (Tokens s),
IsString (Tokens s)) =>
Tokens s -> ParsecT HledgerParseErrorData s m (Tokens s)
of_ Tokens s
period
nth :: ParsecT HledgerParseErrorData Text m Int
nth = forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
choice (forall a b. (a -> b) -> [a] -> [b]
map forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' [Tokens Text
"st",Tokens Text
"nd",Tokens Text
"rd",Tokens Text
"th"])
d_o_y :: TextParser m Interval
d_o_y = forall (m :: * -> *) a. Alternative m => Permutation m a -> m a
runPermutation forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Int -> Int -> Interval
DayOfYear (forall (m :: * -> *) a. Alternative m => m a -> Permutation m a
toPermutation forall a b. (a -> b) -> a -> b
$ (forall (m :: * -> *). TextParser m Int
month forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *). TextParser m Int
mon) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces)
(forall (m :: * -> *) a. Alternative m => m a -> Permutation m a
toPermutation forall a b. (a -> b) -> a -> b
$ ParsecT HledgerParseErrorData Text m Int
nth forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces)
tryinterval :: Text -> Text -> (Int -> Interval) -> TextParser m Interval
tryinterval :: forall (m :: * -> *).
Text -> Text -> (Int -> Interval) -> TextParser m Interval
tryinterval Text
singular Text
compact Int -> Interval
intcons = Int -> Interval
intcons forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. [TextParser m a] -> TextParser m a
choice'
[ Int
1 forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Text
compact
, forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"every" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
choice
[ Int
1 forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Text
singular
, forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' (Text
singular forall a. Semigroup a => a -> a -> a
<> Text
"s")
]
]
periodexprdatespanp :: Day -> TextParser m DateSpan
periodexprdatespanp :: forall (m :: * -> *). Day -> TextParser m DateSpan
periodexprdatespanp Day
rdate = forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
choice forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try [
forall (m :: * -> *). Day -> TextParser m DateSpan
doubledatespanp Day
rdate,
forall (m :: * -> *). Day -> TextParser m DateSpan
quarterdatespanp Day
rdate,
forall (m :: * -> *). Day -> TextParser m DateSpan
fromdatespanp Day
rdate,
forall (m :: * -> *). Day -> TextParser m DateSpan
todatespanp Day
rdate,
forall (m :: * -> *). Day -> TextParser m DateSpan
justdatespanp Day
rdate
]
doubledatespanp :: Day -> TextParser m DateSpan
doubledatespanp :: forall (m :: * -> *). Day -> TextParser m DateSpan
doubledatespanp Day
rdate = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 SmartDate -> SmartDate -> DateSpan
fromToSpan
(forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ((forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"from" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"since") forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *). TextParser m SmartDate
smartdate)
(forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
choice [forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"to", forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"..", forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"-"]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *). TextParser m SmartDate
smartdate)
where
fromToSpan :: SmartDate -> SmartDate -> DateSpan
fromToSpan = Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> SmartDate -> EFDay
fixSmartDate Day
rdate)
quarterdatespanp :: Day -> TextParser m DateSpan
quarterdatespanp :: forall (m :: * -> *). Day -> TextParser m DateSpan
quarterdatespanp Day
rdate = do
Integer
y <- forall {m :: * -> *}. ParsecT HledgerParseErrorData Text m Integer
yearp forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall {a} {b} {c}. (a, b, c) -> a
first3 forall a b. (a -> b) -> a -> b
$ Day -> (Integer, Int, Int)
toGregorian Day
rdate)
Char
q <- forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char' Char
'q' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
is4Digit
forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Period -> DateSpan
periodAsDateSpan forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Period
QuarterPeriod Integer
y (Char -> Int
digitToInt Char
q)
where
is4Digit :: Char -> Bool
is4Digit Char
c = (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'1') :: Word) forall a. Ord a => a -> a -> Bool
<= Word
3
fromdatespanp :: Day -> TextParser m DateSpan
fromdatespanp :: forall (m :: * -> *). Day -> TextParser m DateSpan
fromdatespanp Day
rdate = SmartDate -> DateSpan
fromSpan forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
choice
[ (forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"from" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"since") forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *). TextParser m SmartDate
smartdate
, forall (m :: * -> *). TextParser m SmartDate
smartdate forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
choice [forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"..", forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"-"]
]
where
fromSpan :: SmartDate -> DateSpan
fromSpan SmartDate
b = Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Day -> SmartDate -> EFDay
fixSmartDate Day
rdate SmartDate
b) forall a. Maybe a
Nothing
todatespanp :: Day -> TextParser m DateSpan
todatespanp :: forall (m :: * -> *). Day -> TextParser m DateSpan
todatespanp Day
rdate =
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
choice [forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"to", forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"until", forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"..", forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"-"]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan forall a. Maybe a
Nothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> SmartDate -> EFDay
fixSmartDate Day
rdate forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). TextParser m SmartDate
smartdate)
justdatespanp :: Day -> TextParser m DateSpan
justdatespanp :: forall (m :: * -> *). Day -> TextParser m DateSpan
justdatespanp Day
rdate =
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"in" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Day -> SmartDate -> DateSpan
spanFromSmartDate Day
rdate forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). TextParser m SmartDate
smartdate)
nulldatespan :: DateSpan
nulldatespan :: DateSpan
nulldatespan = Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan forall a. Maybe a
Nothing forall a. Maybe a
Nothing
emptydatespan :: DateSpan
emptydatespan :: DateSpan
emptydatespan = Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addDays Integer
1 Day
nulldate) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact Day
nulldate)
nulldate :: Day
nulldate :: Day
nulldate = Integer -> Int -> Int -> Day
fromGregorian Integer
0 Int
1 Int
1
tests_Dates :: TestTree
tests_Dates = [Char] -> [TestTree] -> TestTree
testGroup [Char]
"Dates"
[ [Char] -> Assertion -> TestTree
testCase [Char]
"weekday" forall a b. (a -> b) -> a -> b
$ do
Bool -> Interval -> DateSpan -> [DateSpan]
splitSpan Bool
False ([Int] -> Interval
DaysOfWeek [Int
1..Int
5]) (Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
01) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
08))
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= [ (Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
06 Int
28) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
06 Int
29))
, (Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
06 Int
29) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
06 Int
30))
, (Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
06 Int
30) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
01))
, (Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
01) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
02))
, (Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
02) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
05))
, (Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
05) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
06))
, (Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
06) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
07))
, (Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
07) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
08))
]
Bool -> Interval -> DateSpan -> [DateSpan]
splitSpan Bool
False ([Int] -> Interval
DaysOfWeek [Int
1, Int
5]) (Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
01) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
08))
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= [ (Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
06 Int
28) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
02))
, (Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
02) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
05))
, (Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
05) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
09))
]
, [Char] -> Assertion -> TestTree
testCase [Char]
"match dayOfWeek" forall a b. (a -> b) -> a -> b
$ do
let dayofweek :: Int -> DateSpan -> [DateSpan]
dayofweek Int
n = (Day -> Day)
-> (Integer -> Day -> Day) -> Int -> DateSpan -> [DateSpan]
splitspan (Int -> Day -> Day
nthdayofweekcontaining Int
n) (\Integer
w -> (if Integer
w forall a. Eq a => a -> a -> Bool
== Integer
0 then forall a. a -> a
id else forall a. Int -> (a -> a) -> a -> a
applyN (Int
nforall a. Num a => a -> a -> a
-Int
1) Day -> Day
nextday forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> (a -> a) -> a -> a
applyN (forall a. Num a => Integer -> a
fromInteger Integer
w) Day -> Day
nextweek)) Int
1
matchdow :: DateSpan -> Int -> Assertion
matchdow DateSpan
ds Int
day = Bool -> Interval -> DateSpan -> [DateSpan]
splitSpan Bool
False ([Int] -> Interval
DaysOfWeek [Int
day]) DateSpan
ds forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Int -> DateSpan -> [DateSpan]
dayofweek Int
day DateSpan
ds
ys2021 :: Day
ys2021 = Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
01 Int
01
ye2021 :: Day
ye2021 = Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
12 Int
31
ys2022 :: Day
ys2022 = Integer -> Int -> Int -> Day
fromGregorian Integer
2022 Int
01 Int
01
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DateSpan -> Int -> Assertion
matchdow (Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact Day
ys2021) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact Day
ye2021))) [Int
1..Int
7]
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DateSpan -> Int -> Assertion
matchdow (Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact Day
ys2021) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact Day
ys2022))) [Int
1..Int
7]
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DateSpan -> Int -> Assertion
matchdow (Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact Day
ye2021) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact Day
ys2022))) [Int
1..Int
7]
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DateSpan -> Int -> Assertion
matchdow (Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact Day
ye2021) forall a. Maybe a
Nothing)) [Int
1..Int
7]
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DateSpan -> Int -> Assertion
matchdow (Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact Day
ys2022) forall a. Maybe a
Nothing)) [Int
1..Int
7]
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DateSpan -> Int -> Assertion
matchdow (Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact Day
ye2021))) [Int
1..Int
7]
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DateSpan -> Int -> Assertion
matchdow (Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact Day
ys2022))) [Int
1..Int
7]
]