{-# 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
  fromEFDay,
  modifyEFDay,
  getCurrentDay,
  getCurrentMonth,
  getCurrentYear,
  nulldate,
  spanContainsDate,
  periodContainsDate,
  parsedateM,
  showDate,
  showEFDate,
  showDateSpan,
  showDateSpanDebug,
  showDateSpanAbbrev,
  elapsedSeconds,
  prevday,
  periodexprp,
  parsePeriodExpr,
  parsePeriodExpr',
  nulldatespan,
  emptydatespan,
  datesepchar,
  datesepchars,
  isDateSepChar,
  spanStart,
  spanEnd,
  spanStartYear,
  spanEndYear,
  spanYears,
  spansSpan,
  spanIntersect,
  spansIntersect,
  spanDefaultsFrom,
  spanExtend,
  spanUnion,
  spansUnion,
  daysSpan,
  latestSpanContaining,
  smartdate,
  splitSpan,
  spansFromBoundaries,
  groupByDateSpan,
  fixSmartDate,
  fixSmartDateStr,
  fixSmartDateStrEither,
  fixSmartDateStrEither',
  yearp,
  daysInSpan,

  tests_Dates
, intervalBoundaryBefore)
where

import Prelude hiding (Applicative(..))
import Control.Applicative (Applicative(..))
import Control.Applicative.Permutations
import Control.Monad (guard, unless)
import qualified Control.Monad.Fail as Fail (MonadFail, fail)
import Data.Char (digitToInt, isDigit, ord)
import Data.Default (def)
import Data.Foldable (asum)
import Data.Function (on)
import Data.Functor (($>))
import Data.List (elemIndex, group, sort, sortBy)
import Data.Maybe (catMaybes, fromMaybe, isJust, mapMaybe)
import Data.Ord (comparing)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Format hiding (months)
import Data.Time.Calendar
    (Day, addDays, addGregorianYearsClip, addGregorianMonthsClip, diffDays,
     fromGregorian, fromGregorianValid, toGregorian)
import Data.Time.Calendar.OrdinalDate (fromMondayStartWeek, mondayStartWeek)
import Data.Time.Clock (UTCTime, diffUTCTime)
import Data.Time.LocalTime (getZonedTime, localDay, zonedTimeToLocalTime)
import Safe (headErr, 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 " [Char] -> [Char] -> [Char]
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 ([Char] -> Text) -> (Day -> [Char]) -> Day -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> [Char]
forall a. Show a => a -> [Char]
show

showEFDate :: EFDay -> Text
showEFDate :: EFDay -> Text
showEFDate = Day -> Text
showDate (Day -> Text) -> (EFDay -> Day) -> EFDay -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EFDay -> Day
fromEFDay

-- | Render a datespan as a display string, abbreviating into a
-- compact form if possible.
-- Warning, hides whether dates are Exact or Flex.
showDateSpan :: DateSpan -> Text
showDateSpan :: DateSpan -> Text
showDateSpan = Period -> Text
showPeriod (Period -> Text) -> (DateSpan -> Period) -> DateSpan -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DateSpan -> Period
dateSpanAsPeriod

-- | Show a DateSpan with its begin/end dates, exact or flex.
showDateSpanDebug :: DateSpan -> String
showDateSpanDebug :: DateSpan -> [Char]
showDateSpanDebug (DateSpan Maybe EFDay
b Maybe EFDay
e)= [Char]
"DateSpan (" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Maybe EFDay -> [Char]
forall a. Show a => a -> [Char]
show Maybe EFDay
b [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
") (" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Maybe EFDay -> [Char]
forall a. Show a => a -> [Char]
show Maybe EFDay
e [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
")"

-- | Like showDateSpan, but show month spans as just the abbreviated month name
-- in the current locale.
showDateSpanAbbrev :: DateSpan -> Text
showDateSpanAbbrev :: DateSpan -> Text
showDateSpanAbbrev = Period -> Text
showPeriodAbbrev (Period -> Text) -> (DateSpan -> Period) -> DateSpan -> Text
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 (LocalTime -> Day) -> (ZonedTime -> LocalTime) -> ZonedTime -> Day
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ZonedTime -> LocalTime
zonedTimeToLocalTime (ZonedTime -> Day) -> IO ZonedTime -> IO Day
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ZonedTime
getZonedTime

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

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

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

spanStart :: DateSpan -> Maybe Day
spanStart :: DateSpan -> Maybe Day
spanStart (DateSpan Maybe EFDay
d Maybe EFDay
_) = EFDay -> Day
fromEFDay (EFDay -> Day) -> Maybe EFDay -> Maybe Day
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe EFDay
d

spanEnd :: DateSpan -> Maybe Day
spanEnd :: DateSpan -> Maybe Day
spanEnd (DateSpan Maybe EFDay
_ Maybe EFDay
d) = EFDay -> Day
fromEFDay (EFDay -> Day) -> Maybe EFDay -> Maybe Day
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe EFDay
d

spanStartDate :: DateSpan -> Maybe EFDay
spanStartDate :: DateSpan -> Maybe EFDay
spanStartDate (DateSpan Maybe EFDay
d Maybe EFDay
_) = Maybe EFDay
d

spanEndDate :: DateSpan -> Maybe EFDay
spanEndDate :: DateSpan -> Maybe EFDay
spanEndDate (DateSpan Maybe EFDay
_ Maybe EFDay
d) = Maybe EFDay
d

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

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

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

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

-- | Get overall span enclosing multiple sequentially ordered spans.
-- The start and end date will be exact or flexible depending on
-- the first span's start date and last span's end date.
spansSpan :: [DateSpan] -> DateSpan
spansSpan :: [DateSpan] -> DateSpan
spansSpan [DateSpan]
spans = Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (DateSpan -> Maybe EFDay
spanStartDate (DateSpan -> Maybe EFDay) -> Maybe DateSpan -> Maybe EFDay
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [DateSpan] -> Maybe DateSpan
forall a. [a] -> Maybe a
headMay [DateSpan]
spans) (DateSpan -> Maybe EFDay
spanEndDate (DateSpan -> Maybe EFDay) -> Maybe DateSpan -> Maybe EFDay
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [DateSpan] -> Maybe DateSpan
forall a. [a] -> Maybe a
lastMay [DateSpan]
spans)

-- | Split a DateSpan into consecutive exact spans of the specified Interval.
-- 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.
--
-- ==== Date adjustment
-- Some intervals respect the "adjust" flag (years, quarters, months, weeks, every Nth weekday
-- of month seem to be the ones that need it). This will move the start date earlier, if needed,
-- to the previous natural interval boundary (first of year, first of quarter, first of month,
-- monday, previous Nth weekday of month). Related: #1982 #2218
--
-- The end date is always moved later if needed to the next natural interval boundary,
-- so that the last period is the same length as the others.
--
-- ==== Examples
-- >>> let t i y1 m1 d1 y2 m2 d2 = splitSpan True i $ DateSpan (Just $ Flex $ fromGregorian y1 m1 d1) (Just $ Flex $ 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 True (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 2008-W01,DateSpan 2008-W02,DateSpan 2008-W03]
-- >>> t (Weeks 2) 2008 01 01 2008 01 15
-- [DateSpan 2007-12-31..2008-01-13,DateSpan 2008-01-14..2008-01-27]
-- >>> t (MonthDay 2) 2008 01 01 2008   04 01
-- [DateSpan 2008-01-02..2008-02-01,DateSpan 2008-02-02..2008-03-01,DateSpan 2008-03-02..2008-04-01]
-- >>> t (NthWeekdayOfMonth 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 (MonthAndDay 11 29) 2012 10 01 2013 10 15
-- [DateSpan 2012-11-29..2013-11-28]
--
splitSpan :: Bool -> Interval -> DateSpan -> [DateSpan]
splitSpan :: Bool -> Interval -> DateSpan -> [DateSpan]
splitSpan Bool
_      Interval
_                        (DateSpan Maybe EFDay
Nothing Maybe EFDay
Nothing) = [Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan Maybe EFDay
forall a. Maybe a
Nothing Maybe EFDay
forall a. Maybe a
Nothing]
splitSpan Bool
_      Interval
_                        DateSpan
ds | DateSpan -> Bool
isEmptySpan DateSpan
ds = []
splitSpan Bool
_      Interval
_                        ds :: DateSpan
ds@(DateSpan (Just EFDay
s) (Just EFDay
e)) | EFDay
s EFDay -> EFDay -> Bool
forall a. Eq a => a -> a -> Bool
== EFDay
e = [DateSpan
ds]
splitSpan Bool
_      Interval
NoInterval               DateSpan
ds = [DateSpan
ds]
splitSpan Bool
_      (Days Int
n)                 DateSpan
ds = (Day -> Day)
-> (Integer -> Day -> Day) -> Int -> DateSpan -> [DateSpan]
splitspan Day -> Day
forall a. a -> a
id Integer -> Day -> Day
addDays Int
n DateSpan
ds
splitSpan Bool
adjust (Weeks Int
n)                DateSpan
ds = (Day -> Day)
-> (Integer -> Day -> Day) -> Int -> DateSpan -> [DateSpan]
splitspan (if Bool
adjust then Day -> Day
startofweek    else Day -> Day
forall a. a -> a
id) Integer -> Day -> Day
addDays                 (Int
7Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
n) DateSpan
ds
splitSpan Bool
adjust (Months Int
n)               DateSpan
ds = (Day -> Day)
-> (Integer -> Day -> Day) -> Int -> DateSpan -> [DateSpan]
splitspan (if Bool
adjust then Day -> Day
startofmonth   else Day -> Day
forall a. a -> a
id) Integer -> Day -> Day
addGregorianMonthsClip  Int
n     DateSpan
ds
splitSpan Bool
adjust (Quarters Int
n)             DateSpan
ds = (Day -> Day)
-> (Integer -> Day -> Day) -> Int -> DateSpan -> [DateSpan]
splitspan (if Bool
adjust then Day -> Day
startofquarter else Day -> Day
forall a. a -> a
id) Integer -> Day -> Day
addGregorianMonthsClip  (Int
3Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
n) DateSpan
ds
splitSpan Bool
adjust (Years Int
n)                DateSpan
ds = (Day -> Day)
-> (Integer -> Day -> Day) -> Int -> DateSpan -> [DateSpan]
splitspan (if Bool
adjust then Day -> Day
startofyear    else Day -> Day
forall a. a -> a
id) Integer -> Day -> Day
addGregorianYearsClip   Int
n     DateSpan
ds
splitSpan Bool
adjust (NthWeekdayOfMonth Int
n Int
wd) DateSpan
ds = (Day -> Day)
-> (Integer -> Day -> Day) -> Int -> DateSpan -> [DateSpan]
splitspan (if Bool
adjust then Day -> Day
prevstart else Day -> Day
nextstart) Integer -> Day -> Day
advancemonths          Int
1     DateSpan
ds
  where
    prevstart :: Day -> Day
prevstart = Int -> Int -> Day -> Day
prevNthWeekdayOfMonth Int
n Int
wd
    nextstart :: Day -> Day
nextstart = Int -> Int -> Day -> Day
nextNthWeekdayOfMonth Int
n Int
wd
    advancemonths :: Integer -> Day -> Day
advancemonths Integer
0 = Day -> Day
forall a. a -> a
id
    advancemonths Integer
m = Int -> Int -> Day -> Day
advanceToNthWeekday Int
n Int
wd (Day -> Day) -> (Day -> Day) -> Day -> Day
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> Day
startofmonth (Day -> Day) -> (Day -> Day) -> Day -> Day
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Day -> Day
addGregorianMonthsClip Integer
m
splitSpan Bool
_      (MonthDay Int
dom)           DateSpan
ds = (Day -> Day)
-> (Integer -> Day -> Day) -> Int -> DateSpan -> [DateSpan]
splitspan (Int -> Day -> Day
nextnthdayofmonth Int
dom) (Int -> Integer -> Day -> Day
addGregorianMonthsToMonthday Int
dom) Int
1 DateSpan
ds
splitSpan Bool
_      (MonthAndDay Int
m Int
d)        DateSpan
ds = (Day -> Day)
-> (Integer -> Day -> Day) -> Int -> DateSpan -> [DateSpan]
splitspan (Int -> Int -> Day -> Day
nextmonthandday Int
m Int
d)   (Integer -> Day -> Day
addGregorianYearsClip)            Int
1 DateSpan
ds
splitSpan Bool
_      (DaysOfWeek [])          DateSpan
ds = [DateSpan
ds]
splitSpan Bool
_      (DaysOfWeek days :: [Int]
days@(Int
n:[Int]
_))  DateSpan
ds = Day -> [Day] -> [DateSpan]
spansFromBoundaries Day
e [Day]
bdrys
  where
    (Day
s, Day
e) = (Day -> Day) -> (Day -> Day) -> DateSpan -> (Day, Day)
dateSpanSplitLimits (Int -> Day -> Day
nthdayofweekcontaining Int
n) Day -> Day
nextday DateSpan
ds
    -- can't show this when debugging, it'll hang:
    bdrys :: [Day]
bdrys = (Integer -> [Day]) -> [Integer] -> [Day]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (((Day -> Day) -> [Day] -> [Day]) -> [Day] -> (Day -> Day) -> [Day]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Day -> Day) -> [Day] -> [Day]
forall a b. (a -> b) -> [a] -> [b]
map [Day]
starts ((Day -> Day) -> [Day])
-> (Integer -> Day -> Day) -> Integer -> [Day]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Day -> Day
addDays) [Integer
0,Integer
7..]
    -- The first representative of each weekday
    starts :: [Day]
starts = (Int -> Day) -> [Int] -> [Day]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
d -> Integer -> Day -> Day
addDays (Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n) (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ Int -> Day -> Day
nthdayofweekcontaining Int
n Day
s) [Int]
days

-- Like addGregorianMonthsClip, add one month to the given date, clipping when needed
-- to fit it within the next month's length. But also, keep a target day of month in mind,
-- and revert to that or as close to it as possible in subsequent longer months.
-- Eg, using it to step through 31sts gives 1/31, 2/28, 3/31, 4/30, 5/31..
addGregorianMonthsToMonthday :: MonthDay -> Integer -> Day -> Day
addGregorianMonthsToMonthday :: Int -> Integer -> Day -> Day
addGregorianMonthsToMonthday Int
dom Integer
n Day
d =
  let (Integer
y,Int
m,Int
_) = Day -> (Integer, Int, Int)
toGregorian (Day -> (Integer, Int, Int)) -> Day -> (Integer, Int, Int)
forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addGregorianMonthsClip Integer
n Day
d
  in Integer -> Int -> Int -> Day
fromGregorian Integer
y Int
m Int
dom

-- Split the given span into exact spans using the provided helper functions:
--
-- 1. The start function is used to adjust the provided span's start date to get the first sub-span's start date.
--
-- 2. The next function is used to calculate subsequent sub-spans' start dates, possibly with stride increased by a multiplier.
--    It should handle spans of varying length, eg when splitting on "every 31st of month",
--    it adjusts to 28/29/30 in short months but returns to 31 in the long months.
--
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
next 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
next (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
mult)) DateSpan
ds
    bdrys :: [Day]
bdrys = (Int -> Day -> Day) -> [Int] -> Day -> [Day]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Integer -> Day -> Day
next (Integer -> Day -> Day) -> (Int -> Integer) -> Int -> Day -> Day
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a. Integral a => a -> Integer
toInteger) [Int
0,Int
mult..] (Day -> [Day]) -> Day -> [Day]
forall a b. (a -> b) -> a -> b
$ Day -> Day
start Day
s

-- | Fill in missing start/end dates 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 EFDay
s) (Just EFDay
e)) = (Day -> Day
start (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ EFDay -> Day
fromEFDay EFDay
s, EFDay -> Day
fromEFDay EFDay
e)
dateSpanSplitLimits Day -> Day
start Day -> Day
next (DateSpan (Just EFDay
s) Maybe EFDay
Nothing)  = (Day -> Day
start (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ EFDay -> Day
fromEFDay EFDay
s, Day -> Day
next (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ Day -> Day
start (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ EFDay -> Day
fromEFDay EFDay
s)
dateSpanSplitLimits Day -> Day
start Day -> Day
next (DateSpan Maybe EFDay
Nothing  (Just EFDay
e)) = (Day -> Day
start (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ EFDay -> Day
fromEFDay EFDay
e, Day -> Day
next (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ Day -> Day
start (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ EFDay -> Day
fromEFDay EFDay
e)
dateSpanSplitLimits Day -> Day
_     Day -> Day
_    (DateSpan Maybe EFDay
Nothing   Maybe EFDay
Nothing) = [Char] -> (Day, Day)
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 exact '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 = (Day -> Day -> DateSpan) -> [Day] -> [Day] -> [DateSpan]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (Maybe EFDay -> Maybe EFDay -> DateSpan)
-> (Day -> Maybe EFDay) -> Day -> Day -> DateSpan
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> (Day -> EFDay) -> Day -> Maybe EFDay
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> EFDay
Exact)) ((Day -> Bool) -> [Day] -> [Day]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Day -> Day -> Bool
forall a. Ord a => a -> a -> Bool
< Day
e) [Day]
bdrys) ([Day] -> [DateSpan]) -> [Day] -> [DateSpan]
forall a b. (a -> b) -> a -> b
$ Int -> [Day] -> [Day]
forall a. Int -> [a] -> [a]
drop Int
1 [Day]
bdrys

-- | 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 EFDay
d1) (Just EFDay
d2)) = Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ Day -> Day -> Integer
diffDays (EFDay -> Day
fromEFDay EFDay
d2) (EFDay -> Day
fromEFDay EFDay
d1)
daysInSpan DateSpan
_ = Maybe Integer
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 EFDay
s) (Just EFDay
e)) = EFDay
e EFDay -> EFDay -> Bool
forall a. Ord a => a -> a -> Bool
<= EFDay
s
isEmptySpan DateSpan
_                            = Bool
False

-- | Does the span include the given date ?
spanContainsDate :: DateSpan -> Day -> Bool
spanContainsDate :: DateSpan -> Day -> Bool
spanContainsDate (DateSpan Maybe EFDay
Nothing Maybe EFDay
Nothing)   Day
_ = Bool
True
spanContainsDate (DateSpan Maybe EFDay
Nothing (Just EFDay
e))  Day
d = Day
d Day -> Day -> Bool
forall a. Ord a => a -> a -> Bool
< EFDay -> Day
fromEFDay EFDay
e
spanContainsDate (DateSpan (Just EFDay
b) Maybe EFDay
Nothing)  Day
d = Day
d Day -> Day -> Bool
forall a. Ord a => a -> a -> Bool
>= EFDay -> Day
fromEFDay EFDay
b
spanContainsDate (DateSpan (Just EFDay
b) (Just EFDay
e)) Day
d = Day
d Day -> Day -> Bool
forall a. Ord a => a -> a -> Bool
>= EFDay -> Day
fromEFDay EFDay
b Bool -> Bool -> Bool
&& Day
d Day -> Day -> Bool
forall a. Ord a => a -> a -> Bool
< EFDay -> Day
fromEFDay EFDay
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
    ([(Day, a)] -> [(DateSpan, [a])])
-> ([a] -> [(Day, a)]) -> [a] -> [(DateSpan, [a])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Day, a) -> Bool) -> [(Day, a)] -> [(Day, a)]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Day -> Bool
beforeStart (Day -> Bool) -> ((Day, a) -> Day) -> (Day, a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Day, a) -> Day
forall a b. (a, b) -> a
fst)
    ([(Day, a)] -> [(Day, a)])
-> ([a] -> [(Day, a)]) -> [a] -> [(Day, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Day, a) -> (Day, a) -> Ordering) -> [(Day, a)] -> [(Day, a)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Day, a) -> Day) -> (Day, a) -> (Day, a) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Day, a) -> Day
forall a b. (a, b) -> a
fst)
    ([(Day, a)] -> [(Day, a)])
-> ([a] -> [(Day, a)]) -> [a] -> [(Day, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> (Day, a)) -> [a] -> [(Day, a)]
forall a b. (a -> b) -> [a] -> [b]
map (\a
x -> (a -> Day
date a
x, a
x))
  where
    groupByCols :: [DateSpan] -> [(Day, a)] -> [(DateSpan, [a])]
groupByCols []     [(Day, a)]
_  = []
    groupByCols (DateSpan
c:[DateSpan]
cs) [] = if Bool
showempty then (DateSpan
c, []) (DateSpan, [a]) -> [(DateSpan, [a])] -> [(DateSpan, [a])]
forall a. a -> [a] -> [a]
: [DateSpan] -> [(Day, a)] -> [(DateSpan, [a])]
groupByCols [DateSpan]
cs [] else []
    groupByCols (DateSpan
c:[DateSpan]
cs) [(Day, a)]
ps = (DateSpan
c, ((Day, a) -> a) -> [(Day, a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (Day, a) -> a
forall a b. (a, b) -> b
snd [(Day, a)]
colps) (DateSpan, [a]) -> [(DateSpan, [a])] -> [(DateSpan, [a])]
forall a. a -> [a] -> [a]
: [DateSpan] -> [(Day, a)] -> [(DateSpan, [a])]
groupByCols [DateSpan]
cs [(Day, a)]
laterps
      where ([(Day, a)]
colps, [(Day, a)]
laterps) = ((Day, a) -> Bool) -> [(Day, a)] -> ([(Day, a)], [(Day, a)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((DateSpan -> Maybe Day
spanEnd DateSpan
c Maybe Day -> Maybe Day -> Bool
forall a. Ord a => a -> a -> Bool
>) (Maybe Day -> Bool) -> ((Day, a) -> Maybe Day) -> (Day, a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> Maybe Day
forall a. a -> Maybe a
Just (Day -> Maybe Day) -> ((Day, a) -> Day) -> (Day, a) -> Maybe Day
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Day, a) -> Day
forall a b. (a, b) -> a
fst) [(Day, a)]
ps

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

-- | 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 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 intersection of two datespans.
--
-- For non-intersecting spans, gives an empty span beginning on the second's start date:
-- >>> DateSpan (Just $ Flex $ fromGregorian 2018 01 01) (Just $ Flex $ fromGregorian 2018 01 03) `spanIntersect` DateSpan (Just $ Flex $ fromGregorian 2018 01 03) (Just $ Flex $ fromGregorian 2018 01 05)
-- DateSpan 2018-01-03..2018-01-02
spanIntersect :: DateSpan -> DateSpan -> DateSpan
spanIntersect (DateSpan Maybe EFDay
b1 Maybe EFDay
e1) (DateSpan Maybe EFDay
b2 Maybe EFDay
e2) = Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (Maybe EFDay -> Maybe EFDay -> Maybe EFDay
laterDefinite Maybe EFDay
b1 Maybe EFDay
b2) (Maybe EFDay -> Maybe EFDay -> Maybe EFDay
earlierDefinite Maybe EFDay
e1 Maybe EFDay
e2)

-- | Fill any unspecified dates in the first span with the dates from
-- the second one (if specified there). Sort of a one-way spanIntersect.
spanDefaultsFrom :: DateSpan -> DateSpan -> DateSpan
spanDefaultsFrom (DateSpan Maybe EFDay
a1 Maybe EFDay
b1) (DateSpan Maybe EFDay
a2 Maybe EFDay
b2) = Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan Maybe EFDay
a Maybe EFDay
b
    where a :: Maybe EFDay
a = if Maybe EFDay -> Bool
forall a. Maybe a -> Bool
isJust Maybe EFDay
a1 then Maybe EFDay
a1 else Maybe EFDay
a2
          b :: Maybe EFDay
b = if Maybe EFDay -> Bool
forall a. Maybe a -> Bool
isJust Maybe EFDay
b1 then Maybe EFDay
b1 else Maybe EFDay
b2

-- | Calculate the union of two datespans.
-- If either span is open-ended, the union will be too.
--
-- >>> ys2024 = fromGregorian 2024 01 01
-- >>> ys2025 = fromGregorian 2025 01 01
-- >>> to2024 = DateSpan Nothing               (Just $ Exact ys2024)
-- >>> in2024 = DateSpan (Just $ Exact ys2024) (Just $ Exact ys2025)
-- >>> spanUnion to2024 in2024
-- DateSpan ..2024-12-31
-- >>> spanUnion in2024 to2024
-- DateSpan ..2024-12-31
spanUnion :: DateSpan -> DateSpan -> DateSpan
spanUnion (DateSpan Maybe EFDay
b1 Maybe EFDay
e1) (DateSpan Maybe EFDay
b2 Maybe EFDay
e2) = Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (Maybe EFDay -> Maybe EFDay -> Maybe EFDay
earlier Maybe EFDay
b1 Maybe EFDay
b2) (Maybe EFDay -> Maybe EFDay -> Maybe EFDay
later Maybe EFDay
e1 Maybe EFDay
e2)

-- | Extend the first span to include any definite end dates of the second.
-- Unlike spanUnion, open ends in the second are ignored.
-- If the first span was open-ended, it still will be after being extended.
--
-- >>> ys2024 = fromGregorian 2024 01 01
-- >>> ys2025 = fromGregorian 2025 01 01
-- >>> to2024 = DateSpan Nothing               (Just $ Exact ys2024)
-- >>> all2024 = DateSpan (Just $ Exact ys2024) (Just $ Exact ys2025)
-- >>> partof2024 = DateSpan (Just $ Exact $ fromGregorian 2024 03 01) (Just $ Exact $ fromGregorian 2024 09 01)
-- >>> spanExtend to2024 all2024
-- DateSpan 2024
-- >>> spanExtend all2024 to2024
-- DateSpan 2024
-- >>> spanExtend partof2024 all2024
-- DateSpan 2024
-- >>> spanExtend all2024 partof2024
-- DateSpan 2024
--
spanExtend :: DateSpan -> DateSpan -> DateSpan
spanExtend (DateSpan Maybe EFDay
b1 Maybe EFDay
e1) (DateSpan Maybe EFDay
b2 Maybe EFDay
e2) = Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (Maybe EFDay -> Maybe EFDay -> Maybe EFDay
earlierDefinite Maybe EFDay
b1 Maybe EFDay
b2) (Maybe EFDay -> Maybe EFDay -> Maybe EFDay
laterDefinite Maybe EFDay
e1 Maybe EFDay
e2)

-- | Pick the earlier of two DateSpan starts, treating Nothing as infinitely early.
-- An Exact and Flex with the same date are considered equal; the first argument wins.
earlier :: Maybe EFDay -> Maybe EFDay -> Maybe EFDay
earlier :: Maybe EFDay -> Maybe EFDay -> Maybe EFDay
earlier = Maybe EFDay -> Maybe EFDay -> Maybe EFDay
forall a. Ord a => a -> a -> a
min

-- | Pick the later of two DateSpan starts, treating Nothing as infinitely late.
-- An Exact and Flex with the same date are considered equal; the second argument wins.
later :: Maybe EFDay -> Maybe EFDay -> Maybe EFDay
later :: Maybe EFDay -> Maybe EFDay -> Maybe EFDay
later Maybe EFDay
_ Maybe EFDay
Nothing = Maybe EFDay
forall a. Maybe a
Nothing
later Maybe EFDay
Nothing Maybe EFDay
_ = Maybe EFDay
forall a. Maybe a
Nothing
later Maybe EFDay
d1 Maybe EFDay
d2     = Maybe EFDay -> Maybe EFDay -> Maybe EFDay
forall a. Ord a => a -> a -> a
max Maybe EFDay
d1 Maybe EFDay
d2

-- | Pick the earlier of two DateSpan ends that is a definite date (if any).
-- An Exact and Flex with the same date are considered equal; the first argument wins.
earlierDefinite :: Maybe EFDay -> Maybe EFDay -> Maybe EFDay
earlierDefinite :: Maybe EFDay -> Maybe EFDay -> Maybe EFDay
earlierDefinite Maybe EFDay
d1 Maybe EFDay
Nothing = Maybe EFDay
d1
earlierDefinite Maybe EFDay
Nothing Maybe EFDay
d2 = Maybe EFDay
d2
earlierDefinite Maybe EFDay
d1 Maybe EFDay
d2      = Maybe EFDay -> Maybe EFDay -> Maybe EFDay
forall a. Ord a => a -> a -> a
min Maybe EFDay
d1 Maybe EFDay
d2

-- | Pick the later of two DateSpan ends that is a definite date (if any).
-- An Exact and Flex with the same date are considered equal; the second argument wins.
laterDefinite :: Maybe EFDay -> Maybe EFDay -> Maybe EFDay
laterDefinite :: Maybe EFDay -> Maybe EFDay -> Maybe EFDay
laterDefinite Maybe EFDay
d1 Maybe EFDay
Nothing = Maybe EFDay
d1
laterDefinite Maybe EFDay
Nothing Maybe EFDay
d2 = Maybe EFDay
d2
laterDefinite Maybe EFDay
d1 Maybe EFDay
d2      = Maybe EFDay -> Maybe EFDay -> Maybe EFDay
forall a. Ord a => a -> a -> a
max Maybe EFDay
d1 Maybe EFDay
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 EFDay -> Maybe EFDay -> DateSpan
DateSpan (Day -> EFDay
Exact (Day -> EFDay) -> Maybe Day -> Maybe EFDay
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Day] -> Maybe Day
forall a. Ord a => [a] -> Maybe a
minimumMay [Day]
ds) (Day -> EFDay
Exact (Day -> EFDay) -> (Day -> Day) -> Day -> EFDay
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Day -> Day
addDays Integer
1 (Day -> EFDay) -> Maybe Day -> Maybe EFDay
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Day] -> Maybe Day
forall a. Ord a => [a] -> Maybe a
maximumMay [Day]
ds)

-- | 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 <- DateSpan -> Set DateSpan -> Maybe DateSpan
forall a. Ord a => a -> Set a -> Maybe a
Set.lookupLT DateSpan
supSpan Set DateSpan
spanSet
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ DateSpan -> Day -> Bool
spanContainsDate DateSpan
spn Day
day
        DateSpan -> Maybe DateSpan
forall a. a -> Maybe a
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 EFDay -> Maybe EFDay -> DateSpan
DateSpan (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addDays Integer
1 Day
day) Maybe EFDay
forall a. Maybe a
Nothing

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

-- | 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 = Parsec HledgerParseErrorData Text (Interval, DateSpan)
-> Text -> Either HledgerParseErrors (Interval, DateSpan)
forall e a.
Parsec e Text a -> Text -> Either (ParseErrorBundle Text e) a
parsewith (Day -> Parsec HledgerParseErrorData Text (Interval, DateSpan)
forall (m :: * -> *). Day -> TextParser m (Interval, DateSpan)
periodexprp Day
refdate Parsec HledgerParseErrorData Text (Interval, DateSpan)
-> ParsecT HledgerParseErrorData Text Identity ()
-> Parsec HledgerParseErrorData Text (Interval, DateSpan)
forall a b.
ParsecT HledgerParseErrorData Text Identity a
-> ParsecT HledgerParseErrorData Text Identity b
-> ParsecT HledgerParseErrorData Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT HledgerParseErrorData Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) (Text -> Text
T.toLower Text
s)

-- | Like parsePeriodExpr, but call error' on failure.
parsePeriodExpr' :: Day -> Text -> (Interval, DateSpan)
parsePeriodExpr' :: Day -> Text -> (Interval, DateSpan)
parsePeriodExpr' Day
refdate Text
s =
  (HledgerParseErrors -> (Interval, DateSpan))
-> ((Interval, DateSpan) -> (Interval, DateSpan))
-> Either HledgerParseErrors (Interval, DateSpan)
-> (Interval, DateSpan)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Char] -> (Interval, DateSpan)
forall a. [Char] -> a
error' ([Char] -> (Interval, DateSpan))
-> (HledgerParseErrors -> [Char])
-> HledgerParseErrors
-> (Interval, DateSpan)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"failed to parse:" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([Char] -> [Char])
-> (HledgerParseErrors -> [Char]) -> HledgerParseErrors -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HledgerParseErrors -> [Char]
customErrorBundlePretty) (Interval, DateSpan) -> (Interval, DateSpan)
forall a. a -> a
id (Either HledgerParseErrors (Interval, DateSpan)
 -> (Interval, DateSpan))
-> Either HledgerParseErrors (Interval, DateSpan)
-> (Interval, DateSpan)
forall a b. (a -> b) -> a -> b
$  -- 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 EFDay -> Maybe EFDay -> DateSpan
DateSpan (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just EFDay
b) (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just EFDay
e)
    where
      (Integer
ry,Int
rm,Int
_) = Day -> (Integer, Int, Int)
toGregorian Day
refdate
      (EFDay
b,EFDay
e) = SmartDate -> (EFDay, EFDay)
span' SmartDate
sdate
        where
          span' :: SmartDate -> (EFDay, EFDay)
          span' :: SmartDate -> (EFDay, EFDay)
span' (SmartCompleteDate Day
day)       = (Day -> EFDay
Exact Day
day, Day -> EFDay
Exact (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Day -> Day
nextday Day
day)
          span' (SmartAssumeStart Integer
y Maybe Int
Nothing)  = (Day -> EFDay
Flex (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Day -> Day
startofyear Day
day, Day -> EFDay
Flex (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Day -> Day
nextyear Day
day) where day :: Day
day = Integer -> Int -> Int -> Day
fromGregorian Integer
y Int
1 Int
1
          span' (SmartAssumeStart Integer
y (Just Int
m)) = (Day -> EFDay
Flex (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Day -> Day
startofmonth Day
day, Day -> EFDay
Flex (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Day -> Day
nextmonth Day
day) where day :: Day
day = Integer -> Int -> Int -> Day
fromGregorian Integer
y Int
m Int
1
          span' (SmartFromReference Maybe Int
m Int
d)      = (Day -> EFDay
Exact Day
day, Day -> EFDay
Exact (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Day -> Day
nextday Day
day) where day :: Day
day = Integer -> Int -> Int -> Day
fromGregorian Integer
ry (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
rm Maybe Int
m) Int
d
          span' (SmartMonth Int
m)                = (Day -> EFDay
Flex (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Day -> Day
startofmonth Day
day, Day -> EFDay
Flex (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Day -> Day
nextmonth Day
day) where day :: Day
day = Integer -> Int -> Int -> Day
fromGregorian Integer
ry Int
m Int
1
          span' (SmartRelative Integer
n SmartInterval
Day)         = (Day -> EFDay
Exact (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addDays Integer
n Day
refdate, Day -> EFDay
Exact (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addDays (Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1) Day
refdate)
          span' (SmartRelative Integer
n SmartInterval
Week)        = (Day -> EFDay
Flex (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addDays (Integer
7Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
n) Day
d, Day -> EFDay
Flex (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addDays (Integer
7Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
7) Day
d) where d :: Day
d = Day -> Day
thisweek Day
refdate
          span' (SmartRelative Integer
n SmartInterval
Month)       = (Day -> EFDay
Flex (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addGregorianMonthsClip Integer
n Day
d, Day -> EFDay
Flex (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addGregorianMonthsClip (Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1) Day
d) where d :: Day
d = Day -> Day
thismonth Day
refdate
          span' (SmartRelative Integer
n SmartInterval
Quarter)     = (Day -> EFDay
Flex (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addGregorianMonthsClip (Integer
3Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
n) Day
d, Day -> EFDay
Flex (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addGregorianMonthsClip (Integer
3Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
3) Day
d) where d :: Day
d = Day -> Day
thisquarter Day
refdate
          span' (SmartRelative Integer
n SmartInterval
Year)        = (Day -> EFDay
Flex (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addGregorianYearsClip Integer
n Day
d, Day -> EFDay
Flex (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addGregorianYearsClip (Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1) Day
d) where d :: Day
d = Day -> Day
thisyear Day
refdate

-- 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 =
  (HledgerParseErrors -> Text)
-> (Text -> Text) -> Either HledgerParseErrors Text -> Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Char] -> Text
forall a. [Char] -> a
error' ([Char] -> Text)
-> (HledgerParseErrors -> [Char]) -> HledgerParseErrors -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"could not parse date %s %s" (Text -> [Char]
forall a. Show a => a -> [Char]
show Text
s) ([Char] -> [Char])
-> (HledgerParseErrors -> [Char]) -> HledgerParseErrors -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HledgerParseErrors -> [Char]
forall a. Show a => a -> [Char]
show) Text -> Text
forall a. a -> a
id (Either HledgerParseErrors Text -> Text)
-> Either HledgerParseErrors Text -> Text
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 = (EFDay -> Text)
-> Either HledgerParseErrors EFDay
-> Either HledgerParseErrors Text
forall a b.
(a -> b)
-> Either HledgerParseErrors a -> Either HledgerParseErrors b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap EFDay -> Text
showEFDate (Either HledgerParseErrors EFDay -> Either HledgerParseErrors Text)
-> (Text -> Either HledgerParseErrors EFDay)
-> Text
-> Either HledgerParseErrors Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> Text -> Either HledgerParseErrors EFDay
fixSmartDateStrEither' Day
d

fixSmartDateStrEither' :: Day -> Text -> Either HledgerParseErrors EFDay
fixSmartDateStrEither' :: Day -> Text -> Either HledgerParseErrors EFDay
fixSmartDateStrEither' Day
d Text
s = case Parsec HledgerParseErrorData Text SmartDate
-> Text -> Either HledgerParseErrors SmartDate
forall e a.
Parsec e Text a -> Text -> Either (ParseErrorBundle Text e) a
parsewith Parsec HledgerParseErrorData Text SmartDate
forall (m :: * -> *). TextParser m SmartDate
smartdateonly (Text -> Text
T.toLower Text
s) of
                               Right SmartDate
sd -> EFDay -> Either HledgerParseErrors EFDay
forall a b. b -> Either a b
Right (EFDay -> Either HledgerParseErrors EFDay)
-> EFDay -> Either HledgerParseErrors EFDay
forall a b. (a -> b) -> a -> b
$ Day -> SmartDate -> EFDay
fixSmartDate Day
d SmartDate
sd
                               Left HledgerParseErrors
e -> HledgerParseErrors -> Either HledgerParseErrors EFDay
forall a b. a -> Either a b
Left HledgerParseErrors
e

-- | Convert a SmartDate to a specific date using the provided reference date.
-- This date will be exact or flexible depending on whether the day was
-- specified exactly. (Missing least-significant parts produces a flex 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 -> EFDay
fixSmartDate :: Day -> SmartDate -> EFDay
fixSmartDate Day
refdate = SmartDate -> EFDay
fix
  where
    fix :: SmartDate -> EFDay
    fix :: SmartDate -> EFDay
fix (SmartCompleteDate Day
d)     = Day -> EFDay
Exact Day
d
    fix (SmartAssumeStart Integer
y Maybe Int
m)    = Day -> EFDay
Flex  (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
y (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
1 Maybe Int
m) Int
1
    fix (SmartFromReference Maybe Int
m Int
d)  = Day -> EFDay
Exact (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
ry (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
rm Maybe Int
m) Int
d
    fix (SmartMonth Int
m)            = Day -> EFDay
Flex  (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
ry Int
m Int
1
    fix (SmartRelative Integer
n SmartInterval
Day)     = Day -> EFDay
Exact (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addDays Integer
n Day
refdate
    fix (SmartRelative Integer
n SmartInterval
Week)    = Day -> EFDay
Flex  (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addDays (Integer
7Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
n) (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ Day -> Day
thisweek Day
refdate
    fix (SmartRelative Integer
n SmartInterval
Month)   = Day -> EFDay
Flex  (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addGregorianMonthsClip Integer
n (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ Day -> Day
thismonth Day
refdate
    fix (SmartRelative Integer
n SmartInterval
Quarter) = Day -> EFDay
Flex  (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addGregorianMonthsClip (Integer
3Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
n) (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ Day -> Day
thisquarter Day
refdate
    fix (SmartRelative Integer
n SmartInterval
Year)    = Day -> EFDay
Flex  (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addGregorianYearsClip Integer
n (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ Day -> Day
thisyear Day
refdate
    (Integer
ry, Int
rm, Int
_) = Day -> (Integer, Int, Int)
toGregorian Day
refdate

prevday :: Day -> Day
prevday :: Day -> Day
prevday = Integer -> Day -> Day
addDays (-Integer
1)
nextday :: Day -> Day
nextday = Integer -> Day -> Day
addDays Integer
1

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

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

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

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

-- Get the natural start for the given interval that falls on or before the given day,
-- when applicable. Works for Weeks, Months, Quarters, Years, eg.
intervalBoundaryBefore :: Interval -> Day -> Day
intervalBoundaryBefore :: Interval -> Day -> Day
intervalBoundaryBefore Interval
i Day
d =
  case Bool -> Interval -> DateSpan -> [DateSpan]
splitSpan Bool
True Interval
i (Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact Day
d) (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addDays Integer
1 Day
d)) of
    (DateSpan (Just EFDay
start) Maybe EFDay
_:[DateSpan]
_) -> EFDay -> Day
fromEFDay EFDay
start
    [DateSpan]
_ -> Day
d

-- | Find the next occurrence of the specified month and day of month, on or after the given date.
-- The month should be 1-12 and the day of month should be 1-31, or an error will be raised.
--
-- >>> let wed22nd = fromGregorian 2017 11 22
-- >>> nextmonthandday 11 21 wed22nd
-- 2018-11-21
-- >>> nextmonthandday 11 22 wed22nd
-- 2017-11-22
-- >>> nextmonthandday 11 23 wed22nd
-- 2017-11-23
nextmonthandday :: Month -> MonthDay -> Day -> Day
nextmonthandday :: Int -> Int -> Day -> Day
nextmonthandday Int
m Int
n Day
date
  -- PARTIAL:
  | Bool -> Bool
not (Int -> Bool
validMonth Int
m) = [Char] -> Day
forall a. [Char] -> a
error' ([Char] -> Day) -> [Char] -> Day
forall a b. (a -> b) -> a -> b
$ [Char]
"nextmonthandday: month should be 1..12, not "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Int -> [Char]
forall a. Show a => a -> [Char]
show Int
m
  | Bool -> Bool
not (Int -> Bool
validDay   Int
n) = [Char] -> Day
forall a. [Char] -> a
error' ([Char] -> Day) -> [Char] -> Day
forall a b. (a -> b) -> a -> b
$ [Char]
"nextmonthandday: day should be 1..31, not "  [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n
  | Day
mdthisyear Day -> Day -> Bool
forall a. Ord a => a -> a -> Bool
>= Day
date = Day
mdthisyear
  | Bool
otherwise          = Day
mdnextyear
  where
    s :: Day
s = Day -> Day
startofyear Day
date
    advancetomonth :: Day -> Day
advancetomonth = Int -> (Day -> Day) -> Day -> Day
forall a. Int -> (a -> a) -> a -> a
applyN (Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Day -> Day
nextmonth
    advancetoday :: Day -> Day
advancetoday = Integer -> Day -> Day
addDays (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1)
    mdthisyear :: Day
mdthisyear = Day -> Day
advancetoday (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ Day -> Day
advancetomonth Day
s
    mdnextyear :: Day
mdnextyear = Day -> Day
advancetoday (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ Day -> Day
advancetomonth (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ Day -> Day
nextyear Day
s

-- | Find the next occurrence of the specified day of month, on or after the given date.
-- The day of month should be 1-31, or an error will be raised.
--
-- >>> let wed22nd = fromGregorian 2017 11 22
-- >>> nextnthdayofmonth 21 wed22nd
-- 2017-12-21
-- >>> nextnthdayofmonth 22 wed22nd
-- 2017-11-22
-- >>> nextnthdayofmonth 23 wed22nd
-- 2017-11-23
nextnthdayofmonth :: MonthDay -> Day -> Day
nextnthdayofmonth :: Int -> Day -> Day
nextnthdayofmonth Int
n Day
date
  -- PARTIAL:
  | Bool -> Bool
not (Int -> Bool
validDay Int
n)       = [Char] -> Day
forall a. [Char] -> a
error' ([Char] -> Day) -> [Char] -> Day
forall a b. (a -> b) -> a -> b
$ [Char]
"nextnthdayofmonth: day should be 1..31, not "  [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n
  | Day
nthofthismonth Day -> Day -> Bool
forall a. Ord a => a -> a -> Bool
>= Day
date = Day
nthofthismonth
  | Bool
otherwise              = Day
nthofnextmonth
  where
    s :: Day
s = Day -> Day
startofmonth Day
date
    nthofthismonth :: Day
nthofthismonth = Int -> Day -> Day
nthdayofmonth Int
n Day
s
    nthofnextmonth :: Day
nthofnextmonth = Int -> Day -> Day
nthdayofmonth Int
n (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ Day -> Day
nextmonth Day
s

-- | 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 Day -> Day -> Bool
forall a. Ord a => a -> a -> Bool
<= Day
d = Day
nthOfSameWeek
                           | Bool
otherwise = Day
nthOfPrevWeek
    where nthOfSameWeek :: Day
nthOfSameWeek = Integer -> Day -> Day
addDays (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1) Day
s
          nthOfPrevWeek :: Day
nthOfPrevWeek = Integer -> Day -> Day
addDays (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1) (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ Day -> Day
prevweek Day
s
          s :: Day
s = Day -> Day
startofweek Day
d

-- -- | Find the next occurrence of some weekday, on or after the given date d.
-- --
-- -- >>> let wed22nd = fromGregorian 2017 11 22
-- -- >>> nextnthdayofweek 1 wed22nd
-- -- 2017-11-20
-- -- >>> nextnthdayofweek 2 wed22nd
-- -- 2017-11-21
-- -- >>> nextnthdayofweek 3 wed22nd
-- -- 2017-11-22
-- -- >>> nextnthdayofweek 4 wed22nd
-- -- 2017-11-16
-- -- >>> nextnthdayofweek 5 wed22nd
-- -- 2017-11-17
-- nextdayofweek :: WeekDay -> Day -> Day
-- nextdayofweek n d | nthOfSameWeek <= d = nthOfSameWeek
--                            | otherwise = nthOfPrevWeek
--     where nthOfSameWeek = addDays (toInteger n-1) s
--           nthOfPrevWeek = addDays (toInteger n-1) $ prevweek s
--           s = startofweek d

-- | Find the next occurrence of some nth weekday of a month, on or after the given date d.
--
-- >>> let wed22nd = fromGregorian 2017 11 22
-- >>> nextNthWeekdayOfMonth 3 3 wed22nd  -- next third wednesday
-- 2017-12-20
-- >>> nextNthWeekdayOfMonth 4 3 wed22nd  -- next fourth wednesday
-- 2017-11-22
-- >>> nextNthWeekdayOfMonth 5 3 wed22nd  -- next fifth wednesday
-- 2017-11-29
nextNthWeekdayOfMonth :: Int -> WeekDay -> Day -> Day
nextNthWeekdayOfMonth :: Int -> Int -> Day -> Day
nextNthWeekdayOfMonth Int
n Int
wd Day
d
  | Day
nthweekdaythismonth Day -> Day -> Bool
forall a. Ord a => a -> a -> Bool
>= Day
d = Day
nthweekdaythismonth
  | Bool
otherwise                = Day
nthweekdaynextmonth
  where
    nthweekdaythismonth :: Day
nthweekdaythismonth = Int -> Int -> Day -> Day
advanceToNthWeekday Int
n Int
wd (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ Day -> Day
startofmonth Day
d
    nthweekdaynextmonth :: Day
nthweekdaynextmonth = Int -> Int -> Day -> Day
advanceToNthWeekday Int
n Int
wd (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ Day -> Day
nextmonth Day
d

-- | Find the previous occurrence of some nth weekday of a month, on or before the given date d.
--
-- >>> let wed22nd = fromGregorian 2017 11 22
-- >>> prevNthWeekdayOfMonth 4 3 wed22nd
-- 2017-11-22
-- >>> prevNthWeekdayOfMonth 5 2 wed22nd
-- 2017-10-31
prevNthWeekdayOfMonth :: Int -> WeekDay -> Day -> Day
prevNthWeekdayOfMonth :: Int -> Int -> Day -> Day
prevNthWeekdayOfMonth Int
n Int
wd Day
d
  | Day
nthweekdaythismonth Day -> Day -> Bool
forall a. Ord a => a -> a -> Bool
<= Day
d = Day
nthweekdaythismonth
  | Bool
otherwise                = Day
nthweekdayprevmonth
  where
    nthweekdaythismonth :: Day
nthweekdaythismonth = Int -> Int -> Day -> Day
advanceToNthWeekday Int
n Int
wd (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ Day -> Day
startofmonth Day
d
    nthweekdayprevmonth :: Day
nthweekdayprevmonth = Int -> Int -> Day -> Day
advanceToNthWeekday Int
n Int
wd (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ Day -> Day
prevmonth Day
d

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

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

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

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

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

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

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

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

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

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

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

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

md :: TextParser m (Month, MonthDay)
md :: forall (m :: * -> *). TextParser m (Int, Int)
md = do
  Int
m <- ParsecT HledgerParseErrorData Text m Int
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal
  TextParser m Char
forall (m :: * -> *). TextParser m Char
datesepchar
  Int
d <- ParsecT HledgerParseErrorData Text m Int
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal
  SmartDate
_ <- SmartDate -> ParsecT HledgerParseErrorData Text m SmartDate
forall (m :: * -> *). MonadFail m => SmartDate -> m SmartDate
failIfInvalidDate (SmartDate -> ParsecT HledgerParseErrorData Text m SmartDate)
-> SmartDate -> ParsecT HledgerParseErrorData Text m SmartDate
forall a b. (a -> b) -> a -> b
$ Maybe Int -> Int -> SmartDate
SmartFromReference (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
m) Int
d
  (Int, Int) -> TextParser m (Int, Int)
forall a. a -> ParsecT HledgerParseErrorData Text m a
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 <- Maybe [Char]
-> (Token Text -> Bool)
-> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe [Char] -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"year") Char -> Bool
Token Text -> Bool
isDigit
  Bool
-> ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Int
T.length Text
year Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
4) (ParsecT HledgerParseErrorData Text m ()
 -> ParsecT HledgerParseErrorData Text m ())
-> ([Char] -> ParsecT HledgerParseErrorData Text m ())
-> [Char]
-> ParsecT HledgerParseErrorData Text m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ParsecT HledgerParseErrorData Text m ()
forall a. [Char] -> ParsecT HledgerParseErrorData Text m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
Fail.fail ([Char] -> ParsecT HledgerParseErrorData Text m ())
-> [Char] -> ParsecT HledgerParseErrorData Text m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Year must contain at least 4 digits: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
year
  Integer -> TextParser m Integer
forall a. a -> ParsecT HledgerParseErrorData Text m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> TextParser m Integer)
-> Integer -> TextParser m Integer
forall a b. (a -> b) -> a -> b
$ Text -> Integer
readDecimal Text
year

-- 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 :: [Text]
weekdayabbrevs = [Text
"mon",Text
"tue",Text
"wed",Text
"thu",Text
"fri",Text
"sat",Text
"sun"]

month, mon :: TextParser m Month
month :: forall (m :: * -> *). TextParser m Int
month = [ParsecT HledgerParseErrorData Text m Int]
-> ParsecT HledgerParseErrorData Text m Int
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
choice ([ParsecT HledgerParseErrorData Text m Int]
 -> ParsecT HledgerParseErrorData Text m Int)
-> [ParsecT HledgerParseErrorData Text m Int]
-> ParsecT HledgerParseErrorData Text m Int
forall a b. (a -> b) -> a -> b
$ (Int -> Tokens Text -> ParsecT HledgerParseErrorData Text m Int)
-> [Int]
-> [Tokens Text]
-> [ParsecT HledgerParseErrorData Text m Int]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
i Tokens Text
m -> Int
i Int
-> ParsecT HledgerParseErrorData Text m (Tokens Text)
-> ParsecT HledgerParseErrorData Text m Int
forall a b.
a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens Text -> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
m) [Int
1..Int
12] [Tokens Text]
months
mon :: forall (m :: * -> *). TextParser m Int
mon   = [ParsecT HledgerParseErrorData Text m Int]
-> ParsecT HledgerParseErrorData Text m Int
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
choice ([ParsecT HledgerParseErrorData Text m Int]
 -> ParsecT HledgerParseErrorData Text m Int)
-> [ParsecT HledgerParseErrorData Text m Int]
-> ParsecT HledgerParseErrorData Text m Int
forall a b. (a -> b) -> a -> b
$ (Int -> Tokens Text -> ParsecT HledgerParseErrorData Text m Int)
-> [Int]
-> [Tokens Text]
-> [ParsecT HledgerParseErrorData Text m Int]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
i Tokens Text
m -> Int
i Int
-> ParsecT HledgerParseErrorData Text m (Tokens Text)
-> ParsecT HledgerParseErrorData Text m Int
forall a b.
a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens Text -> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
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 (Text -> Text)
-> ParsecT HledgerParseErrorData Text m Text
-> ParsecT HledgerParseErrorData Text m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([ParsecT HledgerParseErrorData Text m Text]
-> ParsecT HledgerParseErrorData Text m Text
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
choice ([ParsecT HledgerParseErrorData Text m Text]
 -> ParsecT HledgerParseErrorData Text m Text)
-> ([Tokens Text] -> [ParsecT HledgerParseErrorData Text m Text])
-> [Tokens Text]
-> ParsecT HledgerParseErrorData Text m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tokens Text -> ParsecT HledgerParseErrorData Text m Text)
-> [Tokens Text] -> [ParsecT HledgerParseErrorData Text m Text]
forall a b. (a -> b) -> [a] -> [b]
map Tokens Text -> ParsecT HledgerParseErrorData Text m Text
Tokens Text -> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' ([Tokens Text] -> ParsecT HledgerParseErrorData Text m Text)
-> [Tokens Text] -> ParsecT HledgerParseErrorData Text m Text
forall a b. (a -> b) -> a -> b
$ [Tokens Text]
weekdays [Tokens Text] -> [Tokens Text] -> [Tokens Text]
forall a. [a] -> [a] -> [a]
++ [Text]
[Tokens Text]
weekdayabbrevs)
  case [Maybe Int] -> [Int]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Int] -> [Int]) -> [Maybe Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ [Text
wday Text -> [Text] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
`elemIndex` [Text]
[Tokens Text]
weekdays, Text
wday Text -> [Text] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
`elemIndex` [Text]
weekdayabbrevs] of
    (Int
i:[Int]
_) -> Int -> TextParser m Int
forall a. a -> ParsecT HledgerParseErrorData Text m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
    []    -> [Char] -> TextParser m Int
forall a. [Char] -> ParsecT HledgerParseErrorData Text m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
Fail.fail ([Char] -> TextParser m Int) -> [Char] -> TextParser m Int
forall a b. (a -> b) -> a -> b
$ [Char]
"weekday: should not happen: attempted to find " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
                         Text -> [Char]
forall a. Show a => a -> [Char]
show Text
wday [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" in " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Tokens Text] -> [Char]
forall a. Show a => a -> [Char]
show ([Tokens Text]
weekdays [Tokens Text] -> [Tokens Text] -> [Tokens Text]
forall a. [a] -> [a] -> [a]
++ [Text]
[Tokens Text]
weekdayabbrevs)

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

-- | 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 (MonthDay 2,DateSpan ..)
-- >>> p "every 2nd day"
-- Right (MonthDay 2,DateSpan ..)
-- >>> p "every 2nd day 2009.."
-- Right (MonthDay 2,DateSpan 2009-01-01..)
-- >>> p "every 2nd day 2009-"
-- Right (MonthDay 2,DateSpan 2009-01-01..)
-- >>> p "every 29th Nov"
-- Right (MonthAndDay 11 29,DateSpan ..)
-- >>> p "every 29th nov ..2009"
-- Right (MonthAndDay 11 29,DateSpan ..2008-12-31)
-- >>> p "every nov 29th"
-- Right (MonthAndDay 11 29,DateSpan ..)
-- >>> p "every Nov 29th 2009.."
-- Right (MonthAndDay 11 29,DateSpan 2009-01-01..)
-- >>> p "every 11/29 from 2009"
-- Right (MonthAndDay 11 29,DateSpan 2009-01-01..)
-- >>> p "every 11/29 since 2009"
-- Right (MonthAndDay 11 29,DateSpan 2009-01-01..)
-- >>> p "every 2nd Thursday of month to 2009"
-- Right (NthWeekdayOfMonth 2 4,DateSpan ..2008-12-31)
-- >>> p "every 1st monday of month to 2009"
-- Right (NthWeekdayOfMonth 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 (MonthDay 2,DateSpan ..)
-- >>> p "every 2nd day"
-- Right (MonthDay 2,DateSpan ..)
-- >>> p "every 2nd day 2009.."
-- Right (MonthDay 2,DateSpan 2009-01-01..)
-- >>> p "every 2nd day of month 2009.."
-- Right (MonthDay 2,DateSpan 2009-01-01..)
periodexprp :: Day -> TextParser m (Interval, DateSpan)
periodexprp :: forall (m :: * -> *). Day -> TextParser m (Interval, DateSpan)
periodexprp Day
rdate = do
  ParsecT HledgerParseErrorData Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces
  [TextParser m (Interval, DateSpan)]
-> TextParser m (Interval, DateSpan)
forall (m :: * -> *) a. [TextParser m a] -> TextParser m a
choice' [ Day -> TextParser m (Interval, DateSpan)
forall (m :: * -> *). Day -> TextParser m (Interval, DateSpan)
intervalanddateperiodexprp Day
rdate
          , (,) Interval
NoInterval (DateSpan -> (Interval, DateSpan))
-> ParsecT HledgerParseErrorData Text m DateSpan
-> TextParser m (Interval, DateSpan)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Day -> ParsecT HledgerParseErrorData Text m DateSpan
forall (m :: * -> *). Day -> TextParser m DateSpan
periodexprdatespanp Day
rdate
          ]

-- 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 <- TextParser m Interval
forall (m :: * -> *). TextParser m Interval
reportingintervalp
  DateSpan
s <- DateSpan
-> ParsecT HledgerParseErrorData Text m DateSpan
-> ParsecT HledgerParseErrorData Text m DateSpan
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option DateSpan
forall a. Default a => a
def (ParsecT HledgerParseErrorData Text m DateSpan
 -> ParsecT HledgerParseErrorData Text m DateSpan)
-> (ParsecT HledgerParseErrorData Text m DateSpan
    -> ParsecT HledgerParseErrorData Text m DateSpan)
-> ParsecT HledgerParseErrorData Text m DateSpan
-> ParsecT HledgerParseErrorData Text m DateSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT HledgerParseErrorData Text m DateSpan
-> ParsecT HledgerParseErrorData Text m DateSpan
forall a.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT HledgerParseErrorData Text m DateSpan
 -> ParsecT HledgerParseErrorData Text m DateSpan)
-> ParsecT HledgerParseErrorData Text m DateSpan
-> ParsecT HledgerParseErrorData Text m DateSpan
forall a b. (a -> b) -> a -> b
$ do
      ParsecT HledgerParseErrorData Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces
      Day -> ParsecT HledgerParseErrorData Text m DateSpan
forall (m :: * -> *). Day -> TextParser m DateSpan
periodexprdatespanp Day
rdate
  (Interval, DateSpan) -> TextParser m (Interval, DateSpan)
forall a. a -> ParsecT HledgerParseErrorData Text m a
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 = [TextParser m Interval] -> TextParser m Interval
forall (m :: * -> *) a. [TextParser m a] -> TextParser m a
choice'
    [ Text -> Text -> (Int -> Interval) -> TextParser m Interval
forall (m :: * -> *).
Text -> Text -> (Int -> Interval) -> TextParser m Interval
tryinterval Text
"day"     Text
"daily"     Int -> Interval
Days
    , Text -> Text -> (Int -> Interval) -> TextParser m Interval
forall (m :: * -> *).
Text -> Text -> (Int -> Interval) -> TextParser m Interval
tryinterval Text
"month"   Text
"monthly"   Int -> Interval
Months
    , Text -> Text -> (Int -> Interval) -> TextParser m Interval
forall (m :: * -> *).
Text -> Text -> (Int -> Interval) -> TextParser m Interval
tryinterval Text
"quarter" Text
"quarterly" Int -> Interval
Quarters
    , Text -> Text -> (Int -> Interval) -> TextParser m Interval
forall (m :: * -> *).
Text -> Text -> (Int -> Interval) -> TextParser m Interval
tryinterval Text
"year"    Text
"yearly"    Int -> Interval
Years
    , Int -> Interval
Weeks Int
2 Interval
-> ParsecT HledgerParseErrorData Text m (Tokens Text)
-> TextParser m Interval
forall a b.
a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens Text -> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"biweekly"
    , Int -> Interval
Weeks Int
2 Interval
-> ParsecT HledgerParseErrorData Text m (Tokens Text)
-> TextParser m Interval
forall a b.
a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens Text -> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"fortnightly"
    , Int -> Interval
Months Int
2 Interval
-> ParsecT HledgerParseErrorData Text m (Tokens Text)
-> TextParser m Interval
forall a b.
a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens Text -> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"bimonthly"
    , Tokens Text -> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"every" ParsecT HledgerParseErrorData Text m (Tokens Text)
-> ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m ()
forall a b.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT HledgerParseErrorData Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces ParsecT HledgerParseErrorData Text m ()
-> TextParser m Interval -> TextParser m Interval
forall a b.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [TextParser m Interval] -> TextParser m Interval
forall (m :: * -> *) a. [TextParser m a] -> TextParser m a
choice'
        [ [Int] -> Interval
DaysOfWeek ([Int] -> Interval) -> (Int -> [Int]) -> Int -> Interval
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Int]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Interval)
-> ParsecT HledgerParseErrorData Text m Int
-> TextParser m Interval
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT HledgerParseErrorData Text m Int
nth ParsecT HledgerParseErrorData Text m Int
-> ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m Int
forall a b.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT HledgerParseErrorData Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces ParsecT HledgerParseErrorData Text m Int
-> ParsecT HledgerParseErrorData Text m (Tokens Text)
-> ParsecT HledgerParseErrorData Text m Int
forall a b.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Tokens Text -> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"day" ParsecT HledgerParseErrorData Text m Int
-> ParsecT HledgerParseErrorData Text m Text
-> ParsecT HledgerParseErrorData Text m Int
forall a b.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Tokens Text -> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall {s} {m :: * -> *}.
(Token s ~ Char, IsString (Tokens s), FoldCase (Tokens s),
 Stream s) =>
Tokens s -> ParsecT HledgerParseErrorData s m (Tokens s)
of_ Text
Tokens Text
"week")
        , Int -> Interval
MonthDay (Int -> Interval)
-> ParsecT HledgerParseErrorData Text m Int
-> TextParser m Interval
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT HledgerParseErrorData Text m Int
nth ParsecT HledgerParseErrorData Text m Int
-> ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m Int
forall a b.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT HledgerParseErrorData Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces ParsecT HledgerParseErrorData Text m Int
-> ParsecT HledgerParseErrorData Text m (Tokens Text)
-> ParsecT HledgerParseErrorData Text m Int
forall a b.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Tokens Text -> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"day" ParsecT HledgerParseErrorData Text m Int
-> ParsecT HledgerParseErrorData Text m (Maybe Text)
-> ParsecT HledgerParseErrorData Text m Int
forall a b.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Tokens Text
-> ParsecT HledgerParseErrorData Text m (Maybe (Tokens Text))
forall {s} {m :: * -> *}.
(Token s ~ Char, Stream s, IsString (Tokens s),
 FoldCase (Tokens s)) =>
Tokens s -> ParsecT HledgerParseErrorData s m (Maybe (Tokens s))
optOf_ Text
Tokens Text
"month")
        , (Int -> Int -> Interval)
-> ParsecT HledgerParseErrorData Text m Int
-> ParsecT HledgerParseErrorData Text m Int
-> TextParser m Interval
forall a b c.
(a -> b -> c)
-> ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Int -> Int -> Interval
NthWeekdayOfMonth ParsecT HledgerParseErrorData Text m Int
nth (ParsecT HledgerParseErrorData Text m Int -> TextParser m Interval)
-> ParsecT HledgerParseErrorData Text m Int
-> TextParser m Interval
forall a b. (a -> b) -> a -> b
$ ParsecT HledgerParseErrorData Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m Int
-> ParsecT HledgerParseErrorData Text m Int
forall a b.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT HledgerParseErrorData Text m Int
forall (m :: * -> *). TextParser m Int
weekday ParsecT HledgerParseErrorData Text m Int
-> ParsecT HledgerParseErrorData Text m (Maybe Text)
-> ParsecT HledgerParseErrorData Text m Int
forall a b.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Tokens Text
-> ParsecT HledgerParseErrorData Text m (Maybe (Tokens Text))
forall {s} {m :: * -> *}.
(Token s ~ Char, Stream s, IsString (Tokens s),
 FoldCase (Tokens s)) =>
Tokens s -> ParsecT HledgerParseErrorData s m (Maybe (Tokens s))
optOf_ Text
Tokens Text
"month"
        , (Int -> Int -> Interval) -> (Int, Int) -> Interval
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Int -> Interval
MonthAndDay ((Int, Int) -> Interval)
-> ParsecT HledgerParseErrorData Text m (Int, Int)
-> TextParser m Interval
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT HledgerParseErrorData Text m (Int, Int)
forall (m :: * -> *). TextParser m (Int, Int)
md ParsecT HledgerParseErrorData Text m (Int, Int)
-> ParsecT HledgerParseErrorData Text m (Maybe Text)
-> ParsecT HledgerParseErrorData Text m (Int, Int)
forall a b.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Tokens Text
-> ParsecT HledgerParseErrorData Text m (Maybe (Tokens Text))
forall {s} {m :: * -> *}.
(Token s ~ Char, Stream s, IsString (Tokens s),
 FoldCase (Tokens s)) =>
Tokens s -> ParsecT HledgerParseErrorData s m (Maybe (Tokens s))
optOf_ Text
Tokens Text
"year")
        , [Int] -> Interval
DaysOfWeek ([Int] -> Interval)
-> ParsecT HledgerParseErrorData Text m [Int]
-> TextParser m Interval
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT HledgerParseErrorData Text m [Int]
forall (m :: * -> *). TextParser m [Int]
weekdaysp
        , [Int] -> Interval
DaysOfWeek [Int
1..Int
5] Interval
-> ParsecT HledgerParseErrorData Text m (Tokens Text)
-> TextParser m Interval
forall a b.
a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens Text -> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"weekday"
        , [Int] -> Interval
DaysOfWeek [Int
6..Int
7] Interval
-> ParsecT HledgerParseErrorData Text m (Tokens Text)
-> TextParser m Interval
forall a b.
a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens Text -> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"weekendday"
        , TextParser m Interval
d_o_y TextParser m Interval
-> ParsecT HledgerParseErrorData Text m (Maybe Text)
-> TextParser m Interval
forall a b.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Tokens Text
-> ParsecT HledgerParseErrorData Text m (Maybe (Tokens Text))
forall {s} {m :: * -> *}.
(Token s ~ Char, Stream s, IsString (Tokens s),
 FoldCase (Tokens s)) =>
Tokens s -> ParsecT HledgerParseErrorData s m (Maybe (Tokens s))
optOf_ Text
Tokens 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.
    , Text -> Text -> (Int -> Interval) -> TextParser m Interval
forall (m :: * -> *).
Text -> Text -> (Int -> Interval) -> TextParser m Interval
tryinterval Text
"week"    Text
"weekly"    Int -> Interval
Weeks
    ]
  where
    of_ :: Tokens s -> ParsecT HledgerParseErrorData s m (Tokens s)
of_ Tokens s
period =
      ParsecT HledgerParseErrorData s m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces ParsecT HledgerParseErrorData s m ()
-> ParsecT HledgerParseErrorData s m (Tokens s)
-> ParsecT HledgerParseErrorData s m (Tokens s)
forall a b.
ParsecT HledgerParseErrorData s m a
-> ParsecT HledgerParseErrorData s m b
-> ParsecT HledgerParseErrorData s m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Tokens s -> ParsecT HledgerParseErrorData s m (Tokens s)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens s
"of" ParsecT HledgerParseErrorData s m (Tokens s)
-> ParsecT HledgerParseErrorData s m ()
-> ParsecT HledgerParseErrorData s m ()
forall a b.
ParsecT HledgerParseErrorData s m a
-> ParsecT HledgerParseErrorData s m b
-> ParsecT HledgerParseErrorData s m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT HledgerParseErrorData s m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces ParsecT HledgerParseErrorData s m ()
-> ParsecT HledgerParseErrorData s m (Tokens s)
-> ParsecT HledgerParseErrorData s m (Tokens s)
forall a b.
ParsecT HledgerParseErrorData s m a
-> ParsecT HledgerParseErrorData s m b
-> ParsecT HledgerParseErrorData s m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Tokens s -> ParsecT HledgerParseErrorData s m (Tokens s)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens s
period

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

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

    -- 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 (Int -> Interval)
-> ParsecT HledgerParseErrorData Text m Int
-> ParsecT HledgerParseErrorData Text m Interval
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ParsecT HledgerParseErrorData Text m Int]
-> ParsecT HledgerParseErrorData Text m Int
forall (m :: * -> *) a. [TextParser m a] -> TextParser m a
choice'
        [ Int
1 Int
-> ParsecT HledgerParseErrorData Text m (Tokens Text)
-> ParsecT HledgerParseErrorData Text m Int
forall a b.
a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens Text -> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Text
Tokens Text
compact
        , Tokens Text -> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"every" ParsecT HledgerParseErrorData Text m (Tokens Text)
-> ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m ()
forall a b.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT HledgerParseErrorData Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m Int
-> ParsecT HledgerParseErrorData Text m Int
forall a b.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [ParsecT HledgerParseErrorData Text m Int]
-> ParsecT HledgerParseErrorData Text m Int
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
choice
            [ Int
1 Int
-> ParsecT HledgerParseErrorData Text m (Tokens Text)
-> ParsecT HledgerParseErrorData Text m Int
forall a b.
a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens Text -> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Text
Tokens Text
singular
            , ParsecT HledgerParseErrorData Text m Int
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal ParsecT HledgerParseErrorData Text m Int
-> ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m Int
forall a b.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT HledgerParseErrorData Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces ParsecT HledgerParseErrorData Text m Int
-> ParsecT HledgerParseErrorData Text m (Tokens Text)
-> ParsecT HledgerParseErrorData Text m Int
forall a b.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Tokens Text -> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' (Text
singular Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"s")
            ]
        ]

periodexprdatespanp :: Day -> TextParser m DateSpan
periodexprdatespanp :: forall (m :: * -> *). Day -> TextParser m DateSpan
periodexprdatespanp Day
rdate = [ParsecT HledgerParseErrorData Text m DateSpan]
-> ParsecT HledgerParseErrorData Text m DateSpan
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
choice ([ParsecT HledgerParseErrorData Text m DateSpan]
 -> ParsecT HledgerParseErrorData Text m DateSpan)
-> [ParsecT HledgerParseErrorData Text m DateSpan]
-> ParsecT HledgerParseErrorData Text m DateSpan
forall a b. (a -> b) -> a -> b
$ (ParsecT HledgerParseErrorData Text m DateSpan
 -> ParsecT HledgerParseErrorData Text m DateSpan)
-> [ParsecT HledgerParseErrorData Text m DateSpan]
-> [ParsecT HledgerParseErrorData Text m DateSpan]
forall a b. (a -> b) -> [a] -> [b]
map ParsecT HledgerParseErrorData Text m DateSpan
-> ParsecT HledgerParseErrorData Text m DateSpan
forall a.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try [
                            Day -> ParsecT HledgerParseErrorData Text m DateSpan
forall (m :: * -> *). Day -> TextParser m DateSpan
doubledatespanp Day
rdate,
                            Day -> ParsecT HledgerParseErrorData Text m DateSpan
forall (m :: * -> *). Day -> TextParser m DateSpan
quarterdatespanp Day
rdate,
                            Day -> ParsecT HledgerParseErrorData Text m DateSpan
forall (m :: * -> *). Day -> TextParser m DateSpan
fromdatespanp Day
rdate,
                            Day -> ParsecT HledgerParseErrorData Text m DateSpan
forall (m :: * -> *). Day -> TextParser m DateSpan
todatespanp Day
rdate,
                            Day -> ParsecT HledgerParseErrorData Text m DateSpan
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 = (SmartDate -> SmartDate -> DateSpan)
-> ParsecT HledgerParseErrorData Text m SmartDate
-> ParsecT HledgerParseErrorData Text m SmartDate
-> ParsecT HledgerParseErrorData Text m DateSpan
forall a b c.
(a -> b -> c)
-> ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 SmartDate -> SmartDate -> DateSpan
fromToSpan
    (ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m (Maybe ())
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ((Tokens Text -> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"from" ParsecT HledgerParseErrorData Text m (Tokens Text)
-> ParsecT HledgerParseErrorData Text m (Tokens Text)
-> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall a.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens Text -> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"since") ParsecT HledgerParseErrorData Text m (Tokens Text)
-> ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m ()
forall a b.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT HledgerParseErrorData Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces) ParsecT HledgerParseErrorData Text m (Maybe ())
-> ParsecT HledgerParseErrorData Text m SmartDate
-> ParsecT HledgerParseErrorData Text m SmartDate
forall a b.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT HledgerParseErrorData Text m SmartDate
forall (m :: * -> *). TextParser m SmartDate
smartdate)
    (ParsecT HledgerParseErrorData Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m (Tokens Text)
-> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall a b.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [ParsecT HledgerParseErrorData Text m (Tokens Text)]
-> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
choice [Tokens Text -> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"to", Tokens Text -> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"..", Tokens Text -> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"-"]
    ParsecT HledgerParseErrorData Text m (Tokens Text)
-> ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m ()
forall a b.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT HledgerParseErrorData Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m SmartDate
-> ParsecT HledgerParseErrorData Text m SmartDate
forall a b.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT HledgerParseErrorData Text m SmartDate
forall (m :: * -> *). TextParser m SmartDate
smartdate)
  where
    fromToSpan :: SmartDate -> SmartDate -> DateSpan
fromToSpan = Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (Maybe EFDay -> Maybe EFDay -> DateSpan)
-> (SmartDate -> Maybe EFDay) -> SmartDate -> SmartDate -> DateSpan
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay)
-> (SmartDate -> EFDay) -> SmartDate -> Maybe EFDay
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> SmartDate -> EFDay
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 <- TextParser m Integer
forall {m :: * -> *}. ParsecT HledgerParseErrorData Text m Integer
yearp TextParser m Integer
-> TextParser m Integer -> TextParser m Integer
forall a.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Integer -> TextParser m Integer
forall a. a -> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Integer, Int, Int) -> Integer
forall {a} {b} {c}. (a, b, c) -> a
first3 ((Integer, Int, Int) -> Integer) -> (Integer, Int, Int) -> Integer
forall a b. (a -> b) -> a -> b
$ Day -> (Integer, Int, Int)
toGregorian Day
rdate)
    Char
q <- Token Text -> ParsecT HledgerParseErrorData Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char' Char
Token Text
'q' ParsecT HledgerParseErrorData Text m Char
-> ParsecT HledgerParseErrorData Text m Char
-> ParsecT HledgerParseErrorData Text m Char
forall a b.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Token Text -> Bool)
-> ParsecT HledgerParseErrorData Text m (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
Token Text -> Bool
is4Digit
    DateSpan -> TextParser m DateSpan
forall a. a -> ParsecT HledgerParseErrorData Text m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DateSpan -> TextParser m DateSpan)
-> (Period -> DateSpan) -> Period -> TextParser m DateSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Period -> DateSpan
periodAsDateSpan (Period -> TextParser m DateSpan)
-> Period -> TextParser m DateSpan
forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Period
QuarterPeriod Integer
y (Char -> Int
digitToInt Char
q)
  where
    is4Digit :: Char -> Bool
is4Digit Char
c = (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'1') :: Word) Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
<= Word
3

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

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

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

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

-- | An exact datespan of zero length, that matches no date.
emptydatespan :: DateSpan
emptydatespan :: DateSpan
emptydatespan = Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addDays Integer
1 Day
nulldate) (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact Day
nulldate)

nulldate :: Day
nulldate :: Day
nulldate = Integer -> Int -> Int -> Day
fromGregorian Integer
0 Int
1 Int
1


-- tests

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

      Bool -> Interval -> DateSpan -> [DateSpan]
splitSpan Bool
False ([Int] -> Interval
DaysOfWeek [Int
1, Int
5]) (Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
01) (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
08))
        [DateSpan] -> [DateSpan] -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= [ (Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
06 Int
28) (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
02))
            , (Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
02) (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
05))
            -- next week
            , (Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
07 Int
05) (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact (Day -> EFDay) -> Day -> EFDay
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" (Assertion -> TestTree) -> Assertion -> TestTree
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 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 then Day -> Day
forall a. a -> a
id else Int -> (Day -> Day) -> Day -> Day
forall a. Int -> (a -> a) -> a -> a
applyN (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Day -> Day
nextday (Day -> Day) -> (Day -> Day) -> Day -> Day
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> (Day -> Day) -> Day -> Day
forall a. Int -> (a -> a) -> a -> a
applyN (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
w) Day -> Day
nextweek)) Int
1
          matchdow :: DateSpan -> Int -> Assertion
matchdow DateSpan
ds Int
day = Bool -> Interval -> DateSpan -> [DateSpan]
splitSpan Bool
False ([Int] -> Interval
DaysOfWeek [Int
day]) DateSpan
ds [DateSpan] -> [DateSpan] -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Int -> DateSpan -> [DateSpan]
dayofweek Int
day DateSpan
ds
          ys2021 :: Day
ys2021 = Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
01 Int
01
          ye2021 :: Day
ye2021 = Integer -> Int -> Int -> Day
fromGregorian Integer
2021 Int
12 Int
31
          ys2022 :: Day
ys2022 = Integer -> Int -> Int -> Day
fromGregorian Integer
2022 Int
01 Int
01
      (Int -> Assertion) -> [Int] -> Assertion
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DateSpan -> Int -> Assertion
matchdow (Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact Day
ys2021) (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact Day
ye2021))) [Int
1..Int
7]
      (Int -> Assertion) -> [Int] -> Assertion
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DateSpan -> Int -> Assertion
matchdow (Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact Day
ys2021) (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact Day
ys2022))) [Int
1..Int
7]
      (Int -> Assertion) -> [Int] -> Assertion
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DateSpan -> Int -> Assertion
matchdow (Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact Day
ye2021) (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact Day
ys2022))) [Int
1..Int
7]

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

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

  ]