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