{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE NoMonoLocalBinds    #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE PackageImports      #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections       #-}
{-# 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.
We represent these as a triple of strings like (\"2008\",\"12\",\"\"),
(\"\",\"\",\"tomorrow\"), (\"\",\"last\",\"week\").

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

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

'Period' will probably replace DateSpan in due course.

-}

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

module Hledger.Data.Dates (
  -- * Misc date handling utilities
  getCurrentDay,
  getCurrentMonth,
  getCurrentYear,
  nulldate,
  spanContainsDate,
  periodContainsDate,
  parsedateM,
  showDate,
  showDateSpan,
  showDateSpanMonthAbbrev,
  elapsedSeconds,
  prevday,
  periodexprp,
  parsePeriodExpr,
  parsePeriodExpr',
  nulldatespan,
  emptydatespan,
  datesepchar,
  datesepchars,
  isDateSepChar,
  spanStart,
  spanEnd,
  spanStartYear,
  spanEndYear,
  spanYears,
  spansSpan,
  spanIntersect,
  spansIntersect,
  spanDefaultsFrom,
  spanUnion,
  spansUnion,
  daysSpan,
  latestSpanContaining,
  smartdate,
  splitSpan,
  fixSmartDate,
  fixSmartDateStr,
  fixSmartDateStrEither,
  fixSmartDateStrEither',
  yearp,
  daysInSpan,
  maybePeriod,
)
where

import Prelude ()
import "base-compat-batteries" Prelude.Compat hiding (fail)
import qualified "base-compat-batteries" Control.Monad.Fail.Compat as Fail (MonadFail, fail)
import Control.Applicative (liftA2)
import Control.Applicative.Permutations
import Control.Monad (guard, unless)
import "base-compat-batteries" Data.List.Compat
import Data.Char (digitToInt, isDigit, ord)
import Data.Default
import Data.Foldable (asum)
import Data.Function (on)
import Data.Maybe
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
import Data.Time.Calendar.OrdinalDate
import Data.Time.Clock
import Data.Time.LocalTime
import Safe (headMay, lastMay, maximumMay, minimumMay)
import Text.Megaparsec
import Text.Megaparsec.Char
import Text.Megaparsec.Char.Lexer (decimal)
import Text.Megaparsec.Custom
import Text.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 -> String
show DateSpan
s = String
"DateSpan " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack (DateSpan -> Text
showDateSpan DateSpan
s)

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

-- | Render a datespan as a display string, abbreviating into a
-- compact form if possible.
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

-- | Like showDateSpan, but show month spans as just the abbreviated month name
-- in the current locale.
showDateSpanMonthAbbrev :: DateSpan -> Text
showDateSpanMonthAbbrev :: DateSpan -> Text
showDateSpanMonthAbbrev = Period -> Text
showPeriodMonthAbbrev (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 :: UTCTime -> UTCTime -> a
elapsedSeconds UTCTime
t1 = NominalDiffTime -> a
forall a b. (Real a, Fractional b) => a -> b
realToFrac (NominalDiffTime -> a)
-> (UTCTime -> NominalDiffTime) -> UTCTime -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
t1

spanStart :: DateSpan -> Maybe Day
spanStart :: DateSpan -> Maybe Day
spanStart (DateSpan Maybe Day
d Maybe Day
_) = Maybe Day
d

spanEnd :: DateSpan -> Maybe Day
spanEnd :: DateSpan -> Maybe Day
spanEnd (DateSpan Maybe Day
_ Maybe Day
d) = Maybe Day
d

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

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

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

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

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

-- | Split a DateSpan into consecutive whole spans of the specified interval
-- which fully encompass the original span (and a little more when necessary).
-- If no interval is specified, the original span is returned.
-- If the original span is the null date span, ie unbounded, the null date span is returned.
-- If the original span is empty, eg if the end date is <= the start date, no spans are returned.
--
--
-- ==== Examples:
-- >>> let t i y1 m1 d1 y2 m2 d2 = splitSpan i $ DateSpan (Just $ fromGregorian y1 m1 d1) (Just $ fromGregorian y2 m2 d2)
-- >>> t NoInterval 2008 01 01 2009 01 01
-- [DateSpan 2008]
-- >>> t (Quarters 1) 2008 01 01 2009 01 01
-- [DateSpan 2008Q1,DateSpan 2008Q2,DateSpan 2008Q3,DateSpan 2008Q4]
-- >>> splitSpan (Quarters 1) nulldatespan
-- [DateSpan ..]
-- >>> t (Days 1) 2008 01 01 2008 01 01  -- an empty datespan
-- []
-- >>> t (Quarters 1) 2008 01 01 2008 01 01
-- []
-- >>> t (Months 1) 2008 01 01 2008 04 01
-- [DateSpan 2008-01,DateSpan 2008-02,DateSpan 2008-03]
-- >>> t (Months 2) 2008 01 01 2008 04 01
-- [DateSpan 2008-01-01..2008-02-29,DateSpan 2008-03-01..2008-04-30]
-- >>> t (Weeks 1) 2008 01 01 2008 01 15
-- [DateSpan 2007-12-31W01,DateSpan 2008-01-07W02,DateSpan 2008-01-14W03]
-- >>> t (Weeks 2) 2008 01 01 2008 01 15
-- [DateSpan 2007-12-31..2008-01-13,DateSpan 2008-01-14..2008-01-27]
-- >>> t (DayOfMonth 2) 2008 01 01 2008 04 01
-- [DateSpan 2007-12-02..2008-01-01,DateSpan 2008-01-02..2008-02-01,DateSpan 2008-02-02..2008-03-01,DateSpan 2008-03-02..2008-04-01]
-- >>> t (WeekdayOfMonth 2 4) 2011 01 01 2011 02 15
-- [DateSpan 2010-12-09..2011-01-12,DateSpan 2011-01-13..2011-02-09,DateSpan 2011-02-10..2011-03-09]
-- >>> t (DayOfWeek 2) 2011 01 01 2011 01 15
-- [DateSpan 2010-12-28..2011-01-03,DateSpan 2011-01-04..2011-01-10,DateSpan 2011-01-11..2011-01-17]
-- >>> t (DayOfYear 11 29) 2011 10 01 2011 10 15
-- [DateSpan 2010-11-29..2011-11-28]
-- >>> t (DayOfYear 11 29) 2011 12 01 2012 12 15
-- [DateSpan 2011-11-29..2012-11-28,DateSpan 2012-11-29..2013-11-28]
--
splitSpan :: Interval -> DateSpan -> [DateSpan]
splitSpan :: Interval -> DateSpan -> [DateSpan]
splitSpan Interval
_ (DateSpan Maybe Day
Nothing Maybe Day
Nothing) = [Maybe Day -> Maybe Day -> DateSpan
DateSpan Maybe Day
forall a. Maybe a
Nothing Maybe Day
forall a. Maybe a
Nothing]
splitSpan Interval
_ DateSpan
s | DateSpan -> Bool
isEmptySpan DateSpan
s = []
splitSpan Interval
NoInterval     DateSpan
s = [DateSpan
s]
splitSpan (Days Int
n)       DateSpan
s = (Day -> Day) -> (Day -> Day) -> DateSpan -> [DateSpan]
splitspan Day -> Day
forall a. a -> a
startofday     (Int -> (Day -> Day) -> Day -> Day
forall a. Int -> (a -> a) -> a -> a
applyN Int
n Day -> Day
nextday)     DateSpan
s
splitSpan (Weeks Int
n)      DateSpan
s = (Day -> Day) -> (Day -> Day) -> DateSpan -> [DateSpan]
splitspan Day -> Day
startofweek    (Int -> (Day -> Day) -> Day -> Day
forall a. Int -> (a -> a) -> a -> a
applyN Int
n Day -> Day
nextweek)    DateSpan
s
splitSpan (Months Int
n)     DateSpan
s = (Day -> Day) -> (Day -> Day) -> DateSpan -> [DateSpan]
splitspan Day -> Day
startofmonth   (Int -> (Day -> Day) -> Day -> Day
forall a. Int -> (a -> a) -> a -> a
applyN Int
n Day -> Day
nextmonth)   DateSpan
s
splitSpan (Quarters Int
n)   DateSpan
s = (Day -> Day) -> (Day -> Day) -> DateSpan -> [DateSpan]
splitspan Day -> Day
startofquarter (Int -> (Day -> Day) -> Day -> Day
forall a. Int -> (a -> a) -> a -> a
applyN Int
n Day -> Day
nextquarter) DateSpan
s
splitSpan (Years Int
n)      DateSpan
s = (Day -> Day) -> (Day -> Day) -> DateSpan -> [DateSpan]
splitspan Day -> Day
startofyear    (Int -> (Day -> Day) -> Day -> Day
forall a. Int -> (a -> a) -> a -> a
applyN Int
n Day -> Day
nextyear)    DateSpan
s
splitSpan (DayOfMonth Int
n) DateSpan
s = (Day -> Day) -> (Day -> Day) -> DateSpan -> [DateSpan]
splitspan (Int -> Day -> Day
nthdayofmonthcontaining Int
n) (Int -> Day -> Day
nthdayofmonth Int
n (Day -> Day) -> (Day -> Day) -> Day -> Day
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> Day
nextmonth) DateSpan
s
splitSpan (WeekdayOfMonth Int
n Int
wd) DateSpan
s = (Day -> Day) -> (Day -> Day) -> DateSpan -> [DateSpan]
splitspan (Int -> Int -> Day -> Day
nthweekdayofmonthcontaining Int
n Int
wd) (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
nextmonth) DateSpan
s
splitSpan (DayOfWeek Int
n)  DateSpan
s = (Day -> Day) -> (Day -> Day) -> DateSpan -> [DateSpan]
splitspan (Int -> Day -> Day
nthdayofweekcontaining Int
n)  (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
. Day -> Day
nextweek)  DateSpan
s
splitSpan (DayOfYear Int
m Int
n) DateSpan
s = (Day -> Day) -> (Day -> Day) -> DateSpan -> [DateSpan]
splitspan (Int -> Int -> Day -> Day
nthdayofyearcontaining Int
m Int
n) (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 (Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Day -> Day
nextmonth (Day -> Day) -> (Day -> Day) -> Day -> Day
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> Day
nextyear) DateSpan
s
-- splitSpan (WeekOfYear n)    s = splitspan startofweek    (applyN n nextweek)    s
-- splitSpan (MonthOfYear n)   s = splitspan startofmonth   (applyN n nextmonth)   s
-- splitSpan (QuarterOfYear n) s = splitspan startofquarter (applyN n nextquarter) s

-- Split the given span using the provided helper functions:
-- start is applied to the span's start date to get the first sub-span's start date
-- next is applied to a sub-span's start date to get the next sub-span's start date
splitspan :: (Day -> Day) -> (Day -> Day) -> DateSpan -> [DateSpan]
splitspan :: (Day -> Day) -> (Day -> Day) -> DateSpan -> [DateSpan]
splitspan Day -> Day
_ Day -> Day
_ (DateSpan Maybe Day
Nothing Maybe Day
Nothing) = []
splitspan Day -> Day
start Day -> Day
next (DateSpan Maybe Day
Nothing (Just Day
e)) = (Day -> Day) -> (Day -> Day) -> DateSpan -> [DateSpan]
splitspan Day -> Day
start Day -> Day
next (Maybe Day -> Maybe Day -> DateSpan
DateSpan (Day -> Maybe Day
forall a. a -> Maybe a
Just (Day -> Maybe Day) -> Day -> Maybe Day
forall a b. (a -> b) -> a -> b
$ Day -> Day
start Day
e) (Day -> Maybe Day
forall a. a -> Maybe a
Just (Day -> Maybe Day) -> Day -> Maybe Day
forall a b. (a -> b) -> a -> b
$ Day -> Day
next (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ Day -> Day
start Day
e))
splitspan Day -> Day
start Day -> Day
next (DateSpan (Just Day
s) Maybe Day
Nothing) = (Day -> Day) -> (Day -> Day) -> DateSpan -> [DateSpan]
splitspan Day -> Day
start Day -> Day
next (Maybe Day -> Maybe Day -> DateSpan
DateSpan (Day -> Maybe Day
forall a. a -> Maybe a
Just (Day -> Maybe Day) -> Day -> Maybe Day
forall a b. (a -> b) -> a -> b
$ Day -> Day
start Day
s) (Day -> Maybe Day
forall a. a -> Maybe a
Just (Day -> Maybe Day) -> Day -> Maybe Day
forall a b. (a -> b) -> a -> b
$ Day -> Day
next (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ Day -> Day
start Day
s))
splitspan Day -> Day
start Day -> Day
next span :: DateSpan
span@(DateSpan (Just Day
s) (Just Day
e))
    | Day
s Day -> Day -> Bool
forall a. Eq a => a -> a -> Bool
== Day
e = [DateSpan
span]
    | Bool
otherwise = (Day -> Day) -> (Day -> Day) -> DateSpan -> [DateSpan]
splitspan' Day -> Day
start Day -> Day
next DateSpan
span
    where
      splitspan' :: (Day -> Day) -> (Day -> Day) -> DateSpan -> [DateSpan]
splitspan' Day -> Day
start Day -> Day
next (DateSpan (Just Day
s) (Just Day
e))
          | Day
s Day -> Day -> Bool
forall a. Ord a => a -> a -> Bool
>= Day
e = []
          | Bool
otherwise = Maybe Day -> Maybe Day -> DateSpan
DateSpan (Day -> Maybe Day
forall a. a -> Maybe a
Just Day
subs) (Day -> Maybe Day
forall a. a -> Maybe a
Just Day
sube) DateSpan -> [DateSpan] -> [DateSpan]
forall a. a -> [a] -> [a]
: (Day -> Day) -> (Day -> Day) -> DateSpan -> [DateSpan]
splitspan' Day -> Day
start Day -> Day
next (Maybe Day -> Maybe Day -> DateSpan
DateSpan (Day -> Maybe Day
forall a. a -> Maybe a
Just Day
sube) (Day -> Maybe Day
forall a. a -> Maybe a
Just Day
e))
          where subs :: Day
subs = Day -> Day
start Day
s
                sube :: Day
sube = Day -> Day
next Day
subs
      splitspan' Day -> Day
_ Day -> Day
_ DateSpan
_ = String -> [DateSpan]
forall a. String -> a
error' String
"won't happen, avoids warnings"  -- PARTIAL:

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

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

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

-- | 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)

-- | Calculate the intersection of a number of datespans.
spansIntersect :: [DateSpan] -> DateSpan
spansIntersect [] = DateSpan
nulldatespan
spansIntersect [DateSpan
d] = DateSpan
d
spansIntersect (DateSpan
d:[DateSpan]
ds) = DateSpan
d DateSpan -> DateSpan -> DateSpan
`spanIntersect` ([DateSpan] -> DateSpan
spansIntersect [DateSpan]
ds)

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

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

-- | Calculate the union of a number of datespans.
spansUnion :: [DateSpan] -> DateSpan
spansUnion [] = DateSpan
nulldatespan
spansUnion [DateSpan
d] = DateSpan
d
spansUnion (DateSpan
d:[DateSpan]
ds) = DateSpan
d DateSpan -> DateSpan -> DateSpan
`spanUnion` ([DateSpan] -> DateSpan
spansUnion [DateSpan]
ds)

-- | Calculate the union of two datespans.
spanUnion :: DateSpan -> DateSpan -> DateSpan
spanUnion (DateSpan Maybe Day
b1 Maybe Day
e1) (DateSpan Maybe Day
b2 Maybe Day
e2) = Maybe Day -> Maybe Day -> DateSpan
DateSpan Maybe Day
b Maybe Day
e
    where
      b :: Maybe Day
b = Maybe Day -> Maybe Day -> Maybe Day
forall a. Ord a => Maybe a -> Maybe a -> Maybe a
earliest Maybe Day
b1 Maybe Day
b2
      e :: Maybe Day
e = Maybe Day -> Maybe Day -> Maybe Day
forall a. Ord a => Maybe a -> Maybe a -> Maybe a
latest Maybe Day
e1 Maybe Day
e2

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

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

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

-- | 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
span <- DateSpan -> Set DateSpan -> Maybe DateSpan
forall a. Ord a => a -> Set a -> Maybe a
Set.lookupLT DateSpan
supSpan Set DateSpan
spanSet
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ DateSpan -> Day -> Bool
spanContainsDate DateSpan
span Day
day
        DateSpan -> Maybe DateSpan
forall (m :: * -> *) a. Monad m => a -> m a
return DateSpan
span
      where
        -- The smallest DateSpan larger than any DateSpan containing day.
        supSpan :: DateSpan
supSpan = Maybe Day -> Maybe Day -> DateSpan
DateSpan (Day -> Maybe Day
forall a. a -> Maybe a
Just (Day -> Maybe Day) -> Day -> Maybe Day
forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addDays Integer
1 Day
day) Maybe Day
forall a. Maybe a
Nothing

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

-- | Parse a period expression to an Interval and overall DateSpan using
-- the provided reference date, or return a parse error.
parsePeriodExpr
  :: Day -> Text -> Either (ParseErrorBundle Text CustomErr) (Interval, DateSpan)
parsePeriodExpr :: Day
-> Text
-> Either (ParseErrorBundle Text CustomErr) (Interval, DateSpan)
parsePeriodExpr Day
refdate Text
s = Parsec CustomErr Text (Interval, DateSpan)
-> Text
-> Either (ParseErrorBundle Text CustomErr) (Interval, DateSpan)
forall e a.
Parsec e Text a -> Text -> Either (ParseErrorBundle Text e) a
parsewith (Day -> Parsec CustomErr Text (Interval, DateSpan)
forall (m :: * -> *). Day -> TextParser m (Interval, DateSpan)
periodexprp Day
refdate Parsec CustomErr Text (Interval, DateSpan)
-> ParsecT CustomErr Text Identity ()
-> Parsec CustomErr Text (Interval, DateSpan)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT CustomErr 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 =
  (ParseErrorBundle Text CustomErr -> (Interval, DateSpan))
-> ((Interval, DateSpan) -> (Interval, DateSpan))
-> Either (ParseErrorBundle Text CustomErr) (Interval, DateSpan)
-> (Interval, DateSpan)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> (Interval, DateSpan)
forall a. String -> a
error' (String -> (Interval, DateSpan))
-> (ParseErrorBundle Text CustomErr -> String)
-> ParseErrorBundle Text CustomErr
-> (Interval, DateSpan)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"failed to parse:" String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS
-> (ParseErrorBundle Text CustomErr -> String)
-> ParseErrorBundle Text CustomErr
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseErrorBundle Text CustomErr -> String
customErrorBundlePretty) (Interval, DateSpan) -> (Interval, DateSpan)
forall a. a -> a
id (Either (ParseErrorBundle Text CustomErr) (Interval, DateSpan)
 -> (Interval, DateSpan))
-> Either (ParseErrorBundle Text CustomErr) (Interval, DateSpan)
-> (Interval, DateSpan)
forall a b. (a -> b) -> a -> b
$  -- PARTIAL:
  Day
-> Text
-> Either (ParseErrorBundle Text CustomErr) (Interval, DateSpan)
parsePeriodExpr Day
refdate Text
s

maybePeriod :: Day -> Text -> Maybe (Interval,DateSpan)
maybePeriod :: Day -> Text -> Maybe (Interval, DateSpan)
maybePeriod Day
refdate = (ParseErrorBundle Text CustomErr -> Maybe (Interval, DateSpan))
-> ((Interval, DateSpan) -> Maybe (Interval, DateSpan))
-> Either (ParseErrorBundle Text CustomErr) (Interval, DateSpan)
-> Maybe (Interval, DateSpan)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe (Interval, DateSpan)
-> ParseErrorBundle Text CustomErr -> Maybe (Interval, DateSpan)
forall a b. a -> b -> a
const Maybe (Interval, DateSpan)
forall a. Maybe a
Nothing) (Interval, DateSpan) -> Maybe (Interval, DateSpan)
forall a. a -> Maybe a
Just (Either (ParseErrorBundle Text CustomErr) (Interval, DateSpan)
 -> Maybe (Interval, DateSpan))
-> (Text
    -> Either (ParseErrorBundle Text CustomErr) (Interval, DateSpan))
-> Text
-> Maybe (Interval, DateSpan)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day
-> Text
-> Either (ParseErrorBundle Text CustomErr) (Interval, DateSpan)
parsePeriodExpr Day
refdate

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

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

spanFromSmartDate :: Day -> SmartDate -> DateSpan
spanFromSmartDate :: Day -> SmartDate -> DateSpan
spanFromSmartDate Day
refdate SmartDate
sdate = Maybe Day -> Maybe Day -> DateSpan
DateSpan (Day -> Maybe Day
forall a. a -> Maybe a
Just Day
b) (Day -> Maybe Day
forall a. a -> Maybe a
Just Day
e)
    where
      (Integer
ry,Int
rm,Int
_) = Day -> (Integer, Int, Int)
toGregorian Day
refdate
      (Day
b,Day
e) = SmartDate -> (Day, Day)
span SmartDate
sdate
      span :: SmartDate -> (Day,Day)
      span :: SmartDate -> (Day, Day)
span (SmartRelative SmartSequence
This SmartInterval
Day)                 = (Day
refdate, Day -> Day
nextday Day
refdate)
      span (SmartRelative SmartSequence
Last SmartInterval
Day)                 = (Day -> Day
prevday Day
refdate, Day
refdate)
      span (SmartRelative SmartSequence
Next SmartInterval
Day)                 = (Day -> Day
nextday Day
refdate, Integer -> Day -> Day
addDays Integer
2 Day
refdate)
      span (SmartRelative SmartSequence
This SmartInterval
Week)                = (Day -> Day
thisweek Day
refdate, Day -> Day
nextweek Day
refdate)
      span (SmartRelative SmartSequence
Last SmartInterval
Week)                = (Day -> Day
prevweek Day
refdate, Day -> Day
thisweek Day
refdate)
      span (SmartRelative SmartSequence
Next SmartInterval
Week)                = (Day -> Day
nextweek Day
refdate, Day -> Day
startofweek (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addDays Integer
14 Day
refdate)
      span (SmartRelative SmartSequence
This SmartInterval
Month)               = (Day -> Day
thismonth Day
refdate, Day -> Day
nextmonth Day
refdate)
      span (SmartRelative SmartSequence
Last SmartInterval
Month)               = (Day -> Day
prevmonth Day
refdate, Day -> Day
thismonth Day
refdate)
      span (SmartRelative SmartSequence
Next SmartInterval
Month)               = (Day -> Day
nextmonth Day
refdate, Day -> Day
startofmonth (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addGregorianMonthsClip Integer
2 Day
refdate)
      span (SmartRelative SmartSequence
This SmartInterval
Quarter)             = (Day -> Day
thisquarter Day
refdate, Day -> Day
nextquarter Day
refdate)
      span (SmartRelative SmartSequence
Last SmartInterval
Quarter)             = (Day -> Day
prevquarter Day
refdate, Day -> Day
thisquarter Day
refdate)
      span (SmartRelative SmartSequence
Next SmartInterval
Quarter)             = (Day -> Day
nextquarter Day
refdate, Day -> Day
startofquarter (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addGregorianMonthsClip Integer
6 Day
refdate)
      span (SmartRelative SmartSequence
This SmartInterval
Year)                = (Day -> Day
thisyear Day
refdate, Day -> Day
nextyear Day
refdate)
      span (SmartRelative SmartSequence
Last SmartInterval
Year)                = (Day -> Day
prevyear Day
refdate, Day -> Day
thisyear Day
refdate)
      span (SmartRelative SmartSequence
Next SmartInterval
Year)                = (Day -> Day
nextyear Day
refdate, Day -> Day
startofyear (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addGregorianYearsClip Integer
2 Day
refdate)
      span (SmartAssumeStart Integer
y Maybe (Int, Maybe Int)
Nothing)             = (Day -> Day
startofyear Day
day, Day -> Day
nextyear Day
day) where day :: Day
day = Integer -> Int -> Int -> Day
fromGregorian Integer
y Int
1 Int
1
      span (SmartAssumeStart Integer
y (Just (Int
m, Maybe Int
Nothing))) = (Day -> Day
startofmonth Day
day, Day -> Day
nextmonth Day
day) where day :: Day
day = Integer -> Int -> Int -> Day
fromGregorian Integer
y Int
m Int
1
      span (SmartAssumeStart Integer
y (Just (Int
m, Just Int
d)))  = (Day
day, Day -> Day
nextday Day
day) where day :: Day
day = Integer -> Int -> Int -> Day
fromGregorian Integer
y Int
m Int
d
      span (SmartFromReference Maybe Int
m Int
d)                 = (Day
day, Day -> Day
nextday Day
day) where day :: Day
day = Integer -> Int -> Int -> Day
fromGregorian Integer
ry (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
rm Maybe Int
m) Int
d
      span (SmartMonth Int
m)                           = (Day -> Day
startofmonth Day
day, Day -> Day
nextmonth Day
day) where day :: Day
day = Integer -> Int -> Int -> Day
fromGregorian Integer
ry Int
m Int
1

-- 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 =
  (ParseErrorBundle Text CustomErr -> Text)
-> (Text -> Text)
-> Either (ParseErrorBundle Text CustomErr) Text
-> Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Text
forall a. String -> a
error' (String -> Text)
-> (ParseErrorBundle Text CustomErr -> String)
-> ParseErrorBundle Text CustomErr
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> ShowS
forall r. PrintfType r => String -> r
printf String
"could not parse date %s %s" (Text -> String
forall a. Show a => a -> String
show Text
s) ShowS
-> (ParseErrorBundle Text CustomErr -> String)
-> ParseErrorBundle Text CustomErr
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseErrorBundle Text CustomErr -> String
forall a. Show a => a -> String
show) Text -> Text
forall a. a -> a
id (Either (ParseErrorBundle Text CustomErr) Text -> Text)
-> Either (ParseErrorBundle Text CustomErr) Text -> Text
forall a b. (a -> b) -> a -> b
$  -- PARTIAL:
  (Day -> Text -> Either (ParseErrorBundle Text CustomErr) Text
fixSmartDateStrEither Day
d Text
s :: Either (ParseErrorBundle Text CustomErr) Text)

-- | A safe version of fixSmartDateStr.
fixSmartDateStrEither :: Day -> Text -> Either (ParseErrorBundle Text CustomErr) Text
fixSmartDateStrEither :: Day -> Text -> Either (ParseErrorBundle Text CustomErr) Text
fixSmartDateStrEither Day
d = (Day -> Text)
-> Either (ParseErrorBundle Text CustomErr) Day
-> Either (ParseErrorBundle Text CustomErr) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Day -> Text
showDate (Either (ParseErrorBundle Text CustomErr) Day
 -> Either (ParseErrorBundle Text CustomErr) Text)
-> (Text -> Either (ParseErrorBundle Text CustomErr) Day)
-> Text
-> Either (ParseErrorBundle Text CustomErr) Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> Text -> Either (ParseErrorBundle Text CustomErr) Day
fixSmartDateStrEither' Day
d

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

-- | Convert a SmartDate to an absolute date using the provided reference date.
--
-- ==== Examples:
-- >>> :set -XOverloadedStrings
-- >>> let t = fixSmartDateStr (fromGregorian 2008 11 26)
-- >>> t "0000-01-01"
-- "0000-01-01"
-- >>> t "1999-12-02"
-- "1999-12-02"
-- >>> t "1999.12.02"
-- "1999-12-02"
-- >>> t "1999/3/2"
-- "1999-03-02"
-- >>> t "19990302"
-- "1999-03-02"
-- >>> t "2008/2"
-- "2008-02-01"
-- >>> t "0020/2"
-- "0020-02-01"
-- >>> t "1000"
-- "1000-01-01"
-- >>> t "4/2"
-- "2008-04-02"
-- >>> t "2"
-- "2008-11-02"
-- >>> t "January"
-- "2008-01-01"
-- >>> t "feb"
-- "2008-02-01"
-- >>> t "today"
-- "2008-11-26"
-- >>> t "yesterday"
-- "2008-11-25"
-- >>> t "tomorrow"
-- "2008-11-27"
-- >>> t "this day"
-- "2008-11-26"
-- >>> t "last day"
-- "2008-11-25"
-- >>> t "next day"
-- "2008-11-27"
-- >>> t "this week"  -- last monday
-- "2008-11-24"
-- >>> t "last week"  -- previous monday
-- "2008-11-17"
-- >>> t "next week"  -- next monday
-- "2008-12-01"
-- >>> t "this month"
-- "2008-11-01"
-- >>> t "last month"
-- "2008-10-01"
-- >>> t "next month"
-- "2008-12-01"
-- >>> t "this quarter"
-- "2008-10-01"
-- >>> t "last quarter"
-- "2008-07-01"
-- >>> t "next quarter"
-- "2009-01-01"
-- >>> t "this year"
-- "2008-01-01"
-- >>> t "last year"
-- "2007-01-01"
-- >>> t "next year"
-- "2009-01-01"
--
-- t "last wed"
-- "2008-11-19"
-- t "next friday"
-- "2008-11-28"
-- t "next january"
-- "2009-01-01"
--
fixSmartDate :: Day -> SmartDate -> Day
fixSmartDate :: Day -> SmartDate -> Day
fixSmartDate Day
refdate = SmartDate -> Day
fix
  where
    fix :: SmartDate -> Day
    fix :: SmartDate -> Day
fix (SmartRelative SmartSequence
This SmartInterval
Day)     = Day
refdate
    fix (SmartRelative SmartSequence
Last SmartInterval
Day)     = Day -> Day
prevday Day
refdate
    fix (SmartRelative SmartSequence
Next SmartInterval
Day)     = Day -> Day
nextday Day
refdate
    fix (SmartRelative SmartSequence
This SmartInterval
Week)    = Day -> Day
thisweek Day
refdate
    fix (SmartRelative SmartSequence
Last SmartInterval
Week)    = Day -> Day
prevweek Day
refdate
    fix (SmartRelative SmartSequence
Next SmartInterval
Week)    = Day -> Day
nextweek Day
refdate
    fix (SmartRelative SmartSequence
This SmartInterval
Month)   = Day -> Day
thismonth Day
refdate
    fix (SmartRelative SmartSequence
Last SmartInterval
Month)   = Day -> Day
prevmonth Day
refdate
    fix (SmartRelative SmartSequence
Next SmartInterval
Month)   = Day -> Day
nextmonth Day
refdate
    fix (SmartRelative SmartSequence
This SmartInterval
Quarter) = Day -> Day
thisquarter Day
refdate
    fix (SmartRelative SmartSequence
Last SmartInterval
Quarter) = Day -> Day
prevquarter Day
refdate
    fix (SmartRelative SmartSequence
Next SmartInterval
Quarter) = Day -> Day
nextquarter Day
refdate
    fix (SmartRelative SmartSequence
This SmartInterval
Year)    = Day -> Day
thisyear Day
refdate
    fix (SmartRelative SmartSequence
Last SmartInterval
Year)    = Day -> Day
prevyear Day
refdate
    fix (SmartRelative SmartSequence
Next SmartInterval
Year)    = Day -> Day
nextyear Day
refdate
    fix (SmartAssumeStart Integer
y Maybe (Int, Maybe Int)
md)      = Integer -> Int -> Int -> Day
fromGregorian Integer
y (Int -> ((Int, Maybe Int) -> Int) -> Maybe (Int, Maybe Int) -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
1 (Int, Maybe Int) -> Int
forall a b. (a, b) -> a
fst Maybe (Int, Maybe Int)
md) (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
1 (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ (Int, Maybe Int) -> Maybe Int
forall a b. (a, b) -> b
snd ((Int, Maybe Int) -> Maybe Int)
-> Maybe (Int, Maybe Int) -> Maybe Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (Int, Maybe Int)
md)
    fix (SmartFromReference Maybe Int
m Int
d)     = Integer -> Int -> Int -> Day
fromGregorian Integer
ry (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
rm Maybe Int
m) Int
d
    fix (SmartMonth Int
m)               = Integer -> Int -> Int -> Day
fromGregorian Integer
ry Int
m Int
1
    (Integer
ry, Int
rm, Int
_) = Day -> (Integer, Int, Int)
toGregorian Day
refdate

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

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

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

thisquarter :: Day -> Day
thisquarter = Day -> Day
startofquarter
prevquarter :: Day -> Day
prevquarter = Day -> Day
startofquarter (Day -> Day) -> (Day -> Day) -> Day -> Day
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Day -> Day
addGregorianMonthsClip (-Integer
3)
nextquarter :: Day -> Day
nextquarter = Day -> Day
startofquarter (Day -> Day) -> (Day -> Day) -> Day -> Day
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Day -> Day
addGregorianMonthsClip Integer
3
startofquarter :: Day -> Day
startofquarter Day
day = Integer -> Int -> Int -> Day
fromGregorian Integer
y (Int -> Int
forall a. Integral a => a -> a
firstmonthofquarter Int
m) Int
1
    where
      (Integer
y,Int
m,Int
_) = Day -> (Integer, Int, Int)
toGregorian Day
day
      firstmonthofquarter :: a -> a
firstmonthofquarter a
m = ((a
ma -> a -> a
forall a. Num a => a -> a -> a
-a
1) a -> a -> a
forall a. Integral a => a -> a -> a
`div` a
3) a -> a -> a
forall a. Num a => a -> a -> a
* a
3 a -> a -> a
forall a. Num a => a -> a -> a
+ a
1

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

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

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

-- | 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

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

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

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

-- -- | Parse a couple of date-time string formats to a time type.
-- parsedatetimeM :: String -> Maybe LocalTime
-- parsedatetimeM s = asum [
--     parseTime defaultTimeLocale "%Y/%m/%d %H:%M:%S" s,
--     parseTime defaultTimeLocale "%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 :: String -> Maybe Day
parsedateM String
s = [Maybe Day] -> Maybe Day
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum [
     Bool -> TimeLocale -> String -> String -> Maybe Day
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
"%Y-%m-%d" String
s,
     Bool -> TimeLocale -> String -> String -> Maybe Day
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
"%Y/%m/%d" String
s,
     Bool -> TimeLocale -> String -> String -> Maybe Day
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
"%Y.%m.%d" String
s
     ]

{-|
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)
> 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 (SmartAssumeStart 2018 (Just (12,Just 1)))

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

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 :: 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
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 CustomErr Text m (Int, Int) -> TextParser m SmartDate
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT CustomErr Text m (Int, Int)
forall (m :: * -> *). TextParser m (Int, Int)
md
    , (Maybe Int -> Int -> SmartDate
SmartFromReference Maybe Int
forall a. Maybe a
Nothing (Int -> SmartDate)
-> ParsecT CustomErr Text m Int -> TextParser m SmartDate
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT CustomErr Text m Int
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal) TextParser m SmartDate
-> (SmartDate -> TextParser m SmartDate) -> TextParser m SmartDate
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SmartDate -> TextParser m SmartDate
forall (m :: * -> *). MonadFail m => SmartDate -> m SmartDate
failIfInvalidDate
    , Int -> SmartDate
SmartMonth (Int -> SmartDate)
-> ParsecT CustomErr Text m Int -> TextParser m SmartDate
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT CustomErr Text m Int
forall (m :: * -> *). TextParser m Int
month ParsecT CustomErr Text m Int
-> ParsecT CustomErr Text m Int -> ParsecT CustomErr Text m Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT CustomErr Text m Int
forall (m :: * -> *). TextParser m Int
mon)
    , SmartSequence -> SmartInterval -> SmartDate
SmartRelative SmartSequence
This SmartInterval
Day SmartDate
-> ParsecT CustomErr Text m Text -> TextParser m SmartDate
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens Text -> ParsecT CustomErr Text m (Tokens Text)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"today"
    , SmartSequence -> SmartInterval -> SmartDate
SmartRelative SmartSequence
Last SmartInterval
Day SmartDate
-> ParsecT CustomErr Text m Text -> TextParser m SmartDate
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens Text -> ParsecT CustomErr Text m (Tokens Text)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"yesterday"
    , SmartSequence -> SmartInterval -> SmartDate
SmartRelative SmartSequence
Next SmartInterval
Day SmartDate
-> ParsecT CustomErr Text m Text -> TextParser m SmartDate
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens Text -> ParsecT CustomErr Text m (Tokens Text)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"tomorrow"
    , (SmartSequence -> SmartInterval -> SmartDate)
-> ParsecT CustomErr Text m SmartSequence
-> ParsecT CustomErr Text m SmartInterval
-> TextParser m SmartDate
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 SmartSequence -> SmartInterval -> SmartDate
SmartRelative (ParsecT CustomErr Text m SmartSequence
seqP ParsecT CustomErr Text m SmartSequence
-> ParsecT CustomErr Text m ()
-> ParsecT CustomErr Text m SmartSequence
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT CustomErr Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT CustomErr s m ()
skipNonNewlineSpaces) ParsecT CustomErr Text m SmartInterval
intervalP
    ]
  where
    seqP :: ParsecT CustomErr Text m SmartSequence
seqP = [ParsecT CustomErr Text m SmartSequence]
-> ParsecT CustomErr Text m SmartSequence
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
choice [SmartSequence
This SmartSequence
-> ParsecT CustomErr Text m (Tokens Text)
-> ParsecT CustomErr Text m SmartSequence
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens Text -> ParsecT CustomErr Text m (Tokens Text)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"this", SmartSequence
Last SmartSequence
-> ParsecT CustomErr Text m (Tokens Text)
-> ParsecT CustomErr Text m SmartSequence
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens Text -> ParsecT CustomErr Text m (Tokens Text)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"last", SmartSequence
Next SmartSequence
-> ParsecT CustomErr Text m (Tokens Text)
-> ParsecT CustomErr Text m SmartSequence
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens Text -> ParsecT CustomErr Text m (Tokens Text)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"next"]
    intervalP :: ParsecT CustomErr Text m SmartInterval
intervalP = [ParsecT CustomErr Text m SmartInterval]
-> ParsecT CustomErr Text m SmartInterval
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
choice [SmartInterval
Day SmartInterval
-> ParsecT CustomErr Text m (Tokens Text)
-> ParsecT CustomErr Text m SmartInterval
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens Text -> ParsecT CustomErr 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 CustomErr Text m (Tokens Text)
-> ParsecT CustomErr Text m SmartInterval
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens Text -> ParsecT CustomErr 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 CustomErr Text m (Tokens Text)
-> ParsecT CustomErr Text m SmartInterval
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens Text -> ParsecT CustomErr 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 CustomErr Text m (Tokens Text)
-> ParsecT CustomErr Text m SmartInterval
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens Text -> ParsecT CustomErr 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 CustomErr Text m (Tokens Text)
-> ParsecT CustomErr Text m SmartInterval
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens Text -> ParsecT CustomErr Text m (Tokens Text)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Tokens Text
"year"]

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

datesepchars :: String
datesepchars :: String
datesepchars = String
"/-."

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

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

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

failIfInvalidDate :: Fail.MonadFail m => SmartDate -> m SmartDate
failIfInvalidDate :: SmartDate -> m SmartDate
failIfInvalidDate SmartDate
s = Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isValid (String -> m ()
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"bad smart date: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SmartDate -> String
forall a. Show a => a -> String
show SmartDate
s) m () -> m SmartDate -> m SmartDate
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> SmartDate -> m SmartDate
forall (m :: * -> *) a. Monad m => a -> m a
return SmartDate
s
  where isValid :: Bool
isValid = case SmartDate
s of
            SmartAssumeStart Integer
y (Just (Int
m, Maybe Int
md)) -> 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
y Int
m (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
1 Maybe Int
md)
            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

yyyymmdd :: TextParser m SmartDate
yyyymmdd :: TextParser m SmartDate
yyyymmdd = do
  Integer
y <- String -> Integer
forall a. Read a => String -> a
read (String -> Integer)
-> ParsecT CustomErr Text m String
-> ParsecT CustomErr Text m Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> ParsecT CustomErr Text m Char -> ParsecT CustomErr Text m String
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count Int
4 ParsecT CustomErr Text m Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar
  Int
m <- String -> Int
forall a. Read a => String -> a
read (String -> Int)
-> ParsecT CustomErr Text m String -> ParsecT CustomErr Text m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> ParsecT CustomErr Text m Char -> ParsecT CustomErr Text m String
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count Int
2 ParsecT CustomErr Text m Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar
  Maybe Int
d <- ParsecT CustomErr Text m Int
-> ParsecT CustomErr Text m (Maybe Int)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ParsecT CustomErr Text m Int
 -> ParsecT CustomErr Text m (Maybe Int))
-> ParsecT CustomErr Text m Int
-> ParsecT CustomErr Text m (Maybe Int)
forall a b. (a -> b) -> a -> b
$ String -> Int
forall a. Read a => String -> a
read (String -> Int)
-> ParsecT CustomErr Text m String -> ParsecT CustomErr Text m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> ParsecT CustomErr Text m Char -> ParsecT CustomErr Text m String
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count Int
2 ParsecT CustomErr Text m Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar
  let date :: SmartDate
date = Integer -> Maybe (Int, Maybe Int) -> SmartDate
SmartAssumeStart Integer
y (Maybe (Int, Maybe Int) -> SmartDate)
-> Maybe (Int, Maybe Int) -> SmartDate
forall a b. (a -> b) -> a -> b
$ (Int, Maybe Int) -> Maybe (Int, Maybe Int)
forall a. a -> Maybe a
Just (Int
m, Maybe Int
d)
  SmartDate -> TextParser m SmartDate
forall (m :: * -> *). MonadFail m => SmartDate -> m SmartDate
failIfInvalidDate SmartDate
date

ymd :: TextParser m SmartDate
ymd :: TextParser m SmartDate
ymd = do
    Integer
y <- TextParser m Integer
forall (m :: * -> *). TextParser m Integer
yearp
    (Maybe (Int, Maybe Int) -> SmartDate)
-> ParsecT CustomErr Text m (Maybe (Int, Maybe Int))
-> TextParser m SmartDate
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Integer -> Maybe (Int, Maybe Int) -> SmartDate
SmartAssumeStart Integer
y) (ParsecT CustomErr Text m (Maybe (Int, Maybe Int))
 -> TextParser m SmartDate)
-> (ParsecT CustomErr Text m (Int, Maybe Int)
    -> ParsecT CustomErr Text m (Maybe (Int, Maybe Int)))
-> ParsecT CustomErr Text m (Int, Maybe Int)
-> TextParser m SmartDate
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT CustomErr Text m (Int, Maybe Int)
-> ParsecT CustomErr Text m (Maybe (Int, Maybe Int))
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ParsecT CustomErr Text m (Int, Maybe Int)
 -> ParsecT CustomErr Text m (Maybe (Int, Maybe Int)))
-> (ParsecT CustomErr Text m (Int, Maybe Int)
    -> ParsecT CustomErr Text m (Int, Maybe Int))
-> ParsecT CustomErr Text m (Int, Maybe Int)
-> ParsecT CustomErr Text m (Maybe (Int, Maybe Int))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT CustomErr Text m (Int, Maybe Int)
-> ParsecT CustomErr Text m (Int, Maybe Int)
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT CustomErr Text m (Int, Maybe Int)
 -> TextParser m SmartDate)
-> ParsecT CustomErr Text m (Int, Maybe Int)
-> TextParser m SmartDate
forall a b. (a -> b) -> a -> b
$ do
        Char
sep <- TextParser m Char
forall (m :: * -> *). TextParser m Char
datesepchar
        Int
m <- ParsecT CustomErr Text m Int
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal
        Bool -> ParsecT CustomErr Text m () -> ParsecT CustomErr Text m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int -> Bool
validMonth Int
m) (ParsecT CustomErr Text m () -> ParsecT CustomErr Text m ())
-> ParsecT CustomErr Text m () -> ParsecT CustomErr Text m ()
forall a b. (a -> b) -> a -> b
$ String -> ParsecT CustomErr Text m ()
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String
"Bad month " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
m)
        (Maybe Int -> (Int, Maybe Int))
-> ParsecT CustomErr Text m (Maybe Int)
-> ParsecT CustomErr Text m (Int, Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int
m,) (ParsecT CustomErr Text m (Maybe Int)
 -> ParsecT CustomErr Text m (Int, Maybe Int))
-> (ParsecT CustomErr Text m Int
    -> ParsecT CustomErr Text m (Maybe Int))
-> ParsecT CustomErr Text m Int
-> ParsecT CustomErr Text m (Int, Maybe Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT CustomErr Text m Int
-> ParsecT CustomErr Text m (Maybe Int)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ParsecT CustomErr Text m Int
 -> ParsecT CustomErr Text m (Maybe Int))
-> (ParsecT CustomErr Text m Int -> ParsecT CustomErr Text m Int)
-> ParsecT CustomErr Text m Int
-> ParsecT CustomErr Text m (Maybe Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT CustomErr Text m Int -> ParsecT CustomErr Text m Int
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT CustomErr Text m Int
 -> ParsecT CustomErr Text m (Int, Maybe Int))
-> ParsecT CustomErr Text m Int
-> ParsecT CustomErr Text m (Int, Maybe Int)
forall a b. (a -> b) -> a -> b
$ do
            Char
_ <- Token Text -> ParsecT CustomErr 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 CustomErr Text m Int
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal
            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, Maybe Int) -> SmartDate
SmartAssumeStart Integer
y ((Int, Maybe Int) -> Maybe (Int, Maybe Int)
forall a. a -> Maybe a
Just (Int
m, Int -> Maybe Int
forall a. a -> Maybe a
Just Int
d))
            Int -> ParsecT CustomErr Text m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
d

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

-- | Parse a year number from a Text, making sure that at least four digits are
-- used.
yearp :: TextParser m Integer
yearp :: TextParser m Integer
yearp = do
  Text
year <- Maybe String
-> (Token Text -> Bool) -> ParsecT CustomErr Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P (String -> Maybe String
forall a. a -> Maybe a
Just String
"year") Char -> Bool
Token Text -> Bool
isDigit
  Bool -> ParsecT CustomErr Text m () -> ParsecT CustomErr 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 CustomErr Text m () -> ParsecT CustomErr Text m ())
-> (String -> ParsecT CustomErr Text m ())
-> String
-> ParsecT CustomErr Text m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ParsecT CustomErr Text m ()
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String -> ParsecT CustomErr Text m ())
-> String -> ParsecT CustomErr Text m ()
forall a b. (a -> b) -> a -> b
$ String
"Year must contain at least 4 digits: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
year
  Integer -> TextParser m Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> TextParser m Integer)
-> Integer -> TextParser m Integer
forall a b. (a -> b) -> a -> b
$ Text -> Integer
readDecimal Text
year

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

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

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

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

-- Parse a reporting interval.
reportingintervalp :: TextParser m Interval
reportingintervalp :: TextParser m Interval
reportingintervalp = [TextParser m Interval] -> TextParser m Interval
forall (m :: * -> *) a. [TextParser m a] -> TextParser m a
choice'
    [ String -> String -> (Int -> Interval) -> TextParser m Interval
forall (m :: * -> *).
String -> String -> (Int -> Interval) -> TextParser m Interval
tryinterval String
"day"     String
"daily"     Int -> Interval
Days
    , String -> String -> (Int -> Interval) -> TextParser m Interval
forall (m :: * -> *).
String -> String -> (Int -> Interval) -> TextParser m Interval
tryinterval String
"week"    String
"weekly"    Int -> Interval
Weeks
    , String -> String -> (Int -> Interval) -> TextParser m Interval
forall (m :: * -> *).
String -> String -> (Int -> Interval) -> TextParser m Interval
tryinterval String
"month"   String
"monthly"   Int -> Interval
Months
    , String -> String -> (Int -> Interval) -> TextParser m Interval
forall (m :: * -> *).
String -> String -> (Int -> Interval) -> TextParser m Interval
tryinterval String
"quarter" String
"quarterly" Int -> Interval
Quarters
    , String -> String -> (Int -> Interval) -> TextParser m Interval
forall (m :: * -> *).
String -> String -> (Int -> Interval) -> TextParser m Interval
tryinterval String
"year"    String
"yearly"    Int -> Interval
Years
    , Int -> Interval
Weeks Int
2 Interval -> ParsecT CustomErr Text m Text -> TextParser m Interval
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens Text -> ParsecT CustomErr 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 CustomErr Text m Text -> TextParser m Interval
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens Text -> ParsecT CustomErr 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 CustomErr Text m Text -> TextParser m Interval
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens Text -> ParsecT CustomErr 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 CustomErr 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 CustomErr Text m Text
-> ParsecT CustomErr Text m () -> ParsecT CustomErr Text m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT CustomErr Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT CustomErr s m ()
skipNonNewlineSpaces ParsecT CustomErr Text m ()
-> TextParser m Interval -> TextParser m Interval
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [TextParser m Interval] -> TextParser m Interval
forall (m :: * -> *) a. [TextParser m a] -> TextParser m a
choice'
        [ Int -> Interval
DayOfWeek (Int -> Interval)
-> ParsecT CustomErr Text m Int -> TextParser m Interval
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT CustomErr Text m Int
nth ParsecT CustomErr Text m Int
-> ParsecT CustomErr Text m () -> ParsecT CustomErr Text m Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT CustomErr Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT CustomErr s m ()
skipNonNewlineSpaces ParsecT CustomErr Text m Int
-> ParsecT CustomErr Text m Text -> ParsecT CustomErr Text m Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Tokens Text -> ParsecT CustomErr 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 CustomErr Text m Int
-> ParsecT CustomErr Text m Text -> ParsecT CustomErr Text m Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Tokens Text -> ParsecT CustomErr Text m (Tokens Text)
forall s (m :: * -> *).
(IsString (Tokens s), FoldCase (Tokens s), Stream s,
 Token s ~ Char) =>
Tokens s -> ParsecT CustomErr s m (Tokens s)
of_ Tokens Text
"week")
        , Int -> Interval
DayOfMonth (Int -> Interval)
-> ParsecT CustomErr Text m Int -> TextParser m Interval
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT CustomErr Text m Int
nth ParsecT CustomErr Text m Int
-> ParsecT CustomErr Text m () -> ParsecT CustomErr Text m Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT CustomErr Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT CustomErr s m ()
skipNonNewlineSpaces ParsecT CustomErr Text m Int
-> ParsecT CustomErr Text m Text -> ParsecT CustomErr Text m Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Tokens Text -> ParsecT CustomErr 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 CustomErr Text m Int
-> ParsecT CustomErr Text m (Maybe Text)
-> ParsecT CustomErr Text m Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Tokens Text -> ParsecT CustomErr Text m (Maybe (Tokens Text))
forall s (m :: * -> *).
(Stream s, IsString (Tokens s), FoldCase (Tokens s),
 Token s ~ Char) =>
Tokens s -> ParsecT CustomErr s m (Maybe (Tokens s))
optOf_ Tokens Text
"month")
        , (Int -> Int -> Interval)
-> ParsecT CustomErr Text m Int
-> ParsecT CustomErr Text m Int
-> TextParser m Interval
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Int -> Int -> Interval
WeekdayOfMonth ParsecT CustomErr Text m Int
nth (ParsecT CustomErr Text m Int -> TextParser m Interval)
-> ParsecT CustomErr Text m Int -> TextParser m Interval
forall a b. (a -> b) -> a -> b
$ ParsecT CustomErr Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT CustomErr s m ()
skipNonNewlineSpaces ParsecT CustomErr Text m ()
-> ParsecT CustomErr Text m Int -> ParsecT CustomErr Text m Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT CustomErr Text m Int
forall (m :: * -> *). TextParser m Int
weekday ParsecT CustomErr Text m Int
-> ParsecT CustomErr Text m (Maybe Text)
-> ParsecT CustomErr Text m Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Tokens Text -> ParsecT CustomErr Text m (Maybe (Tokens Text))
forall s (m :: * -> *).
(Stream s, IsString (Tokens s), FoldCase (Tokens s),
 Token s ~ Char) =>
Tokens s -> ParsecT CustomErr s m (Maybe (Tokens s))
optOf_ Tokens Text
"month"
        , (Int -> Int -> Interval) -> (Int, Int) -> Interval
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Int -> Interval
DayOfYear ((Int, Int) -> Interval)
-> ParsecT CustomErr Text m (Int, Int) -> TextParser m Interval
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT CustomErr Text m (Int, Int)
forall (m :: * -> *). TextParser m (Int, Int)
md ParsecT CustomErr Text m (Int, Int)
-> ParsecT CustomErr Text m (Maybe Text)
-> ParsecT CustomErr Text m (Int, Int)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Tokens Text -> ParsecT CustomErr Text m (Maybe (Tokens Text))
forall s (m :: * -> *).
(Stream s, IsString (Tokens s), FoldCase (Tokens s),
 Token s ~ Char) =>
Tokens s -> ParsecT CustomErr s m (Maybe (Tokens s))
optOf_ Tokens Text
"year")
        , Int -> Interval
DayOfWeek (Int -> Interval)
-> ParsecT CustomErr Text m Int -> TextParser m Interval
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT CustomErr Text m Int
forall (m :: * -> *). TextParser m Int
weekday
        , TextParser m Interval
d_o_y TextParser m Interval
-> ParsecT CustomErr Text m (Maybe Text) -> TextParser m Interval
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Tokens Text -> ParsecT CustomErr Text m (Maybe (Tokens Text))
forall s (m :: * -> *).
(Stream s, IsString (Tokens s), FoldCase (Tokens s),
 Token s ~ Char) =>
Tokens s -> ParsecT CustomErr s m (Maybe (Tokens s))
optOf_ Tokens Text
"year"
        ]
    ]
  where
    of_ :: Tokens s -> ParsecT CustomErr s m (Tokens s)
of_ Tokens s
period =
      ParsecT CustomErr s m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT CustomErr s m ()
skipNonNewlineSpaces ParsecT CustomErr s m ()
-> ParsecT CustomErr s m (Tokens s)
-> ParsecT CustomErr s m (Tokens s)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Tokens s -> ParsecT CustomErr 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 CustomErr s m (Tokens s)
-> ParsecT CustomErr s m () -> ParsecT CustomErr s m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT CustomErr s m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT CustomErr s m ()
skipNonNewlineSpaces ParsecT CustomErr s m ()
-> ParsecT CustomErr s m (Tokens s)
-> ParsecT CustomErr s m (Tokens s)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Tokens s -> ParsecT CustomErr 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 CustomErr s m (Maybe (Tokens s))
optOf_ Tokens s
period = ParsecT CustomErr s m (Tokens s)
-> ParsecT CustomErr s m (Maybe (Tokens s))
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ParsecT CustomErr s m (Tokens s)
 -> ParsecT CustomErr s m (Maybe (Tokens s)))
-> (ParsecT CustomErr s m (Tokens s)
    -> ParsecT CustomErr s m (Tokens s))
-> ParsecT CustomErr s m (Tokens s)
-> ParsecT CustomErr s m (Maybe (Tokens s))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT CustomErr s m (Tokens s)
-> ParsecT CustomErr s m (Tokens s)
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT CustomErr s m (Tokens s)
 -> ParsecT CustomErr s m (Maybe (Tokens s)))
-> ParsecT CustomErr s m (Tokens s)
-> ParsecT CustomErr s m (Maybe (Tokens s))
forall a b. (a -> b) -> a -> b
$ Tokens s -> ParsecT CustomErr s m (Tokens s)
forall s (m :: * -> *).
(IsString (Tokens s), FoldCase (Tokens s), Stream s,
 Token s ~ Char) =>
Tokens s -> ParsecT CustomErr s m (Tokens s)
of_ Tokens s
period

    nth :: ParsecT CustomErr Text m Int
nth = ParsecT CustomErr Text m Int
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal ParsecT CustomErr Text m Int
-> ParsecT CustomErr Text m (Tokens Text)
-> ParsecT CustomErr Text m Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* [ParsecT CustomErr Text m (Tokens Text)]
-> ParsecT CustomErr Text m (Tokens Text)
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
choice ((Tokens Text -> ParsecT CustomErr Text m (Tokens Text))
-> [Tokens Text] -> [ParsecT CustomErr Text m (Tokens Text)]
forall a b. (a -> b) -> [a] -> [b]
map Tokens Text -> ParsecT CustomErr 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 CustomErr Text m) Interval
-> TextParser m Interval
forall (m :: * -> *) a. Alternative m => Permutation m a -> m a
runPermutation (Permutation (ParsecT CustomErr Text m) Interval
 -> TextParser m Interval)
-> Permutation (ParsecT CustomErr Text m) Interval
-> TextParser m Interval
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Interval)
-> Permutation (ParsecT CustomErr Text m) Int
-> Permutation (ParsecT CustomErr Text m) Int
-> Permutation (ParsecT CustomErr Text m) Interval
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Int -> Int -> Interval
DayOfYear (ParsecT CustomErr Text m Int
-> Permutation (ParsecT CustomErr Text m) Int
forall (m :: * -> *) a. Alternative m => m a -> Permutation m a
toPermutation (ParsecT CustomErr Text m Int
 -> Permutation (ParsecT CustomErr Text m) Int)
-> ParsecT CustomErr Text m Int
-> Permutation (ParsecT CustomErr Text m) Int
forall a b. (a -> b) -> a -> b
$ (ParsecT CustomErr Text m Int
forall (m :: * -> *). TextParser m Int
month ParsecT CustomErr Text m Int
-> ParsecT CustomErr Text m Int -> ParsecT CustomErr Text m Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT CustomErr Text m Int
forall (m :: * -> *). TextParser m Int
mon) ParsecT CustomErr Text m Int
-> ParsecT CustomErr Text m () -> ParsecT CustomErr Text m Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT CustomErr Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT CustomErr s m ()
skipNonNewlineSpaces)
                                              (ParsecT CustomErr Text m Int
-> Permutation (ParsecT CustomErr Text m) Int
forall (m :: * -> *) a. Alternative m => m a -> Permutation m a
toPermutation (ParsecT CustomErr Text m Int
 -> Permutation (ParsecT CustomErr Text m) Int)
-> ParsecT CustomErr Text m Int
-> Permutation (ParsecT CustomErr Text m) Int
forall a b. (a -> b) -> a -> b
$ ParsecT CustomErr Text m Int
nth ParsecT CustomErr Text m Int
-> ParsecT CustomErr Text m () -> ParsecT CustomErr Text m Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT CustomErr Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT CustomErr s m ()
skipNonNewlineSpaces)

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

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

-- |
-- >>> 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 :: Day -> TextParser m DateSpan
doubledatespanp Day
rdate = (SmartDate -> SmartDate -> DateSpan)
-> ParsecT CustomErr Text m SmartDate
-> ParsecT CustomErr Text m SmartDate
-> TextParser m DateSpan
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 SmartDate -> SmartDate -> DateSpan
fromToSpan
    (ParsecT CustomErr Text m () -> ParsecT CustomErr Text m (Maybe ())
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Tokens Text -> ParsecT CustomErr 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 CustomErr Text m Text
-> ParsecT CustomErr Text m () -> ParsecT CustomErr Text m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT CustomErr Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT CustomErr s m ()
skipNonNewlineSpaces) ParsecT CustomErr Text m (Maybe ())
-> ParsecT CustomErr Text m SmartDate
-> ParsecT CustomErr Text m SmartDate
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT CustomErr Text m SmartDate
forall (m :: * -> *). TextParser m SmartDate
smartdate)
    (ParsecT CustomErr Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT CustomErr s m ()
skipNonNewlineSpaces ParsecT CustomErr Text m ()
-> ParsecT CustomErr Text m Text -> ParsecT CustomErr Text m Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [ParsecT CustomErr Text m Text] -> ParsecT CustomErr Text m Text
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
choice [Tokens Text -> ParsecT CustomErr 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 CustomErr Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"..", Tokens Text -> ParsecT CustomErr Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"-"]
    ParsecT CustomErr Text m Text
-> ParsecT CustomErr Text m () -> ParsecT CustomErr Text m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT CustomErr Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT CustomErr s m ()
skipNonNewlineSpaces ParsecT CustomErr Text m ()
-> ParsecT CustomErr Text m SmartDate
-> ParsecT CustomErr Text m SmartDate
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT CustomErr Text m SmartDate
forall (m :: * -> *). TextParser m SmartDate
smartdate)
  where
    fromToSpan :: SmartDate -> SmartDate -> DateSpan
fromToSpan = Maybe Day -> Maybe Day -> DateSpan
DateSpan (Maybe Day -> Maybe Day -> DateSpan)
-> (SmartDate -> Maybe Day) -> SmartDate -> SmartDate -> DateSpan
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Day -> Maybe Day
forall a. a -> Maybe a
Just (Day -> Maybe Day) -> (SmartDate -> Day) -> SmartDate -> Maybe Day
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> SmartDate -> Day
fixSmartDate Day
rdate)

-- |
-- >>> 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 :: Day -> TextParser m DateSpan
quarterdatespanp Day
rdate = do
    Integer
y <- TextParser m Integer
forall (m :: * -> *). TextParser m Integer
yearp TextParser m Integer
-> TextParser m Integer -> TextParser m Integer
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Integer -> TextParser m Integer
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Integer, Int, Int) -> Integer
forall a b c. (a, b, c) -> a
first3 ((Integer, Int, Int) -> Integer) -> (Integer, Int, Int) -> Integer
forall a b. (a -> b) -> a -> b
$ Day -> (Integer, Int, Int)
toGregorian Day
rdate)
    Char
q <- Token Text -> ParsecT CustomErr 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 CustomErr Text m Char
-> ParsecT CustomErr Text m Char -> ParsecT CustomErr Text m Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Token Text -> Bool) -> ParsecT CustomErr Text m (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
Token Text -> Bool
is4Digit
    DateSpan -> TextParser m DateSpan
forall (m :: * -> *) a. Monad m => a -> m a
return (DateSpan -> TextParser m DateSpan)
-> (Period -> DateSpan) -> Period -> TextParser m DateSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Period -> DateSpan
periodAsDateSpan (Period -> TextParser m DateSpan)
-> Period -> TextParser m DateSpan
forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Period
QuarterPeriod Integer
y (Char -> Int
digitToInt Char
q)
  where
    is4Digit :: Char -> Bool
is4Digit Char
c = (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'1') :: Word) Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
<= Word
3

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

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

justdatespanp :: Day -> TextParser m DateSpan
justdatespanp :: Day -> TextParser m DateSpan
justdatespanp Day
rdate =
    ParsecT CustomErr Text m () -> ParsecT CustomErr Text m (Maybe ())
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Tokens Text -> ParsecT CustomErr 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 CustomErr Text m Text
-> ParsecT CustomErr Text m () -> ParsecT CustomErr Text m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT CustomErr Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT CustomErr s m ()
skipNonNewlineSpaces)
    ParsecT CustomErr Text m (Maybe ())
-> TextParser m DateSpan -> TextParser m DateSpan
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Day -> SmartDate -> DateSpan
spanFromSmartDate Day
rdate (SmartDate -> DateSpan)
-> ParsecT CustomErr Text m SmartDate -> TextParser m DateSpan
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT CustomErr Text m SmartDate
forall (m :: * -> *). TextParser m SmartDate
smartdate)

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

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

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