{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE NoMonoLocalBinds    #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies        #-}
{-|

Date parsing and utilities for hledger.

For date and time values, we use the standard Day and UTCTime types.

A 'SmartDate' is a date which may be partially-specified or relative.
Eg 2008\/12\/31, but also 2008\/12, 12\/31, tomorrow, last week, next year,
in 5 days, in -3 quarters.
We represent these as a triple of strings like (\"2008\",\"12\",\"\"),
(\"\",\"\",\"tomorrow\"), (\"\",\"last\",\"week\").

A 'DateSpan' is the span of time between two specific calendar dates, or
an open-ended span where one or both dates are unspecified. (A date span
with both ends unspecified matches all dates.)

An 'Interval' is ledger's \"reporting interval\" - weekly, monthly,
quarterly, etc.

'Period' will probably replace DateSpan in due course.

-}

-- XXX fromGregorian silently clips bad dates, use fromGregorianValid instead ?

module Hledger.Data.Dates (
  -- * Misc date handling utilities
  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
, intervalStartBefore)
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.Printf (printf)

import Hledger.Data.Types
import Hledger.Data.Period
import Hledger.Utils


-- Help ppShow parse and line-wrap DateSpans better in debug output.
instance Show DateSpan where
    show :: DateSpan -> [Char]
show DateSpan
s = [Char]
"DateSpan " forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack (DateSpan -> Text
showDateSpan DateSpan
s)

showDate :: Day -> Text
showDate :: Day -> Text
showDate = [Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show

-- | Render a datespan as a display string, abbreviating into a
-- compact form if possible.
showDateSpan :: DateSpan -> Text
showDateSpan :: DateSpan -> Text
showDateSpan = Period -> Text
showPeriod forall b c a. (b -> c) -> (a -> b) -> a -> c
. DateSpan -> Period
dateSpanAsPeriod

-- | Like showDateSpan, but show month spans as just the abbreviated month name
-- in the current locale.
showDateSpanMonthAbbrev :: DateSpan -> Text
showDateSpanMonthAbbrev :: DateSpan -> Text
showDateSpanMonthAbbrev = Period -> Text
showPeriodMonthAbbrev forall b c a. (b -> c) -> (a -> b) -> a -> c
. DateSpan -> Period
dateSpanAsPeriod

-- | Get the current local date.
getCurrentDay :: IO Day
getCurrentDay :: IO Day
getCurrentDay = LocalTime -> Day
localDay forall b c a. (b -> c) -> (a -> b) -> a -> c
. ZonedTime -> LocalTime
zonedTimeToLocalTime forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ZonedTime
getZonedTime

-- | Get the current local month number.
getCurrentMonth :: IO Int
getCurrentMonth :: IO Int
getCurrentMonth = forall {a} {b} {c}. (a, b, c) -> b
second3 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> (Integer, Int, Int)
toGregorian forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Day
getCurrentDay

-- | Get the current local year.
getCurrentYear :: IO Integer
getCurrentYear :: IO Integer
getCurrentYear = forall {a} {b} {c}. (a, b, c) -> a
first3 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> (Integer, Int, Int)
toGregorian forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Day
getCurrentDay

elapsedSeconds :: Fractional a => UTCTime -> UTCTime -> a
elapsedSeconds :: forall a. Fractional a => UTCTime -> UTCTime -> a
elapsedSeconds UTCTime
t1 = forall a b. (Real a, Fractional b) => a -> b
realToFrac forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
t1

spanStart :: DateSpan -> Maybe Day
spanStart :: DateSpan -> Maybe Day
spanStart (DateSpan Maybe 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
_) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall {a} {b} {c}. (a, b, c) -> a
first3 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> (Integer, Int, Int)
toGregorian) Maybe Day
d

spanEndYear :: DateSpan -> Maybe Year
spanEndYear :: DateSpan -> Maybe Integer
spanEndYear (DateSpan Maybe Day
d Maybe Day
_) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall {a} {b} {c}. (a, b, c) -> a
first3 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> (Integer, Int, Int)
toGregorian) Maybe Day
d

-- | Get the 0-2 years mentioned explicitly in a DateSpan.
spanYears :: DateSpan -> [Year]
spanYears :: DateSpan -> [Integer]
spanYears (DateSpan Maybe Day
ma Maybe Day
mb) = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall {a} {b} {c}. (a, b, c) -> a
first3 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> (Integer, Int, Int)
toGregorian)) [Maybe Day
ma,Maybe Day
mb]

-- might be useful later: http://en.wikipedia.org/wiki/Allen%27s_interval_algebra

-- | Get overall span enclosing multiple sequentially ordered spans.
spansSpan :: [DateSpan] -> DateSpan
spansSpan :: [DateSpan] -> DateSpan
spansSpan [DateSpan]
spans = Maybe Day -> Maybe Day -> DateSpan
DateSpan (DateSpan -> Maybe Day
spanStart forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. [a] -> Maybe a
headMay [DateSpan]
spans) (DateSpan -> Maybe Day
spanEnd forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. [a] -> Maybe a
lastMay [DateSpan]
spans)

-- | Split a DateSpan into consecutive whole spans of the specified interval
-- which fully encompass the original span (and a little more when necessary).
-- If no interval is specified, the original span is returned.
-- If the original span is the null date span, ie unbounded, the null date span is returned.
-- If the original span is empty, eg if the end date is <= the start date, no spans are returned.
--
--
-- ==== Examples:
-- >>> let t i y1 m1 d1 y2 m2 d2 = splitSpan i $ DateSpan (Just $ fromGregorian y1 m1 d1) (Just $ fromGregorian y2 m2 d2)
-- >>> t NoInterval 2008 01 01 2009 01 01
-- [DateSpan 2008]
-- >>> t (Quarters 1) 2008 01 01 2009 01 01
-- [DateSpan 2008Q1,DateSpan 2008Q2,DateSpan 2008Q3,DateSpan 2008Q4]
-- >>> splitSpan (Quarters 1) nulldatespan
-- [DateSpan ..]
-- >>> t (Days 1) 2008 01 01 2008 01 01  -- an empty datespan
-- []
-- >>> t (Quarters 1) 2008 01 01 2008 01 01
-- []
-- >>> t (Months 1) 2008 01 01 2008 04 01
-- [DateSpan 2008-01,DateSpan 2008-02,DateSpan 2008-03]
-- >>> t (Months 2) 2008 01 01 2008 04 01
-- [DateSpan 2008-01-01..2008-02-29,DateSpan 2008-03-01..2008-04-30]
-- >>> t (Weeks 1) 2008 01 01 2008 01 15
-- [DateSpan 2007-12-31W01,DateSpan 2008-01-07W02,DateSpan 2008-01-14W03]
-- >>> t (Weeks 2) 2008 01 01 2008 01 15
-- [DateSpan 2007-12-31..2008-01-13,DateSpan 2008-01-14..2008-01-27]
-- >>> t (DayOfMonth 2) 2008 01 01 2008 04 01
-- [DateSpan 2007-12-02..2008-01-01,DateSpan 2008-01-02..2008-02-01,DateSpan 2008-02-02..2008-03-01,DateSpan 2008-03-02..2008-04-01]
-- >>> t (WeekdayOfMonth 2 4) 2011 01 01 2011 02 15
-- [DateSpan 2010-12-09..2011-01-12,DateSpan 2011-01-13..2011-02-09,DateSpan 2011-02-10..2011-03-09]
-- >>> t (DaysOfWeek [2]) 2011 01 01 2011 01 15
-- [DateSpan 2010-12-28..2011-01-03,DateSpan 2011-01-04..2011-01-10,DateSpan 2011-01-11..2011-01-17]
-- >>> t (DayOfYear 11 29) 2011 10 01 2011 10 15
-- [DateSpan 2010-11-29..2011-11-28]
-- >>> t (DayOfYear 11 29) 2011 12 01 2012 12 15
-- [DateSpan 2011-11-29..2012-11-28,DateSpan 2012-11-29..2013-11-28]
--
splitSpan :: Interval -> DateSpan -> [DateSpan]
splitSpan :: Interval -> DateSpan -> [DateSpan]
splitSpan Interval
_ (DateSpan Maybe Day
Nothing Maybe Day
Nothing) = [Maybe Day -> Maybe Day -> DateSpan
DateSpan forall a. Maybe a
Nothing 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 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 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
7forall 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
3forall 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 = forall {a}. a -> a
id
    advancemonths Integer
w = Int -> Int -> Day -> Day
advancetonthweekday Int
n Int
wd forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> Day
startofmonth forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Day -> Day
addGregorianMonthsClip Integer
w
splitSpan (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 = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map [Day]
starts forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Day -> Day
addDays) [Integer
0,Integer
7..]
    -- The first representative of each weekday
    starts :: [Day]
starts = forall a b. (a -> b) -> [a] -> [b]
map (\Int
d -> Integer -> Day -> Day
addDays (forall a. Integral a => a -> Integer
toInteger forall a b. (a -> b) -> a -> b
$ Int
d forall a. Num a => a -> a -> a
- Int
n) forall a b. (a -> b) -> a -> b
$ Int -> Day -> Day
nthdayofweekcontaining Int
n Day
s) [Int]
days

-- Split the given span using the provided helper functions:
-- start is applied to the span's start date to get the first sub-span's start date
-- addInterval is applied to an integer n (multiplying it by mult) and the span's start date to get the nth sub-span's start date
splitspan :: (Day -> Day) -> (Integer -> Day -> Day) -> Int -> DateSpan -> [DateSpan]
splitspan :: (Day -> Day)
-> (Integer -> Day -> Day) -> Int -> DateSpan -> [DateSpan]
splitspan Day -> Day
start Integer -> Day -> Day
addInterval Int
mult DateSpan
ds = Day -> [Day] -> [DateSpan]
spansFromBoundaries Day
e [Day]
bdrys
  where
    (Day
s, Day
e) = (Day -> Day) -> (Day -> Day) -> DateSpan -> (Day, Day)
dateSpanSplitLimits Day -> Day
start (Integer -> Day -> Day
addInterval forall a b. (a -> b) -> a -> b
$ forall a. Integral a => a -> Integer
toInteger Int
mult) DateSpan
ds
    bdrys :: [Day]
bdrys = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Integer -> Day -> Day
addInterval forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Integral a => a -> Integer
toInteger) [Int
0,Int
mult..] forall a b. (a -> b) -> a -> b
$ Day -> Day
start Day
s

-- | Fill in missing endpoints for calculating 'splitSpan'.
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 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 forall a b. (a -> b) -> a -> b
$ Day -> Day
start Day
e)
dateSpanSplitLimits Day -> Day
_     Day -> Day
_    (DateSpan Maybe Day
Nothing   Maybe Day
Nothing) = forall a. HasCallStack => [Char] -> a
error [Char]
"dateSpanSplitLimits: Should not be nulldatespan"  -- PARTIAL: This case should have been handled in splitSpan

-- | Construct a list of 'DateSpan's from a list of boundaries, which fit within a given range.
spansFromBoundaries :: Day -> [Day] -> [DateSpan]
spansFromBoundaries :: Day -> [Day] -> [DateSpan]
spansFromBoundaries Day
e [Day]
bdrys = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Maybe Day -> Maybe Day -> DateSpan
DateSpan forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a. a -> Maybe a
Just) (forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Ord a => a -> a -> Bool
< Day
e) [Day]
bdrys) forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop Int
1 [Day]
bdrys

-- | Count the days in a DateSpan, or if it is open-ended return Nothing.
daysInSpan :: DateSpan -> Maybe Integer
daysInSpan :: DateSpan -> Maybe Integer
daysInSpan (DateSpan (Just Day
d1) (Just Day
d2)) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Day -> Day -> Integer
diffDays Day
d2 Day
d1
daysInSpan DateSpan
_ = forall a. Maybe a
Nothing

-- | Is this an empty span, ie closed with the end date on or before the start date ?
isEmptySpan :: DateSpan -> Bool
isEmptySpan :: DateSpan -> Bool
isEmptySpan (DateSpan (Just Day
s) (Just Day
e)) = Day
e forall a. Ord a => a -> a -> Bool
<= Day
s
isEmptySpan DateSpan
_                            = Bool
False

-- | Does the span include the given date ?
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 forall a. Ord a => a -> a -> Bool
< Day
e
spanContainsDate (DateSpan (Just Day
b) Maybe Day
Nothing)  Day
d = Day
d forall a. Ord a => a -> a -> Bool
>= Day
b
spanContainsDate (DateSpan (Just Day
b) (Just Day
e)) Day
d = Day
d forall a. Ord a => a -> a -> Bool
>= Day
b Bool -> Bool -> Bool
&& Day
d forall a. Ord a => a -> a -> Bool
< Day
e

-- | Does the period include the given date ?
-- (Here to avoid import cycle).
periodContainsDate :: Period -> Day -> Bool
periodContainsDate :: Period -> Day -> Bool
periodContainsDate Period
p = DateSpan -> Day -> Bool
spanContainsDate (Period -> DateSpan
periodAsDateSpan Period
p)

-- | Group elements based on where they fall in a list of 'DateSpan's without
-- gaps. The precondition is not checked.
groupByDateSpan :: Bool -> (a -> Day) -> [DateSpan] -> [a] -> [(DateSpan, [a])]
groupByDateSpan :: forall a.
Bool -> (a -> Day) -> [DateSpan] -> [a] -> [(DateSpan, [a])]
groupByDateSpan Bool
showempty a -> Day
date [DateSpan]
colspans =
      [DateSpan] -> [(Day, a)] -> [(DateSpan, [a])]
groupByCols [DateSpan]
colspans
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Day -> Bool
beforeStart forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall a b. (a, b) -> a
fst)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\a
x -> (a -> Day
date a
x, a
x))
  where
    groupByCols :: [DateSpan] -> [(Day, a)] -> [(DateSpan, [a])]
groupByCols []     [(Day, a)]
_  = []
    groupByCols (DateSpan
c:[DateSpan]
cs) [] = if Bool
showempty then (DateSpan
c, []) forall a. a -> [a] -> [a]
: [DateSpan] -> [(Day, a)] -> [(DateSpan, [a])]
groupByCols [DateSpan]
cs [] else []
    groupByCols (DateSpan
c:[DateSpan]
cs) [(Day, a)]
ps = (DateSpan
c, forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Day, a)]
matches) forall a. a -> [a] -> [a]
: [DateSpan] -> [(Day, a)] -> [(DateSpan, [a])]
groupByCols [DateSpan]
cs [(Day, a)]
later
      where ([(Day, a)]
matches, [(Day, a)]
later) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((DateSpan -> Maybe Day
spanEnd DateSpan
c forall a. Ord a => a -> a -> Bool
>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Day, a)]
ps

    beforeStart :: Day -> Bool
beforeStart = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> b -> a
const Bool
True) forall a. Ord a => a -> a -> Bool
(>) forall a b. (a -> b) -> a -> b
$ DateSpan -> Maybe Day
spanStart forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. [a] -> Maybe a
headMay [DateSpan]
colspans

-- | Calculate the intersection of a number of datespans.
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)

-- | Calculate the intersection of two datespans.
--
-- For non-intersecting spans, gives an empty span beginning on the second's start date:
-- >>> DateSpan (Just $ fromGregorian 2018 01 01) (Just $ fromGregorian 2018 01 03) `spanIntersect` DateSpan (Just $ fromGregorian 2018 01 03) (Just $ fromGregorian 2018 01 05)
-- DateSpan 2018-01-03..2018-01-02
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 = forall {a}. Ord a => Maybe a -> Maybe a -> Maybe a
latest Maybe Day
b1 Maybe Day
b2
      e :: Maybe Day
e = forall {a}. Ord a => Maybe a -> Maybe a -> Maybe a
earliest Maybe Day
e1 Maybe Day
e2

-- | Fill any unspecified dates in the first span with the dates from
-- the second one. Sort of a one-way spanIntersect.
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 forall a. Maybe a -> Bool
isJust Maybe Day
a1 then Maybe Day
a1 else Maybe Day
a2
          b :: Maybe Day
b = if forall a. Maybe a -> Bool
isJust Maybe Day
b1 then Maybe Day
b1 else Maybe Day
b2

-- | Calculate the union of a number of datespans.
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)

-- | Calculate the union of two datespans.
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 = forall {a}. Ord a => Maybe a -> Maybe a -> Maybe a
earliest Maybe Day
b1 Maybe Day
b2
      e :: Maybe Day
e = 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) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a
max a
d1 a
d2

earliest :: Maybe a -> Maybe a -> Maybe a
earliest Maybe a
d Maybe a
Nothing = Maybe a
d
earliest Maybe a
Nothing Maybe a
d = Maybe a
d
earliest (Just a
d1) (Just a
d2) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a
min a
d1 a
d2

-- | Calculate the minimal DateSpan containing all of the given Days (in the
-- usual exclusive-end-date sense: beginning on the earliest, and ending on
-- the day after the latest).
daysSpan :: [Day] -> DateSpan
daysSpan :: [Day] -> DateSpan
daysSpan [Day]
ds = Maybe Day -> Maybe Day -> DateSpan
DateSpan (forall a. Ord a => [a] -> Maybe a
minimumMay [Day]
ds) (Integer -> Day -> Day
addDays Integer
1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Ord a => [a] -> Maybe a
maximumMay [Day]
ds)

-- | Select the DateSpan containing a given Day, if any, from a given list of
-- DateSpans.
--
-- If the DateSpans are non-overlapping, this returns the unique containing
-- DateSpan, if it exists. If the DateSpans are overlapping, it will return the
-- containing DateSpan with the latest start date, and then latest end date.

-- Note: This will currently return `DateSpan (Just s) (Just e)` before it will
-- return `DateSpan (Just s) Nothing`. It's unclear which behaviour is desired.
-- This is irrelevant at the moment as it's never applied to any list with
-- overlapping DateSpans.
latestSpanContaining :: [DateSpan] -> Day -> Maybe DateSpan
latestSpanContaining :: [DateSpan] -> Day -> Maybe DateSpan
latestSpanContaining [DateSpan]
datespans = Day -> Maybe DateSpan
go
  where
    go :: Day -> Maybe DateSpan
go Day
day = do
        DateSpan
spn <- forall a. Ord a => a -> Set a -> Maybe a
Set.lookupLT DateSpan
supSpan Set DateSpan
spanSet
        forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ DateSpan -> Day -> Bool
spanContainsDate DateSpan
spn Day
day
        forall (m :: * -> *) a. Monad m => a -> m a
return DateSpan
spn
      where
        -- The smallest DateSpan larger than any DateSpan containing day.
        supSpan :: DateSpan
supSpan = Maybe Day -> Maybe Day -> DateSpan
DateSpan (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addDays Integer
1 Day
day) forall a. Maybe a
Nothing

    spanSet :: Set DateSpan
spanSet = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. DateSpan -> Bool
isEmptySpan) [DateSpan]
datespans

-- | Parse a period expression to an Interval and overall DateSpan using
-- the provided reference date, or return a parse error.
parsePeriodExpr
  :: Day -> Text -> Either HledgerParseErrors (Interval, DateSpan)
parsePeriodExpr :: Day -> Text -> Either HledgerParseErrors (Interval, DateSpan)
parsePeriodExpr Day
refdate Text
s = forall e a.
Parsec e Text a -> Text -> Either (ParseErrorBundle Text e) a
parsewith (forall (m :: * -> *). Day -> TextParser m (Interval, DateSpan)
periodexprp Day
refdate forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) (Text -> Text
T.toLower Text
s)

-- | Like parsePeriodExpr, but call error' on failure.
parsePeriodExpr' :: Day -> Text -> (Interval, DateSpan)
parsePeriodExpr' :: Day -> Text -> (Interval, DateSpan)
parsePeriodExpr' Day
refdate Text
s =
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. [Char] -> a
error' forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"failed to parse:" forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. HledgerParseErrors -> [Char]
customErrorBundlePretty) forall {a}. a -> a
id forall a b. (a -> b) -> a -> b
$  -- PARTIAL:
  Day -> Text -> Either HledgerParseErrors (Interval, DateSpan)
parsePeriodExpr Day
refdate Text
s

-- | Show a DateSpan as a human-readable pseudo-period-expression string.
-- dateSpanAsText :: DateSpan -> String
-- dateSpanAsText (DateSpan Nothing Nothing)   = "all"
-- dateSpanAsText (DateSpan Nothing (Just e))  = printf "to %s" (show e)
-- dateSpanAsText (DateSpan (Just b) Nothing)  = printf "from %s" (show b)
-- dateSpanAsText (DateSpan (Just b) (Just e)) = printf "%s to %s" (show b) (show e)

-- | Convert a single smart date string to a date span using the provided
-- reference date, or raise an error.
-- spanFromSmartDateString :: Day -> String -> DateSpan
-- spanFromSmartDateString refdate s = spanFromSmartDate refdate sdate
--     where
--       sdate = fromparse $ parsewith smartdateonly s

spanFromSmartDate :: Day -> SmartDate -> DateSpan
spanFromSmartDate :: Day -> SmartDate -> DateSpan
spanFromSmartDate Day
refdate SmartDate
sdate = Maybe Day -> Maybe Day -> DateSpan
DateSpan (forall a. a -> Maybe a
Just Day
b) (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
        where
          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 (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
nforall a. Num a => a -> a -> a
+Integer
1) Day
refdate)
          span' (SmartRelative Integer
n SmartInterval
Week)        = (Integer -> Day -> Day
addDays (Integer
7forall a. Num a => a -> a -> a
*Integer
n) Day
d, Integer -> Day -> Day
addDays (Integer
7forall a. Num a => a -> a -> a
*Integer
nforall a. Num a => a -> a -> a
+Integer
7) Day
d) where d :: Day
d = Day -> Day
thisweek Day
refdate
          span' (SmartRelative Integer
n SmartInterval
Month)       = (Integer -> Day -> Day
addGregorianMonthsClip Integer
n Day
d, Integer -> Day -> Day
addGregorianMonthsClip (Integer
nforall a. Num a => a -> a -> a
+Integer
1) Day
d) where d :: Day
d = Day -> Day
thismonth Day
refdate
          span' (SmartRelative Integer
n SmartInterval
Quarter)     = (Integer -> Day -> Day
addGregorianMonthsClip (Integer
3forall a. Num a => a -> a -> a
*Integer
n) Day
d, Integer -> Day -> Day
addGregorianMonthsClip (Integer
3forall a. Num a => a -> a -> a
*Integer
nforall a. Num a => a -> a -> a
+Integer
3) Day
d) where d :: Day
d = Day -> Day
thisquarter Day
refdate
          span' (SmartRelative Integer
n SmartInterval
Year)        = (Integer -> Day -> Day
addGregorianYearsClip Integer
n Day
d, Integer -> Day -> Day
addGregorianYearsClip (Integer
nforall a. Num a => a -> a -> a
+Integer
1) Day
d) where d :: Day
d = Day -> Day
thisyear Day
refdate

-- showDay :: Day -> String
-- showDay day = printf "%04d/%02d/%02d" y m d where (y,m,d) = toGregorian day

-- | Convert a smart date string to an explicit yyyy\/mm\/dd string using
-- the provided reference date, or raise an error.
fixSmartDateStr :: Day -> Text -> Text
fixSmartDateStr :: Day -> Text -> Text
fixSmartDateStr Day
d Text
s =
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. [Char] -> a
error' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. PrintfType r => [Char] -> r
printf [Char]
"could not parse date %s %s" (forall a. Show a => a -> [Char]
show Text
s) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show) forall {a}. a -> a
id forall a b. (a -> b) -> a -> b
$  -- PARTIAL:
  (Day -> Text -> Either HledgerParseErrors Text
fixSmartDateStrEither Day
d Text
s :: Either HledgerParseErrors Text)

-- | A safe version of fixSmartDateStr.
fixSmartDateStrEither :: Day -> Text -> Either HledgerParseErrors Text
fixSmartDateStrEither :: Day -> Text -> Either HledgerParseErrors Text
fixSmartDateStrEither Day
d = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Day -> Text
showDate 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 forall e a.
Parsec e Text a -> Text -> Either (ParseErrorBundle Text e) a
parsewith forall (m :: * -> *). TextParser m SmartDate
smartdateonly (Text -> Text
T.toLower Text
s) of
                               Right SmartDate
sd -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Day -> SmartDate -> Day
fixSmartDate Day
d SmartDate
sd
                               Left HledgerParseErrors
e -> forall a b. a -> Either a b
Left HledgerParseErrors
e

-- | Convert a SmartDate to an absolute date using the provided reference date.
--
-- ==== Examples:
-- >>> :set -XOverloadedStrings
-- >>> let t = fixSmartDateStr (fromGregorian 2008 11 26)
-- >>> t "0000-01-01"
-- "0000-01-01"
-- >>> t "1999-12-02"
-- "1999-12-02"
-- >>> t "1999.12.02"
-- "1999-12-02"
-- >>> t "1999/3/2"
-- "1999-03-02"
-- >>> t "19990302"
-- "1999-03-02"
-- >>> t "2008/2"
-- "2008-02-01"
-- >>> t "0020/2"
-- "0020-02-01"
-- >>> t "1000"
-- "1000-01-01"
-- >>> t "4/2"
-- "2008-04-02"
-- >>> t "2"
-- "2008-11-02"
-- >>> t "January"
-- "2008-01-01"
-- >>> t "feb"
-- "2008-02-01"
-- >>> t "today"
-- "2008-11-26"
-- >>> t "yesterday"
-- "2008-11-25"
-- >>> t "tomorrow"
-- "2008-11-27"
-- >>> t "this day"
-- "2008-11-26"
-- >>> t "last day"
-- "2008-11-25"
-- >>> t "next day"
-- "2008-11-27"
-- >>> t "this week"  -- last monday
-- "2008-11-24"
-- >>> t "last week"  -- previous monday
-- "2008-11-17"
-- >>> t "next week"  -- next monday
-- "2008-12-01"
-- >>> t "this month"
-- "2008-11-01"
-- >>> t "last month"
-- "2008-10-01"
-- >>> t "next month"
-- "2008-12-01"
-- >>> t "this quarter"
-- "2008-10-01"
-- >>> t "last quarter"
-- "2008-07-01"
-- >>> t "next quarter"
-- "2009-01-01"
-- >>> t "this year"
-- "2008-01-01"
-- >>> t "last year"
-- "2007-01-01"
-- >>> t "next year"
-- "2009-01-01"
--
-- t "last wed"
-- "2008-11-19"
-- t "next friday"
-- "2008-11-28"
-- t "next january"
-- "2009-01-01"
--
-- >>> t "in 5 days"
-- "2008-12-01"
-- >>> t "in 7 months"
-- "2009-06-01"
-- >>> t "in -2 weeks"
-- "2008-11-10"
-- >>> t "1 quarter ago"
-- "2008-07-01"
-- >>> t "1 week ahead"
-- "2008-12-01"
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 (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 (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
7forall a. Num a => a -> a -> a
*Integer
n) forall a b. (a -> b) -> a -> b
$ Day -> Day
thisweek Day
refdate
    fix (SmartRelative Integer
n SmartInterval
Month)   = Integer -> Day -> Day
addGregorianMonthsClip Integer
n forall a b. (a -> b) -> a -> b
$ Day -> Day
thismonth Day
refdate
    fix (SmartRelative Integer
n SmartInterval
Quarter) = Integer -> Day -> Day
addGregorianMonthsClip (Integer
3forall a. Num a => a -> a -> a
*Integer
n) forall a b. (a -> b) -> a -> b
$ Day -> Day
thisquarter Day
refdate
    fix (SmartRelative Integer
n SmartInterval
Year)    = Integer -> Day -> Day
addGregorianYearsClip Integer
n forall a b. (a -> b) -> a -> b
$ Day -> Day
thisyear Day
refdate
    (Integer
ry, Int
rm, Int
_) = Day -> (Integer, Int, Int)
toGregorian Day
refdate

prevday :: Day -> Day
prevday :: Day -> Day
prevday = Integer -> Day -> Day
addDays (-Integer
1)
nextday :: Day -> Day
nextday = Integer -> Day -> Day
addDays Integer
1
startofday :: a -> a
startofday = forall {a}. a -> a
id

thisweek :: Day -> Day
thisweek = Day -> Day
startofweek
prevweek :: Day -> Day
prevweek = Day -> Day
startofweek forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Day -> Day
addDays (-Integer
7)
nextweek :: Day -> Day
nextweek = Day -> Day
startofweek forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Day -> Day
addDays Integer
7
startofweek :: Day -> Day
startofweek Day
day = Integer -> Int -> Int -> Day
fromMondayStartWeek Integer
y Int
w Int
1
    where
      (Integer
y,Int
_,Int
_) = Day -> (Integer, Int, Int)
toGregorian Day
day
      (Int
w,Int
_) = Day -> (Int, Int)
mondayStartWeek Day
day

thismonth :: Day -> Day
thismonth = Day -> Day
startofmonth
prevmonth :: Day -> Day
prevmonth = Day -> Day
startofmonth forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Day -> Day
addGregorianMonthsClip (-Integer
1)
nextmonth :: Day -> Day
nextmonth = Day -> Day
startofmonth forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Day -> Day
addGregorianMonthsClip Integer
1
startofmonth :: Day -> Day
startofmonth Day
day = Integer -> Int -> Int -> Day
fromGregorian Integer
y Int
m Int
1 where (Integer
y,Int
m,Int
_) = Day -> (Integer, Int, Int)
toGregorian Day
day
nthdayofmonth :: Int -> Day -> Day
nthdayofmonth Int
d Day
day = Integer -> Int -> Int -> Day
fromGregorian Integer
y Int
m Int
d where (Integer
y,Int
m,Int
_) = Day -> (Integer, Int, Int)
toGregorian Day
day

thisquarter :: Day -> Day
thisquarter = Day -> Day
startofquarter
startofquarter :: Day -> Day
startofquarter Day
day = Integer -> Int -> Int -> Day
fromGregorian Integer
y (forall {a}. Integral a => a -> a
firstmonthofquarter Int
m) Int
1
    where
      (Integer
y,Int
m,Int
_) = Day -> (Integer, Int, Int)
toGregorian Day
day
      firstmonthofquarter :: a -> a
firstmonthofquarter a
m2 = ((a
m2forall a. Num a => a -> a -> a
-a
1) forall a. Integral a => a -> a -> a
`div` a
3) forall a. Num a => a -> a -> a
* a
3 forall a. Num a => a -> a -> a
+ a
1

thisyear :: Day -> Day
thisyear = Day -> Day
startofyear
prevyear :: Day -> Day
prevyear = Day -> Day
startofyear forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Day -> Day
addGregorianYearsClip (-Integer
1)
nextyear :: Day -> Day
nextyear = Day -> Day
startofyear forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Day -> Day
addGregorianYearsClip Integer
1
startofyear :: Day -> Day
startofyear Day
day = Integer -> Int -> Int -> Day
fromGregorian Integer
y Int
1 Int
1 where (Integer
y,Int
_,Int
_) = Day -> (Integer, Int, Int)
toGregorian Day
day

-- Get the natural start for the given interval that falls on or before the given day.
intervalStartBefore :: Interval -> Day -> Day
intervalStartBefore :: Interval -> Day -> Day
intervalStartBefore Interval
int Day
d =
  case Interval -> DateSpan -> [DateSpan]
splitSpan Interval
int (Maybe Day -> Maybe Day -> DateSpan
DateSpan (forall a. a -> Maybe a
Just Day
d) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addDays Integer
1 Day
d)) of
    (DateSpan (Just Day
start) Maybe Day
_:[DateSpan]
_) -> Day
start
    [DateSpan]
_ -> Day
d

-- | For given date d find year-long interval that starts on given
-- MM/DD of year and covers it.
-- The given MM and DD should be basically valid (1-12 & 1-31),
-- or an error is raised.
--
-- Examples: lets take 2017-11-22. Year-long intervals covering it that
-- starts before Nov 22 will start in 2017. However
-- intervals that start after Nov 23rd should start in 2016:
-- >>> let wed22nd = fromGregorian 2017 11 22
-- >>> nthdayofyearcontaining 11 21 wed22nd
-- 2017-11-21
-- >>> nthdayofyearcontaining 11 22 wed22nd
-- 2017-11-22
-- >>> nthdayofyearcontaining 11 23 wed22nd
-- 2016-11-23
-- >>> nthdayofyearcontaining 12 02 wed22nd
-- 2016-12-02
-- >>> nthdayofyearcontaining 12 31 wed22nd
-- 2016-12-31
-- >>> nthdayofyearcontaining 1 1 wed22nd
-- 2017-01-01
nthdayofyearcontaining :: Month -> MonthDay -> Day -> Day
nthdayofyearcontaining :: Int -> Int -> Day -> Day
nthdayofyearcontaining Int
m Int
mdy Day
date
  -- PARTIAL:
  | Bool -> Bool
not (Int -> Bool
validMonth Int
m)  = forall a. [Char] -> a
error' forall a b. (a -> b) -> a -> b
$ [Char]
"nthdayofyearcontaining: invalid month "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> [Char]
show Int
m
  | Bool -> Bool
not (Int -> Bool
validDay   Int
mdy) = forall a. [Char] -> a
error' forall a b. (a -> b) -> a -> b
$ [Char]
"nthdayofyearcontaining: invalid day "  forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> [Char]
show Int
mdy
  | Day
mmddOfSameYear forall a. Ord a => a -> a -> Bool
<= Day
date = Day
mmddOfSameYear
  | Bool
otherwise = Day
mmddOfPrevYear
  where mmddOfSameYear :: Day
mmddOfSameYear = Integer -> Day -> Day
addDays (forall a. Integral a => a -> Integer
toInteger Int
mdyforall a. Num a => a -> a -> a
-Integer
1) forall a b. (a -> b) -> a -> b
$ forall a. Int -> (a -> a) -> a -> a
applyN (Int
mforall a. Num a => a -> a -> a
-Int
1) Day -> Day
nextmonth Day
s
        mmddOfPrevYear :: Day
mmddOfPrevYear = Integer -> Day -> Day
addDays (forall a. Integral a => a -> Integer
toInteger Int
mdyforall a. Num a => a -> a -> a
-Integer
1) forall a b. (a -> b) -> a -> b
$ forall a. Int -> (a -> a) -> a -> a
applyN (Int
mforall a. Num a => a -> a -> a
-Int
1) Day -> Day
nextmonth forall a b. (a -> b) -> a -> b
$ Day -> Day
prevyear Day
s
        s :: Day
s = Day -> Day
startofyear Day
date

-- | For given date d find month-long interval that starts on nth day of month
-- and covers it.
-- The given day of month should be basically valid (1-31), or an error is raised.
--
-- Examples: lets take 2017-11-22. Month-long intervals covering it that
-- start on 1st-22nd of month will start in Nov. However
-- intervals that start on 23rd-30th of month should start in Oct:
-- >>> let wed22nd = fromGregorian 2017 11 22
-- >>> nthdayofmonthcontaining 1 wed22nd
-- 2017-11-01
-- >>> nthdayofmonthcontaining 12 wed22nd
-- 2017-11-12
-- >>> nthdayofmonthcontaining 22 wed22nd
-- 2017-11-22
-- >>> nthdayofmonthcontaining 23 wed22nd
-- 2017-10-23
-- >>> nthdayofmonthcontaining 30 wed22nd
-- 2017-10-30
nthdayofmonthcontaining :: MonthDay -> Day -> Day
nthdayofmonthcontaining :: Int -> Day -> Day
nthdayofmonthcontaining Int
mdy Day
date
  -- PARTIAL:
  | Bool -> Bool
not (Int -> Bool
validDay Int
mdy) = forall a. [Char] -> a
error' forall a b. (a -> b) -> a -> b
$ [Char]
"nthdayofmonthcontaining: invalid day "  forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> [Char]
show Int
mdy
  | Day
nthOfSameMonth forall a. Ord a => a -> a -> Bool
<= Day
date = Day
nthOfSameMonth
  | Bool
otherwise = Day
nthOfPrevMonth
  where nthOfSameMonth :: Day
nthOfSameMonth = Int -> Day -> Day
nthdayofmonth Int
mdy Day
s
        nthOfPrevMonth :: Day
nthOfPrevMonth = Int -> Day -> Day
nthdayofmonth Int
mdy forall a b. (a -> b) -> a -> b
$ Day -> Day
prevmonth Day
s
        s :: Day
s = Day -> Day
startofmonth Day
date

-- | For given date d find week-long interval that starts on nth day of week
-- and covers it.
--
-- Examples: 2017-11-22 is Wed. Week-long intervals that cover it and
-- start on Mon, Tue or Wed will start in the same week. However
-- intervals that start on Thu or Fri should start in prev week:
-- >>> let wed22nd = fromGregorian 2017 11 22
-- >>> nthdayofweekcontaining 1 wed22nd
-- 2017-11-20
-- >>> nthdayofweekcontaining 2 wed22nd
-- 2017-11-21
-- >>> nthdayofweekcontaining 3 wed22nd
-- 2017-11-22
-- >>> nthdayofweekcontaining 4 wed22nd
-- 2017-11-16
-- >>> nthdayofweekcontaining 5 wed22nd
-- 2017-11-17
nthdayofweekcontaining :: WeekDay -> Day -> Day
nthdayofweekcontaining :: Int -> Day -> Day
nthdayofweekcontaining Int
n Day
d | Day
nthOfSameWeek forall a. Ord a => a -> a -> Bool
<= Day
d = Day
nthOfSameWeek
                           | Bool
otherwise = Day
nthOfPrevWeek
    where nthOfSameWeek :: Day
nthOfSameWeek = Integer -> Day -> Day
addDays (forall a. Integral a => a -> Integer
toInteger Int
nforall a. Num a => a -> a -> a
-Integer
1) Day
s
          nthOfPrevWeek :: Day
nthOfPrevWeek = Integer -> Day -> Day
addDays (forall a. Integral a => a -> Integer
toInteger Int
nforall a. Num a => a -> a -> a
-Integer
1) forall a b. (a -> b) -> a -> b
$ Day -> Day
prevweek Day
s
          s :: Day
s = Day -> Day
startofweek Day
d

-- | For given date d find month-long interval that starts on nth weekday of month
-- and covers it.
--
-- Examples: 2017-11-22 is 3rd Wed of Nov. Month-long intervals that cover it and
-- start on 1st-4th Wed will start in Nov. However
-- intervals that start on 4th Thu or Fri or later should start in Oct:
-- >>> let wed22nd = fromGregorian 2017 11 22
-- >>> nthweekdayofmonthcontaining 1 3 wed22nd
-- 2017-11-01
-- >>> nthweekdayofmonthcontaining 3 2 wed22nd
-- 2017-11-21
-- >>> nthweekdayofmonthcontaining 4 3 wed22nd
-- 2017-11-22
-- >>> nthweekdayofmonthcontaining 4 4 wed22nd
-- 2017-10-26
-- >>> nthweekdayofmonthcontaining 4 5 wed22nd
-- 2017-10-27
nthweekdayofmonthcontaining :: Int -> WeekDay -> Day -> Day
nthweekdayofmonthcontaining :: Int -> Int -> Day -> Day
nthweekdayofmonthcontaining Int
n Int
wd Day
d | Day
nthWeekdaySameMonth forall a. Ord a => a -> a -> Bool
<= Day
d  = Day
nthWeekdaySameMonth
                                   | Bool
otherwise = Day
nthWeekdayPrevMonth
    where nthWeekdaySameMonth :: Day
nthWeekdaySameMonth = Int -> Int -> Day -> Day
advancetonthweekday Int
n Int
wd forall a b. (a -> b) -> a -> b
$ Day -> Day
startofmonth Day
d
          nthWeekdayPrevMonth :: Day
nthWeekdayPrevMonth = Int -> Int -> Day -> Day
advancetonthweekday Int
n Int
wd forall a b. (a -> b) -> a -> b
$ Day -> Day
prevmonth Day
d

-- | Advance to nth weekday wd after given start day s
-- Can call error.
advancetonthweekday :: Int -> WeekDay -> Day -> Day
advancetonthweekday :: Int -> Int -> Day -> Day
advancetonthweekday Int
n Int
wd Day
s =
  -- PARTIAL:
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall {a}. a
err (forall {a}. Integral a => a -> Day -> Day
addWeeks (Int
nforall a. Num a => a -> a -> a
-Int
1)) forall a b. (a -> b) -> a -> b
$ forall {a}. (a -> Bool) -> [a] -> Maybe a
firstMatch (forall a. Ord a => a -> a -> Bool
>=Day
s) forall a b. (a -> b) -> a -> b
$ forall a. (a -> a) -> a -> [a]
iterate (forall {a}. Integral a => a -> Day -> Day
addWeeks Integer
1) forall a b. (a -> b) -> a -> b
$ Day -> Day
firstweekday Day
s
  where
    err :: a
err = forall a. [Char] -> a
error' [Char]
"advancetonthweekday: should not happen"
    addWeeks :: a -> Day -> Day
addWeeks a
k = Integer -> Day -> Day
addDays (Integer
7 forall a. Num a => a -> a -> a
* forall a. Integral a => a -> Integer
toInteger a
k)
    firstMatch :: (a -> Bool) -> [a] -> Maybe a
firstMatch a -> Bool
p = forall a. [a] -> Maybe a
headMay forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Bool
p)
    firstweekday :: Day -> Day
firstweekday = Integer -> Day -> Day
addDays (forall a. Integral a => a -> Integer
toInteger Int
wdforall a. Num a => a -> a -> a
-Integer
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> Day
startofweek

----------------------------------------------------------------------
-- parsing

-- -- | Parse a couple of date-time string formats to a time type.
-- parsedatetimeM :: String -> Maybe LocalTime
-- parsedatetimeM s = asum [
--     parseTimeM TruedefaultTimeLocale "%Y/%m/%d %H:%M:%S" s,
--     parseTimeM TruedefaultTimeLocale "%Y-%m-%d %H:%M:%S" s
--     ]

-- | Try to parse a couple of date string formats:
-- `YYYY-MM-DD`, `YYYY/MM/DD` or `YYYY.MM.DD`, with leading zeros required.
-- For internal use, not quite the same as the journal's "simple dates".
-- >>> parsedateM "2008/02/03"
-- Just 2008-02-03
-- >>> parsedateM "2008/02/03/"
-- Nothing
-- >>> parsedateM "2008/02/30"
-- Nothing
parsedateM :: String -> Maybe Day
parsedateM :: [Char] -> Maybe Day
parsedateM [Char]
s = forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum [
     forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> [Char] -> [Char] -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale [Char]
"%Y-%m-%d" [Char]
s,
     forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> [Char] -> [Char] -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale [Char]
"%Y/%m/%d" [Char]
s,
     forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> [Char] -> [Char] -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale [Char]
"%Y.%m.%d" [Char]
s
     ]

{-|
Parse a date in any of the formats allowed in Ledger's period expressions, and some others.
Assumes any text in the parse stream has been lowercased.
Returns a SmartDate, to be converted to a full date later (see fixSmartDate).

Examples:

> 2004                                        (start of year, which must have 4+ digits)
> 2004/10                                     (start of month, which must be 1-12)
> 2004/10/1                                   (exact date, day must be 1-31)
> 10/1                                        (month and day in current year)
> 21                                          (day in current month)
> october, oct                                (start of month in current year)
> yesterday, today, tomorrow                  (-1, 0, 1 days from today)
> last/this/next day/week/month/quarter/year  (-1, 0, 1 periods from the current period)
> in n days/weeks/months/quarters/years       (n periods from the current period)
> n days/weeks/months/quarters/years ago      (-n periods from the current period)
> 20181201                                    (8 digit YYYYMMDD with valid year month and day)
> 201812                                      (6 digit YYYYMM with valid year and month)

Note malformed digit sequences might give surprising results:

> 201813                                      (6 digits with an invalid month is parsed as start of 6-digit year)
> 20181301                                    (8 digits with an invalid month is parsed as start of 8-digit year)
> 20181232                                    (8 digits with an invalid day gives an error)
> 201801012                                   (9+ digits beginning with a valid YYYYMMDD gives an error)

Eg:

YYYYMMDD is parsed as year-month-date if those parts are valid
(>=4 digits, 1-12, and 1-31 respectively):
>>> parsewith (smartdate <* eof) "20181201"
Right (SmartCompleteDate 2018-12-01)

YYYYMM is parsed as year-month-01 if year and month are valid:
>>> parsewith (smartdate <* eof) "201804"
Right (SmartAssumeStart 2018 (Just 4))

With an invalid month, it's parsed as a year:
>>> parsewith (smartdate <* eof) "201813"
Right (SmartAssumeStart 201813 Nothing)

A 9+ digit number beginning with valid YYYYMMDD gives an error:
>>> parsewith (smartdate <* eof) "201801012"
Left (...)

Big numbers not beginning with a valid YYYYMMDD are parsed as a year:
>>> parsewith (smartdate <* eof) "201813012"
Right (SmartAssumeStart 201813012 Nothing)

-}
smartdate :: TextParser m SmartDate
smartdate :: forall (m :: * -> *). TextParser m SmartDate
smartdate = forall (m :: * -> *) a. [TextParser m a] -> TextParser m a
choice'
  -- XXX maybe obscures date errors ? see ledgerdate
    [ TextParser m SmartDate
relativeP
    , forall (m :: * -> *). TextParser m SmartDate
yyyymmdd, forall (m :: * -> *). TextParser m SmartDate
ymd
    , (\(Int
m,Int
d) -> Maybe Int -> Int -> SmartDate
SmartFromReference (forall a. a -> Maybe a
Just Int
m) Int
d) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). TextParser m (Int, Int)
md
    , forall (m :: * -> *). MonadFail m => SmartDate -> m SmartDate
failIfInvalidDate forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Int -> Int -> SmartDate
SmartFromReference forall a. Maybe a
Nothing forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal
    , Int -> SmartDate
SmartMonth forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (m :: * -> *). TextParser m Int
month forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *). TextParser m Int
mon)
    , Integer -> SmartInterval -> SmartDate
SmartRelative Integer
0    SmartInterval
Day forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"today"
    , Integer -> SmartInterval -> SmartDate
SmartRelative (-Integer
1) SmartInterval
Day forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"yesterday"
    , Integer -> SmartInterval -> SmartDate
SmartRelative Integer
1    SmartInterval
Day forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"tomorrow"
    ]
  where
    relativeP :: TextParser m SmartDate
relativeP = do
        forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"in" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces
        Integer
num      <- forall {m :: * -> *}. ParsecT HledgerParseErrorData Text m Integer
seqP forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces
        SmartInterval
interval <- ParsecT HledgerParseErrorData Text m SmartInterval
intervalP forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces
        Integer -> Integer
sign     <- forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
choice [forall a. Num a => a -> a
negate forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"ago", forall {a}. a -> a
id forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"ahead", forall (f :: * -> *) a. Applicative f => a -> f a
pure forall {a}. a -> a
id]
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Integer -> SmartInterval -> SmartDate
SmartRelative (Integer -> Integer
sign Integer
num) SmartInterval
interval

    seqP :: ParsecT HledgerParseErrorData Text m Integer
seqP = forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
choice [ Integer
0 forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"this", -Integer
1 forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"last", Integer
1 forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"next", forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m () -> m a -> m a
signed forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal ]
    intervalP :: ParsecT HledgerParseErrorData Text m SmartInterval
intervalP = forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
choice [ SmartInterval
Day forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"day", SmartInterval
Week forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"week", SmartInterval
Month forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"month"
                       , SmartInterval
Quarter forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"quarter", SmartInterval
Year forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"year" ] forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char' Char
's')

-- | Like smartdate, but there must be nothing other than whitespace after the date.
smartdateonly :: TextParser m SmartDate
smartdateonly :: forall (m :: * -> *). TextParser m SmartDate
smartdateonly = forall (m :: * -> *). TextParser m SmartDate
smartdate forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *). MonadParsec e s m => m ()
eof

datesepchars :: String
datesepchars :: [Char]
datesepchars = [Char]
"/-."

datesepchar :: TextParser m Char
datesepchar :: forall (m :: * -> *). TextParser m Char
datesepchar = forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
isDateSepChar

isDateSepChar :: Char -> Bool
isDateSepChar :: Char -> Bool
isDateSepChar Char
c = Char
c forall a. Eq a => a -> a -> Bool
== Char
'-' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'/' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'.'

validMonth, validDay :: Int -> Bool
validMonth :: Int -> Bool
validMonth Int
n = Int
n forall a. Ord a => a -> a -> Bool
>= Int
1 Bool -> Bool -> Bool
&& Int
n forall a. Ord a => a -> a -> Bool
<= Int
12
validDay :: Int -> Bool
validDay Int
n = Int
n forall a. Ord a => a -> a -> Bool
>= Int
1 Bool -> Bool -> Bool
&& Int
n forall a. Ord a => a -> a -> Bool
<= Int
31

failIfInvalidDate :: Fail.MonadFail m => SmartDate -> m SmartDate
failIfInvalidDate :: forall (m :: * -> *). MonadFail m => SmartDate -> m SmartDate
failIfInvalidDate SmartDate
s = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isValid (forall (m :: * -> *) a. MonadFail m => [Char] -> m a
Fail.fail forall a b. (a -> b) -> a -> b
$ [Char]
"bad smart date: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show SmartDate
s) forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> SmartDate
s
  where isValid :: Bool
isValid = case SmartDate
s of
            SmartAssumeStart Integer
_ (Just Int
m) -> Int -> Bool
validMonth Int
m
            SmartFromReference Maybe Int
mm Int
d     -> forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Maybe Day
fromGregorianValid Integer
2004 (forall a. a -> Maybe a -> a
fromMaybe Int
1 Maybe Int
mm) Int
d
            SmartMonth Int
m                -> Int -> Bool
validMonth Int
m
            SmartDate
_                           -> Bool
True

showBadDate :: Integer -> Int -> Int -> String
showBadDate :: Integer -> Int -> Int -> [Char]
showBadDate Integer
y Int
m Int
d = [Char]
"bad smart date: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Integer
y forall a. [a] -> [a] -> [a]
++ [Char]
"-" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
m forall a. [a] -> [a] -> [a]
++ [Char]
"-" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
d

yyyymmdd :: TextParser m SmartDate
yyyymmdd :: forall (m :: * -> *). TextParser m SmartDate
yyyymmdd = do
  Integer
y <- forall a. Read a => [Char] -> a
read forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count Int
4 forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar
  Int
m <- forall a. Read a => [Char] -> a
read forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count Int
2 forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar
  Maybe Int
mdy <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a b. (a -> b) -> a -> b
$ forall a. Read a => [Char] -> a
read forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count Int
2 forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar
  case Maybe Int
mdy of
      Maybe Int
Nothing -> forall (m :: * -> *). MonadFail m => SmartDate -> m SmartDate
failIfInvalidDate forall a b. (a -> b) -> a -> b
$ Integer -> Maybe Int -> SmartDate
SmartAssumeStart Integer
y (forall a. a -> Maybe a
Just Int
m)
      Just Int
d  -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadFail m => [Char] -> m a
Fail.fail forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> [Char]
showBadDate Integer
y Int
m Int
d) (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> SmartDate
SmartCompleteDate) forall a b. (a -> b) -> a -> b
$
                   Integer -> Int -> Int -> Maybe Day
fromGregorianValid Integer
y Int
m Int
d

ymd :: TextParser m SmartDate
ymd :: forall (m :: * -> *). TextParser m SmartDate
ymd = do
    Integer
y <- forall {m :: * -> *}. ParsecT HledgerParseErrorData Text m Integer
yearp
    Maybe (Either Int Day)
emd <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ do
        Char
sep <- forall (m :: * -> *). TextParser m Char
datesepchar
        Int
m <- forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int -> Bool
validMonth Int
m) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => [Char] -> m a
Fail.fail ([Char]
"Bad month " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Int
m)
        forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option (forall a b. a -> Either a b
Left Int
m) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
            Token Text
_ <- forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
sep
            Int
d <- forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal
            forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadFail m => [Char] -> m a
Fail.fail forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> [Char]
showBadDate Integer
y Int
m Int
d) forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Maybe Day
fromGregorianValid Integer
y Int
m Int
d
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Maybe (Either Int Day)
emd of
        Maybe (Either Int Day)
Nothing          -> Integer -> Maybe Int -> SmartDate
SmartAssumeStart Integer
y forall a. Maybe a
Nothing
        Just (Left Int
m)    -> Integer -> Maybe Int -> SmartDate
SmartAssumeStart Integer
y (forall a. a -> Maybe a
Just Int
m)
        Just (Right Day
day) -> Day -> SmartDate
SmartCompleteDate Day
day

md :: TextParser m (Month, MonthDay)
md :: forall (m :: * -> *). TextParser m (Int, Int)
md = do
  Int
m <- forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal
  forall (m :: * -> *). TextParser m Char
datesepchar
  Int
d <- forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal
  SmartDate
_ <- forall (m :: * -> *). MonadFail m => SmartDate -> m SmartDate
failIfInvalidDate forall a b. (a -> b) -> a -> b
$ Maybe Int -> Int -> SmartDate
SmartFromReference (forall a. a -> Maybe a
Just Int
m) Int
d
  forall (m :: * -> *) a. Monad m => a -> m a
return (Int
m, Int
d)

-- | Parse a year number from a Text, making sure that at least four digits are
-- used.
yearp :: TextParser m Integer
yearp :: forall {m :: * -> *}. ParsecT HledgerParseErrorData Text m Integer
yearp = do
  Text
year <- forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe [Char] -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P (forall a. a -> Maybe a
Just [Char]
"year") Char -> Bool
isDigit
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Int
T.length Text
year forall a. Ord a => a -> a -> Bool
>= Int
4) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadFail m => [Char] -> m a
Fail.fail forall a b. (a -> b) -> a -> b
$ [Char]
"Year must contain at least 4 digits: " forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
year
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> Integer
readDecimal Text
year

-- These are compared case insensitively, and should all be kept lower case.
months :: [Tokens Text]
months         = [Tokens Text
"january",Tokens Text
"february",Tokens Text
"march",Tokens Text
"april",Tokens Text
"may",Tokens Text
"june",
                  Tokens Text
"july",Tokens Text
"august",Tokens Text
"september",Tokens Text
"october",Tokens Text
"november",Tokens Text
"december"]
monthabbrevs :: [Tokens Text]
monthabbrevs   = [Tokens Text
"jan",Tokens Text
"feb",Tokens Text
"mar",Tokens Text
"apr",Tokens Text
"may",Tokens Text
"jun",Tokens Text
"jul",Tokens Text
"aug",Tokens Text
"sep",Tokens Text
"oct",Tokens Text
"nov",Tokens Text
"dec"]
weekdays :: [Tokens Text]
weekdays       = [Tokens Text
"monday",Tokens Text
"tuesday",Tokens Text
"wednesday",Tokens Text
"thursday",Tokens Text
"friday",Tokens Text
"saturday",Tokens Text
"sunday"]
weekdayabbrevs :: [Tokens Text]
weekdayabbrevs = [Tokens Text
"mon",Tokens Text
"tue",Tokens Text
"wed",Tokens Text
"thu",Tokens Text
"fri",Tokens Text
"sat",Tokens Text
"sun"]

month, mon :: TextParser m Month
month :: forall (m :: * -> *). TextParser m Int
month = forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
choice forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
i Tokens Text
m -> Int
i forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
m) [Int
1..Int
12] [Tokens Text]
months
mon :: forall (m :: * -> *). TextParser m Int
mon   = forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
choice forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
i Tokens Text
m -> Int
i forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
m) [Int
1..Int
12] [Tokens Text]
monthabbrevs

weekday :: TextParser m Int
weekday :: forall (m :: * -> *). TextParser m Int
weekday = do
  Text
wday <- Text -> Text
T.toLower forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
choice forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' forall a b. (a -> b) -> a -> b
$ [Tokens Text]
weekdays forall a. [a] -> [a] -> [a]
++ [Tokens Text]
weekdayabbrevs)
  case forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ [Text
wday forall a. Eq a => a -> [a] -> Maybe Int
`elemIndex` [Tokens Text]
weekdays, Text
wday forall a. Eq a => a -> [a] -> Maybe Int
`elemIndex` [Tokens Text]
weekdayabbrevs] of
    (Int
i:[Int]
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return (Int
iforall a. Num a => a -> a -> a
+Int
1)
    []    -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
Fail.fail forall a b. (a -> b) -> a -> b
$ [Char]
"weekday: should not happen: attempted to find " forall a. Semigroup a => a -> a -> a
<>
                         forall a. Show a => a -> [Char]
show Text
wday forall a. Semigroup a => a -> a -> a
<> [Char]
" in " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show ([Tokens Text]
weekdays forall a. [a] -> [a] -> [a]
++ [Tokens Text]
weekdayabbrevs)

weekdaysp :: TextParser m [Int]
weekdaysp :: forall (m :: * -> *). TextParser m [Int]
weekdaysp = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [[a]]
group forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> [a]
sort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
sepBy1 forall (m :: * -> *). TextParser m Int
weekday (forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
",")

-- | Parse a period expression, specifying a date span and optionally
-- a reporting interval. Requires a reference "today" date for
-- resolving any relative start/end dates (only; it is not needed for
-- parsing the reporting interval).
--
-- >>> let p = parsePeriodExpr (fromGregorian 2008 11 26)
-- >>> p "from Aug to Oct"
-- Right (NoInterval,DateSpan 2008-08-01..2008-09-30)
-- >>> p "aug to oct"
-- Right (NoInterval,DateSpan 2008-08-01..2008-09-30)
-- >>> p "2009q2"
-- Right (NoInterval,DateSpan 2009Q2)
-- >>> p "Q3"
-- Right (NoInterval,DateSpan 2008Q3)
-- >>> p "every 3 days in Aug"
-- Right (Days 3,DateSpan 2008-08)
-- >>> p "daily from aug"
-- Right (Days 1,DateSpan 2008-08-01..)
-- >>> p "every week to 2009"
-- Right (Weeks 1,DateSpan ..2008-12-31)
-- >>> p "every 2nd day of month"
-- Right (DayOfMonth 2,DateSpan ..)
-- >>> p "every 2nd day"
-- Right (DayOfMonth 2,DateSpan ..)
-- >>> p "every 2nd day 2009.."
-- Right (DayOfMonth 2,DateSpan 2009-01-01..)
-- >>> p "every 2nd day 2009-"
-- Right (DayOfMonth 2,DateSpan 2009-01-01..)
-- >>> p "every 29th Nov"
-- Right (DayOfYear 11 29,DateSpan ..)
-- >>> p "every 29th nov ..2009"
-- Right (DayOfYear 11 29,DateSpan ..2008-12-31)
-- >>> p "every nov 29th"
-- Right (DayOfYear 11 29,DateSpan ..)
-- >>> p "every Nov 29th 2009.."
-- Right (DayOfYear 11 29,DateSpan 2009-01-01..)
-- >>> p "every 11/29 from 2009"
-- Right (DayOfYear 11 29,DateSpan 2009-01-01..)
-- >>> p "every 2nd Thursday of month to 2009"
-- Right (WeekdayOfMonth 2 4,DateSpan ..2008-12-31)
-- >>> p "every 1st monday of month to 2009"
-- Right (WeekdayOfMonth 1 1,DateSpan ..2008-12-31)
-- >>> p "every tue"
-- Right (DaysOfWeek [2],DateSpan ..)
-- >>> p "every 2nd day of week"
-- Right (DaysOfWeek [2],DateSpan ..)
-- >>> p "every 2nd day of month"
-- Right (DayOfMonth 2,DateSpan ..)
-- >>> p "every 2nd day"
-- Right (DayOfMonth 2,DateSpan ..)
-- >>> p "every 2nd day 2009.."
-- Right (DayOfMonth 2,DateSpan 2009-01-01..)
-- >>> p "every 2nd day of month 2009.."
-- Right (DayOfMonth 2,DateSpan 2009-01-01..)
periodexprp :: Day -> TextParser m (Interval, DateSpan)
periodexprp :: forall (m :: * -> *). Day -> TextParser m (Interval, DateSpan)
periodexprp Day
rdate = do
  forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces
  forall (m :: * -> *) a. [TextParser m a] -> TextParser m a
choice' [ forall (m :: * -> *). Day -> TextParser m (Interval, DateSpan)
intervalanddateperiodexprp Day
rdate
          , (,) Interval
NoInterval forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Day -> TextParser m DateSpan
periodexprdatespanp Day
rdate
          ]

-- Parse a reporting interval and a date span.
intervalanddateperiodexprp :: Day -> TextParser m (Interval, DateSpan)
intervalanddateperiodexprp :: forall (m :: * -> *). Day -> TextParser m (Interval, DateSpan)
intervalanddateperiodexprp Day
rdate = do
  Interval
i <- forall (m :: * -> *). TextParser m Interval
reportingintervalp
  DateSpan
s <- forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option forall a. Default a => a
def forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ do
      forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces
      forall (m :: * -> *). Day -> TextParser m DateSpan
periodexprdatespanp Day
rdate
  forall (m :: * -> *) a. Monad m => a -> m a
return (Interval
i,DateSpan
s)

-- Parse a reporting interval.
reportingintervalp :: TextParser m Interval
reportingintervalp :: forall (m :: * -> *). TextParser m Interval
reportingintervalp = forall (m :: * -> *) a. [TextParser m a] -> TextParser m a
choice'
    [ forall (m :: * -> *).
Text -> Text -> (Int -> Interval) -> TextParser m Interval
tryinterval Text
"day"     Text
"daily"     Int -> Interval
Days
    , forall (m :: * -> *).
Text -> Text -> (Int -> Interval) -> TextParser m Interval
tryinterval Text
"month"   Text
"monthly"   Int -> Interval
Months
    , forall (m :: * -> *).
Text -> Text -> (Int -> Interval) -> TextParser m Interval
tryinterval Text
"quarter" Text
"quarterly" Int -> Interval
Quarters
    , forall (m :: * -> *).
Text -> Text -> (Int -> Interval) -> TextParser m Interval
tryinterval Text
"year"    Text
"yearly"    Int -> Interval
Years
    , Int -> Interval
Weeks Int
2 forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"biweekly"
    , Int -> Interval
Weeks Int
2 forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"fortnightly"
    , Int -> Interval
Months Int
2 forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"bimonthly"
    , forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"every" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. [TextParser m a] -> TextParser m a
choice'
        [ [Int] -> Interval
DaysOfWeek forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT HledgerParseErrorData Text m Int
nth forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"day" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall {s} {m :: * -> *}.
(Token s ~ Char, Stream s, FoldCase (Tokens s),
 IsString (Tokens s)) =>
Tokens s -> ParsecT HledgerParseErrorData s m (Tokens s)
of_ Text
"week")
        , Int -> Interval
DayOfMonth forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT HledgerParseErrorData Text m Int
nth forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"day" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall {s} {m :: * -> *}.
(Token s ~ Char, Stream s, FoldCase (Tokens s),
 IsString (Tokens s)) =>
Tokens s -> ParsecT HledgerParseErrorData s m (Maybe (Tokens s))
optOf_ Text
"month")
        , forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Int -> Int -> Interval
WeekdayOfMonth ParsecT HledgerParseErrorData Text m Int
nth forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *). TextParser m Int
weekday forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall {s} {m :: * -> *}.
(Token s ~ Char, Stream s, FoldCase (Tokens s),
 IsString (Tokens s)) =>
Tokens s -> ParsecT HledgerParseErrorData s m (Maybe (Tokens s))
optOf_ Text
"month"
        , forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Int -> Interval
DayOfYear forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (m :: * -> *). TextParser m (Int, Int)
md forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall {s} {m :: * -> *}.
(Token s ~ Char, Stream s, FoldCase (Tokens s),
 IsString (Tokens s)) =>
Tokens s -> ParsecT HledgerParseErrorData s m (Maybe (Tokens s))
optOf_ Text
"year")
        , [Int] -> Interval
DaysOfWeek forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). TextParser m [Int]
weekdaysp
        , [Int] -> Interval
DaysOfWeek [Int
1..Int
5] forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"weekday"
        , [Int] -> Interval
DaysOfWeek [Int
6..Int
7] forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"weekendday"
        , TextParser m Interval
d_o_y forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall {s} {m :: * -> *}.
(Token s ~ Char, Stream s, FoldCase (Tokens s),
 IsString (Tokens s)) =>
Tokens s -> ParsecT HledgerParseErrorData s m (Maybe (Tokens s))
optOf_ Text
"year"
        ]
    -- NB: the ordering is important here since the parse for `every weekday`
    -- would match the `tryinterval` first and then error on `d`. Perhaps it
    -- would be clearer to factor some of this into the `every` choice or other
    -- left-factorings.
    , forall (m :: * -> *).
Text -> Text -> (Int -> Interval) -> TextParser m Interval
tryinterval Text
"week"    Text
"weekly"    Int -> Interval
Weeks
    ]
  where
    of_ :: Tokens s -> ParsecT HledgerParseErrorData s m (Tokens s)
of_ Tokens s
period =
      forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens s
"of" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens s
period

    optOf_ :: Tokens s -> ParsecT HledgerParseErrorData s m (Maybe (Tokens s))
optOf_ Tokens s
period = forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ forall {s} {m :: * -> *}.
(Token s ~ Char, Stream s, FoldCase (Tokens s),
 IsString (Tokens s)) =>
Tokens s -> ParsecT HledgerParseErrorData s m (Tokens s)
of_ Tokens s
period

    nth :: ParsecT HledgerParseErrorData Text m Int
nth = forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
choice (forall a b. (a -> b) -> [a] -> [b]
map forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' [Tokens Text
"st",Tokens Text
"nd",Tokens Text
"rd",Tokens Text
"th"])
    d_o_y :: TextParser m Interval
d_o_y = forall (m :: * -> *) a. Alternative m => Permutation m a -> m a
runPermutation forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Int -> Int -> Interval
DayOfYear (forall (m :: * -> *) a. Alternative m => m a -> Permutation m a
toPermutation forall a b. (a -> b) -> a -> b
$ (forall (m :: * -> *). TextParser m Int
month forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *). TextParser m Int
mon) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces)
                                              (forall (m :: * -> *) a. Alternative m => m a -> Permutation m a
toPermutation forall a b. (a -> b) -> a -> b
$ ParsecT HledgerParseErrorData Text m Int
nth forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces)

    -- Parse any of several variants of a basic interval, eg "daily", "every day", "every N days".
    tryinterval :: Text -> Text -> (Int -> Interval) -> TextParser m Interval
    tryinterval :: forall (m :: * -> *).
Text -> Text -> (Int -> Interval) -> TextParser m Interval
tryinterval Text
singular Text
compact Int -> Interval
intcons = Int -> Interval
intcons forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. [TextParser m a] -> TextParser m a
choice'
        [ Int
1 forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Text
compact
        , forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"every" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
choice
            [ Int
1 forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Text
singular
            , forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' (Text
singular forall a. Semigroup a => a -> a -> a
<> Text
"s")
            ]
        ]

periodexprdatespanp :: Day -> TextParser m DateSpan
periodexprdatespanp :: forall (m :: * -> *). Day -> TextParser m DateSpan
periodexprdatespanp Day
rdate = forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
choice forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try [
                            forall (m :: * -> *). Day -> TextParser m DateSpan
doubledatespanp Day
rdate,
                            forall (m :: * -> *). Day -> TextParser m DateSpan
quarterdatespanp Day
rdate,
                            forall (m :: * -> *). Day -> TextParser m DateSpan
fromdatespanp Day
rdate,
                            forall (m :: * -> *). Day -> TextParser m DateSpan
todatespanp Day
rdate,
                            forall (m :: * -> *). Day -> TextParser m DateSpan
justdatespanp Day
rdate
                           ]

-- |
-- >>> parsewith (doubledatespanp (fromGregorian 2018 01 01) <* eof) "20180101-201804"
-- Right DateSpan 2018Q1
-- >>> parsewith (doubledatespanp (fromGregorian 2018 01 01) <* eof) "2017..2018"
-- Right DateSpan 2017
-- >>> parsewith (doubledatespanp (fromGregorian 2018 01 01) <* eof) "2017-2018"
-- Right DateSpan 2017
-- >>> parsewith (doubledatespanp (fromGregorian 2018 01 01) <* eof) "2017-01-2018"
-- Right DateSpan 2017
-- >>> parsewith (doubledatespanp (fromGregorian 2018 01 01) <* eof) "2017-01-01-2018"
-- Right DateSpan 2017
doubledatespanp :: Day -> TextParser m DateSpan
doubledatespanp :: forall (m :: * -> *). Day -> TextParser m DateSpan
doubledatespanp Day
rdate = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 SmartDate -> SmartDate -> DateSpan
fromToSpan
    (forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"from" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *). TextParser m SmartDate
smartdate)
    (forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
choice [forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"to", forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"..", forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"-"]
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *). TextParser m SmartDate
smartdate)
  where
    fromToSpan :: SmartDate -> SmartDate -> DateSpan
fromToSpan = Maybe Day -> Maybe Day -> DateSpan
DateSpan forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> SmartDate -> Day
fixSmartDate Day
rdate)

-- |
-- >>> parsewith (quarterdatespanp (fromGregorian 2018 01 01) <* eof) "q1"
-- Right DateSpan 2018Q1
-- >>> parsewith (quarterdatespanp (fromGregorian 2018 01 01) <* eof) "Q1"
-- Right DateSpan 2018Q1
-- >>> parsewith (quarterdatespanp (fromGregorian 2018 01 01) <* eof) "2020q4"
-- Right DateSpan 2020Q4
quarterdatespanp :: Day -> TextParser m DateSpan
quarterdatespanp :: forall (m :: * -> *). Day -> TextParser m DateSpan
quarterdatespanp Day
rdate = do
    Integer
y <- forall {m :: * -> *}. ParsecT HledgerParseErrorData Text m Integer
yearp forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall {a} {b} {c}. (a, b, c) -> a
first3 forall a b. (a -> b) -> a -> b
$ Day -> (Integer, Int, Int)
toGregorian Day
rdate)
    Char
q <- forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char' Char
'q' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
is4Digit
    forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Period -> DateSpan
periodAsDateSpan forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Period
QuarterPeriod Integer
y (Char -> Int
digitToInt Char
q)
  where
    is4Digit :: Char -> Bool
is4Digit Char
c = (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'1') :: Word) forall a. Ord a => a -> a -> Bool
<= Word
3

fromdatespanp :: Day -> TextParser m DateSpan
fromdatespanp :: forall (m :: * -> *). Day -> TextParser m DateSpan
fromdatespanp Day
rdate = SmartDate -> DateSpan
fromSpan forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
choice
    [ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"from" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *). TextParser m SmartDate
smartdate
    , forall (m :: * -> *). TextParser m SmartDate
smartdate forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
choice [forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"..", forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"-"]
    ]
  where
    fromSpan :: SmartDate -> DateSpan
fromSpan SmartDate
b = Maybe Day -> Maybe Day -> DateSpan
DateSpan (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Day -> SmartDate -> Day
fixSmartDate Day
rdate SmartDate
b) forall a. Maybe a
Nothing

todatespanp :: Day -> TextParser m DateSpan
todatespanp :: forall (m :: * -> *). Day -> TextParser m DateSpan
todatespanp Day
rdate =
    forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
choice [forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"to", forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"until", forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"..", forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"-"]
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Maybe Day -> Maybe Day -> DateSpan
DateSpan forall a. Maybe a
Nothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> SmartDate -> Day
fixSmartDate Day
rdate forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). TextParser m SmartDate
smartdate)

justdatespanp :: Day -> TextParser m DateSpan
justdatespanp :: forall (m :: * -> *). Day -> TextParser m DateSpan
justdatespanp Day
rdate =
    forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"in" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces)
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Day -> SmartDate -> DateSpan
spanFromSmartDate Day
rdate forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). TextParser m SmartDate
smartdate)

nulldatespan :: DateSpan
nulldatespan :: DateSpan
nulldatespan = Maybe Day -> Maybe Day -> DateSpan
DateSpan forall a. Maybe a
Nothing forall a. Maybe a
Nothing

-- | A datespan of zero length, that matches no date.
emptydatespan :: DateSpan
emptydatespan :: DateSpan
emptydatespan = Maybe Day -> Maybe Day -> DateSpan
DateSpan (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addDays Integer
1 Day
nulldate) (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

tests_Dates :: TestTree
tests_Dates = [Char] -> [TestTree] -> TestTree
testGroup [Char]
"Dates"
  [ [Char] -> Assertion -> TestTree
testCase [Char]
"weekday" forall a b. (a -> b) -> a -> b
$ do
      Interval -> DateSpan -> [DateSpan]
splitSpan ([Int] -> Interval
DaysOfWeek [Int
1..Int
5]) (Maybe Day -> Maybe Day -> DateSpan
DateSpan (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
01) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
08))
        forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= [ (Maybe Day -> Maybe Day -> DateSpan
DateSpan (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
06 Int
28) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
06 Int
29))
            , (Maybe Day -> Maybe Day -> DateSpan
DateSpan (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
06 Int
29) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
06 Int
30))
            , (Maybe Day -> Maybe Day -> DateSpan
DateSpan (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
06 Int
30) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
01))
            , (Maybe Day -> Maybe Day -> DateSpan
DateSpan (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
01) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
02))
            , (Maybe Day -> Maybe Day -> DateSpan
DateSpan (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
02) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
05))
            -- next week
            , (Maybe Day -> Maybe Day -> DateSpan
DateSpan (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
05) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
06))
            , (Maybe Day -> Maybe Day -> DateSpan
DateSpan (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
06) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
07))
            , (Maybe Day -> Maybe Day -> DateSpan
DateSpan (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
07) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ 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 (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
01) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
08))
        forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= [ (Maybe Day -> Maybe Day -> DateSpan
DateSpan (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
06 Int
28) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
02))
            , (Maybe Day -> Maybe Day -> DateSpan
DateSpan (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
02) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
05))
            -- next week
            , (Maybe Day -> Maybe Day -> DateSpan
DateSpan (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
05) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
09))
            ]

  , [Char] -> Assertion -> TestTree
testCase [Char]
"match dayOfWeek" forall a b. (a -> b) -> a -> b
$ do
      let dayofweek :: Int -> DateSpan -> [DateSpan]
dayofweek Int
n = (Day -> Day)
-> (Integer -> Day -> Day) -> Int -> DateSpan -> [DateSpan]
splitspan (Int -> Day -> Day
nthdayofweekcontaining Int
n) (\Integer
w -> (if Integer
w forall a. Eq a => a -> a -> Bool
== Integer
0 then forall {a}. a -> a
id else forall a. Int -> (a -> a) -> a -> a
applyN (Int
nforall a. Num a => a -> a -> a
-Int
1) Day -> Day
nextday forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> (a -> a) -> a -> a
applyN (forall a. Num a => Integer -> a
fromInteger Integer
w) Day -> Day
nextweek)) Int
1
          matchdow :: DateSpan -> Int -> Assertion
matchdow DateSpan
ds Int
day = Interval -> DateSpan -> [DateSpan]
splitSpan ([Int] -> Interval
DaysOfWeek [Int
day]) DateSpan
ds forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Int -> DateSpan -> [DateSpan]
dayofweek Int
day DateSpan
ds
          ys2021 :: Day
ys2021 = Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
01 Int
01
          ye2021 :: Day
ye2021 = Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
12 Int
31
          ys2022 :: Day
ys2022 = Integer -> Int -> Int -> Day
fromGregorian Integer
2022 Int
01 Int
01
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DateSpan -> Int -> Assertion
matchdow (Maybe Day -> Maybe Day -> DateSpan
DateSpan (forall a. a -> Maybe a
Just Day
ys2021) (forall a. a -> Maybe a
Just Day
ye2021))) [Int
1..Int
7]
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DateSpan -> Int -> Assertion
matchdow (Maybe Day -> Maybe Day -> DateSpan
DateSpan (forall a. a -> Maybe a
Just Day
ys2021) (forall a. a -> Maybe a
Just Day
ys2022))) [Int
1..Int
7]
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DateSpan -> Int -> Assertion
matchdow (Maybe Day -> Maybe Day -> DateSpan
DateSpan (forall a. a -> Maybe a
Just Day
ye2021) (forall a. a -> Maybe a
Just Day
ys2022))) [Int
1..Int
7]

      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DateSpan -> Int -> Assertion
matchdow (Maybe Day -> Maybe Day -> DateSpan
DateSpan (forall a. a -> Maybe a
Just Day
ye2021) forall a. Maybe a
Nothing)) [Int
1..Int
7]
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DateSpan -> Int -> Assertion
matchdow (Maybe Day -> Maybe Day -> DateSpan
DateSpan (forall a. a -> Maybe a
Just Day
ys2022) forall a. Maybe a
Nothing)) [Int
1..Int
7]

      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DateSpan -> Int -> Assertion
matchdow (Maybe Day -> Maybe Day -> DateSpan
DateSpan forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just Day
ye2021))) [Int
1..Int
7]
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DateSpan -> Int -> Assertion
matchdow (Maybe Day -> Maybe Day -> DateSpan
DateSpan forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just Day
ys2022))) [Int
1..Int
7]

  ]