1174 lines
44 KiB
Haskell
1174 lines
44 KiB
Haskell
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE NoMonoLocalBinds #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-|
|
|
|
|
Date parsing and utilities for hledger.
|
|
|
|
For date and time values, we use the standard Day and UTCTime types.
|
|
|
|
A 'SmartDate' is a date which may be partially-specified or relative.
|
|
Eg 2008\/12\/31, but also 2008\/12, 12\/31, tomorrow, last week, next year,
|
|
in 5 days, in -3 quarters.
|
|
We represent these as a triple of strings like (\"2008\",\"12\",\"\"),
|
|
(\"\",\"\",\"tomorrow\"), (\"\",\"last\",\"week\").
|
|
|
|
A 'DateSpan' is the span of time between two specific calendar dates, or
|
|
an open-ended span where one or both dates are unspecified. (A date span
|
|
with both ends unspecified matches all dates.)
|
|
|
|
An 'Interval' is ledger's \"reporting interval\" - weekly, monthly,
|
|
quarterly, etc.
|
|
|
|
'Period' will probably replace DateSpan in due course.
|
|
|
|
-}
|
|
|
|
-- XXX fromGregorian silently clips bad dates, use fromGregorianValid instead ?
|
|
|
|
module Hledger.Data.Dates (
|
|
-- * Misc date handling utilities
|
|
fromEFDay,
|
|
modifyEFDay,
|
|
getCurrentDay,
|
|
getCurrentMonth,
|
|
getCurrentYear,
|
|
nulldate,
|
|
spanContainsDate,
|
|
periodContainsDate,
|
|
parsedate,
|
|
showDate,
|
|
showEFDate,
|
|
showDateSpan,
|
|
showDateSpanDebug,
|
|
showDateSpanAbbrev,
|
|
elapsedSeconds,
|
|
prevday,
|
|
periodexprp,
|
|
parsePeriodExpr,
|
|
parsePeriodExpr',
|
|
nulldatespan,
|
|
emptydatespan,
|
|
datesepchar,
|
|
datesepchars,
|
|
isDateSepChar,
|
|
spanStart,
|
|
spanEnd,
|
|
spanStartYear,
|
|
spanEndYear,
|
|
spanYears,
|
|
spansSpan,
|
|
spanIntersect,
|
|
spansIntersect,
|
|
spanDefaultsFrom,
|
|
spanValidDefaultsFrom,
|
|
spanExtend,
|
|
spanUnion,
|
|
spansUnion,
|
|
daysSpan,
|
|
latestSpanContaining,
|
|
smartdate,
|
|
groupByDateSpan,
|
|
fixSmartDate,
|
|
fixSmartDateStr,
|
|
fixSmartDateStrEither,
|
|
fixSmartDateStrEither',
|
|
yearp,
|
|
daysInSpan,
|
|
|
|
-- Temp exports
|
|
startofyear,
|
|
startofquarter,
|
|
startofmonth,
|
|
startofweek,
|
|
nextday,
|
|
nextweek,
|
|
nextmonthandday,
|
|
nextnthdayofmonth,
|
|
prevNthWeekdayOfMonth,
|
|
nthdayofweekcontaining,
|
|
addGregorianMonthsToMonthday,
|
|
advanceToNthWeekday,
|
|
nextNthWeekdayOfMonth,
|
|
isEmptySpan
|
|
) where
|
|
|
|
import Prelude hiding (Applicative(..))
|
|
import Control.Applicative (Applicative(..))
|
|
import Control.Applicative.Permutations
|
|
import Control.Monad (guard, unless)
|
|
import Control.Monad.Fail qualified as Fail (MonadFail, fail)
|
|
import Data.Char (digitToInt, isDigit)
|
|
import Data.Default (def)
|
|
import Data.Foldable (asum)
|
|
import Data.Function (on)
|
|
import Data.Functor (($>))
|
|
import Data.List (elemIndex, group, sort, sortBy)
|
|
import Data.Maybe (catMaybes, fromMaybe, isJust, mapMaybe)
|
|
import Data.Ord (comparing)
|
|
import Data.Set qualified as Set
|
|
import Data.Text (Text)
|
|
import Data.Text qualified as T
|
|
import Data.Time.Format hiding (months)
|
|
import Data.Time.Calendar
|
|
(Day, addDays, addGregorianYearsClip, addGregorianMonthsClip, diffDays,
|
|
fromGregorian, fromGregorianValid, toGregorian)
|
|
import Data.Time.Calendar.OrdinalDate (fromMondayStartWeek, mondayStartWeek)
|
|
import Data.Time.Clock (UTCTime, diffUTCTime)
|
|
import Data.Time.LocalTime (getZonedTime, localDay, zonedTimeToLocalTime)
|
|
import Safe (headErr, headMay, lastMay, maximumMay, minimumMay)
|
|
import Text.Megaparsec
|
|
import Text.Megaparsec.Char (char, char', digitChar, string, string')
|
|
import Text.Megaparsec.Char.Lexer (decimal, signed)
|
|
import Text.Printf (printf)
|
|
|
|
import Hledger.Data.Types
|
|
import Hledger.Data.Period
|
|
import Hledger.Utils
|
|
|
|
|
|
-- Help ppShow parse and line-wrap DateSpans better in debug output.
|
|
instance Show DateSpan where
|
|
show s = "DateSpan " ++ T.unpack (showDateSpan s)
|
|
|
|
showDate :: Day -> Text
|
|
showDate = T.pack . show
|
|
|
|
showEFDate :: EFDay -> Text
|
|
showEFDate = showDate . fromEFDay
|
|
|
|
-- | Render a datespan as a display string, abbreviating into a
|
|
-- compact form if possible.
|
|
-- Warning, hides whether dates are Exact or Flex.
|
|
showDateSpan :: DateSpan -> Text
|
|
showDateSpan = showPeriod . dateSpanAsPeriod
|
|
|
|
-- | Show a DateSpan with its begin/end dates, exact or flex.
|
|
showDateSpanDebug :: DateSpan -> String
|
|
showDateSpanDebug (DateSpan b e)= "DateSpan (" <> show b <> ") (" <> show e <> ")"
|
|
|
|
-- | Like showDateSpan, but show month spans as just the abbreviated month name
|
|
-- in the current locale.
|
|
showDateSpanAbbrev :: DateSpan -> Text
|
|
showDateSpanAbbrev = showPeriodAbbrev . dateSpanAsPeriod
|
|
|
|
-- | Get the current local date.
|
|
getCurrentDay :: IO Day
|
|
getCurrentDay = localDay . zonedTimeToLocalTime <$> getZonedTime
|
|
|
|
-- | Get the current local month number.
|
|
getCurrentMonth :: IO Int
|
|
getCurrentMonth = second3 . toGregorian <$> getCurrentDay
|
|
|
|
-- | Get the current local year.
|
|
getCurrentYear :: IO Integer
|
|
getCurrentYear = first3 . toGregorian <$> getCurrentDay
|
|
|
|
elapsedSeconds :: Fractional a => UTCTime -> UTCTime -> a
|
|
elapsedSeconds t1 = realToFrac . diffUTCTime t1
|
|
|
|
spanStart :: DateSpan -> Maybe Day
|
|
spanStart (DateSpan d _) = fromEFDay <$> d
|
|
|
|
spanEnd :: DateSpan -> Maybe Day
|
|
spanEnd (DateSpan _ d) = fromEFDay <$> d
|
|
|
|
spanStartDate :: DateSpan -> Maybe EFDay
|
|
spanStartDate (DateSpan d _) = d
|
|
|
|
spanEndDate :: DateSpan -> Maybe EFDay
|
|
spanEndDate (DateSpan _ d) = d
|
|
|
|
spanStartYear :: DateSpan -> Maybe Year
|
|
spanStartYear (DateSpan d _) = fmap (first3 . toGregorian . fromEFDay) d
|
|
|
|
spanEndYear :: DateSpan -> Maybe Year
|
|
spanEndYear (DateSpan d _) = fmap (first3 . toGregorian. fromEFDay) d
|
|
|
|
-- | Get the 0-2 years mentioned explicitly in a DateSpan.
|
|
spanYears :: DateSpan -> [Year]
|
|
spanYears (DateSpan ma mb) = mapMaybe (fmap (first3 . toGregorian. fromEFDay)) [ma,mb]
|
|
|
|
-- might be useful later: http://en.wikipedia.org/wiki/Allen%27s_interval_algebra
|
|
|
|
-- | Get overall span enclosing multiple sequentially ordered spans.
|
|
-- The start and end date will be exact or flexible depending on
|
|
-- the first span's start date and last span's end date.
|
|
spansSpan :: [DateSpan] -> DateSpan
|
|
spansSpan spans = DateSpan (spanStartDate =<< headMay spans) (spanEndDate =<< lastMay spans)
|
|
|
|
-- Like addGregorianMonthsClip, add one month to the given date, clipping when needed
|
|
-- to fit it within the next month's length. But also, keep a target day of month in mind,
|
|
-- and revert to that or as close to it as possible in subsequent longer months.
|
|
-- Eg, using it to step through 31sts gives 1/31, 2/28, 3/31, 4/30, 5/31..
|
|
addGregorianMonthsToMonthday :: MonthDay -> Integer -> Day -> Day
|
|
addGregorianMonthsToMonthday dom n d =
|
|
let (y,m,_) = toGregorian $ addGregorianMonthsClip n d
|
|
in fromGregorian y m dom
|
|
|
|
-- | Count the days in a DateSpan, or if it is open-ended return Nothing.
|
|
daysInSpan :: DateSpan -> Maybe Integer
|
|
daysInSpan (DateSpan (Just d1) (Just d2)) = Just $ diffDays (fromEFDay d2) (fromEFDay d1)
|
|
daysInSpan _ = Nothing
|
|
|
|
-- | Is this an empty span, ie closed with the end date on or before the start date ?
|
|
isEmptySpan :: DateSpan -> Bool
|
|
isEmptySpan (DateSpan (Just s) (Just e)) = e <= s
|
|
isEmptySpan _ = False
|
|
|
|
-- | Does the span include the given date ?
|
|
spanContainsDate :: DateSpan -> Day -> Bool
|
|
spanContainsDate (DateSpan Nothing Nothing) _ = True
|
|
spanContainsDate (DateSpan Nothing (Just e)) d = d < fromEFDay e
|
|
spanContainsDate (DateSpan (Just b) Nothing) d = d >= fromEFDay b
|
|
spanContainsDate (DateSpan (Just b) (Just e)) d = d >= fromEFDay b && d < fromEFDay e
|
|
|
|
-- | Does the period include the given date ?
|
|
-- (Here to avoid import cycle).
|
|
periodContainsDate :: Period -> Day -> Bool
|
|
periodContainsDate p = spanContainsDate (periodAsDateSpan p)
|
|
|
|
-- | Group elements based on where they fall in a list of 'DateSpan's without
|
|
-- gaps. The precondition is not checked.
|
|
groupByDateSpan :: Bool -> (a -> Day) -> [DateSpan] -> [a] -> [(DateSpan, [a])]
|
|
groupByDateSpan showempty date colspans =
|
|
groupByCols colspans
|
|
. dropWhile (beforeStart . fst)
|
|
. sortBy (comparing fst)
|
|
. map (\x -> (date x, x))
|
|
where
|
|
groupByCols [] _ = []
|
|
groupByCols (c:cs) [] = if showempty then (c, []) : groupByCols cs [] else []
|
|
groupByCols (c:cs) ps = (c, map snd colps) : groupByCols cs laterps
|
|
where (colps, laterps) = span ((spanEnd c >) . Just . fst) ps
|
|
|
|
beforeStart = maybe (const False) (>) $ spanStart =<< headMay colspans
|
|
|
|
-- | Calculate the intersection of a number of datespans.
|
|
spansIntersect [] = nulldatespan
|
|
spansIntersect [d] = d
|
|
spansIntersect (d:ds) = d `spanIntersect` (spansIntersect ds)
|
|
|
|
-- | Calculate the union of a number of datespans.
|
|
spansUnion [] = nulldatespan
|
|
spansUnion [d] = d
|
|
spansUnion (d:ds) = d `spanUnion` (spansUnion ds)
|
|
|
|
-- | Calculate the intersection of two datespans.
|
|
--
|
|
-- For non-intersecting spans, gives an empty span beginning on the second's start date:
|
|
-- >>> DateSpan (Just $ Flex $ fromGregorian 2018 01 01) (Just $ Flex $ fromGregorian 2018 01 03) `spanIntersect` DateSpan (Just $ Flex $ fromGregorian 2018 01 03) (Just $ Flex $ fromGregorian 2018 01 05)
|
|
-- DateSpan 2018-01-03..2018-01-02
|
|
spanIntersect (DateSpan b1 e1) (DateSpan b2 e2) = DateSpan (laterDefinite b1 b2) (earlierDefinite e1 e2)
|
|
|
|
-- | Fill any unspecified dates in the first span with the dates from
|
|
-- the second one (if specified there). Sort of a one-way spanIntersect.
|
|
-- This one can create an invalid span that'll always be empty.
|
|
--
|
|
-- >>> :{
|
|
-- DateSpan (Just $ Exact $ fromGregorian 2024 1 1) Nothing
|
|
-- `spanDefaultsFrom`
|
|
-- DateSpan (Just $ Exact $ fromGregorian 2024 1 1) (Just $ Exact $ fromGregorian 2024 1 2)
|
|
-- :}
|
|
-- DateSpan 2024-01-01
|
|
--
|
|
-- >>> :{
|
|
-- DateSpan (Just $ Exact $ fromGregorian 2025 1 1) Nothing
|
|
-- `spanDefaultsFrom`
|
|
-- DateSpan (Just $ Exact $ fromGregorian 2024 1 1) (Just $ Exact $ fromGregorian 2024 1 2)
|
|
-- :}
|
|
-- DateSpan 2025-01-01..2024-01-01
|
|
--
|
|
spanDefaultsFrom :: DateSpan -> DateSpan -> DateSpan
|
|
spanDefaultsFrom (DateSpan a1 b1) (DateSpan a2 b2) = DateSpan a b
|
|
where a = if isJust a1 then a1 else a2
|
|
b = if isJust b1 then b1 else b2
|
|
|
|
-- | A smarter version of spanDefaultsFrom that avoids creating invalid
|
|
-- spans ending before they begin. Kept separate for now to reduce risk.
|
|
--
|
|
-- >>> :{
|
|
-- DateSpan (Just $ Exact $ fromGregorian 2025 1 1) Nothing
|
|
-- `spanValidDefaultsFrom`
|
|
-- DateSpan (Just $ Exact $ fromGregorian 2024 1 1) (Just $ Exact $ fromGregorian 2024 1 2)
|
|
-- :}
|
|
-- DateSpan 2025-01-01..
|
|
--
|
|
spanValidDefaultsFrom :: DateSpan -> DateSpan -> DateSpan
|
|
spanValidDefaultsFrom s1 s2 =
|
|
case s1 `spanDefaultsFrom` s2 of
|
|
DateSpan b e | b >= e -> s1
|
|
s -> s
|
|
|
|
-- | Calculate the union of two datespans.
|
|
-- If either span is open-ended, the union will be too.
|
|
--
|
|
-- >>> ys2024 = fromGregorian 2024 01 01
|
|
-- >>> ys2025 = fromGregorian 2025 01 01
|
|
-- >>> to2024 = DateSpan Nothing (Just $ Exact ys2024)
|
|
-- >>> in2024 = DateSpan (Just $ Exact ys2024) (Just $ Exact ys2025)
|
|
-- >>> spanUnion to2024 in2024
|
|
-- DateSpan ..2024-12-31
|
|
-- >>> spanUnion in2024 to2024
|
|
-- DateSpan ..2024-12-31
|
|
spanUnion (DateSpan b1 e1) (DateSpan b2 e2) = DateSpan (earlier b1 b2) (later e1 e2)
|
|
|
|
-- | Extend the definite start/end dates of the first span, if needed,
|
|
-- to include the definite start/end dates of the second span.
|
|
-- And/or, replace open start/end dates in the first span with
|
|
-- definite start/end dates from the second.
|
|
-- Unlike spanUnion, open start/end dates in the second are ignored.
|
|
--
|
|
-- >>> ys2024 = fromGregorian 2024 01 01
|
|
-- >>> ys2025 = fromGregorian 2025 01 01
|
|
-- >>> to2024 = DateSpan Nothing (Just $ Exact ys2024)
|
|
-- >>> all2024 = DateSpan (Just $ Exact ys2024) (Just $ Exact ys2025)
|
|
-- >>> partof2024 = DateSpan (Just $ Exact $ fromGregorian 2024 03 01) (Just $ Exact $ fromGregorian 2024 09 01)
|
|
-- >>> spanExtend to2024 all2024
|
|
-- DateSpan 2024
|
|
-- >>> spanExtend all2024 to2024
|
|
-- DateSpan 2024
|
|
-- >>> spanExtend partof2024 all2024
|
|
-- DateSpan 2024
|
|
-- >>> spanExtend all2024 partof2024
|
|
-- DateSpan 2024
|
|
--
|
|
spanExtend (DateSpan b1 e1) (DateSpan b2 e2) = DateSpan (earlierDefinite b1 b2) (laterDefinite e1 e2)
|
|
|
|
-- | Pick the earlier of two DateSpan starts, treating Nothing as infinitely early.
|
|
-- An Exact and Flex with the same date are considered equal; the first argument wins.
|
|
earlier :: Maybe EFDay -> Maybe EFDay -> Maybe EFDay
|
|
earlier = min
|
|
|
|
-- | Pick the later of two DateSpan starts, treating Nothing as infinitely late.
|
|
-- An Exact and Flex with the same date are considered equal; the second argument wins.
|
|
later :: Maybe EFDay -> Maybe EFDay -> Maybe EFDay
|
|
later _ Nothing = Nothing
|
|
later Nothing _ = Nothing
|
|
later d1 d2 = max d1 d2
|
|
|
|
-- | Pick the earlier of two DateSpan ends that is a definite date (if any).
|
|
-- An Exact and Flex with the same date are considered equal; the first argument wins.
|
|
earlierDefinite :: Maybe EFDay -> Maybe EFDay -> Maybe EFDay
|
|
earlierDefinite d1 Nothing = d1
|
|
earlierDefinite Nothing d2 = d2
|
|
earlierDefinite d1 d2 = min d1 d2
|
|
|
|
-- | Pick the later of two DateSpan ends that is a definite date (if any).
|
|
-- An Exact and Flex with the same date are considered equal; the second argument wins.
|
|
laterDefinite :: Maybe EFDay -> Maybe EFDay -> Maybe EFDay
|
|
laterDefinite d1 Nothing = d1
|
|
laterDefinite Nothing d2 = d2
|
|
laterDefinite d1 d2 = max d1 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 ds = DateSpan (Exact <$> minimumMay ds) (Exact . addDays 1 <$> maximumMay 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 datespans = go
|
|
where
|
|
go day = do
|
|
spn <- Set.lookupLT supSpan spanSet
|
|
guard $ spanContainsDate spn day
|
|
return spn
|
|
where
|
|
-- The smallest DateSpan larger than any DateSpan containing day.
|
|
supSpan = DateSpan (Just $ Exact $ addDays 1 day) Nothing
|
|
|
|
spanSet = Set.fromList $ filter (not . isEmptySpan) datespans
|
|
|
|
-- | Parse a period expression to an Interval and overall DateSpan using
|
|
-- the provided reference date, or return a parse error.
|
|
parsePeriodExpr
|
|
:: Day -> Text -> Either HledgerParseErrors (Interval, DateSpan)
|
|
parsePeriodExpr refdate s = parsewith (periodexprp refdate <* eof) (T.toLower s)
|
|
|
|
-- | Like parsePeriodExpr, but call error' on failure.
|
|
parsePeriodExpr' :: Day -> Text -> (Interval, DateSpan)
|
|
parsePeriodExpr' refdate s =
|
|
either (error' . ("failed to parse:" ++) . customErrorBundlePretty) id $ -- PARTIAL:
|
|
parsePeriodExpr refdate s
|
|
|
|
-- | Show a DateSpan as a human-readable pseudo-period-expression string.
|
|
-- dateSpanAsText :: DateSpan -> String
|
|
-- dateSpanAsText (DateSpan Nothing Nothing) = "all"
|
|
-- dateSpanAsText (DateSpan Nothing (Just e)) = printf "to %s" (show e)
|
|
-- dateSpanAsText (DateSpan (Just b) Nothing) = printf "from %s" (show b)
|
|
-- dateSpanAsText (DateSpan (Just b) (Just e)) = printf "%s to %s" (show b) (show e)
|
|
|
|
-- | Convert a single smart date string to a date span using the provided
|
|
-- reference date, or raise an error.
|
|
-- spanFromSmartDateString :: Day -> String -> DateSpan
|
|
-- spanFromSmartDateString refdate s = spanFromSmartDate refdate sdate
|
|
-- where
|
|
-- sdate = fromparse $ parsewith smartdateonly s
|
|
|
|
spanFromSmartDate :: Day -> SmartDate -> DateSpan
|
|
spanFromSmartDate refdate sdate = DateSpan (Just b) (Just e)
|
|
where
|
|
(ry,rm,_) = toGregorian refdate
|
|
(b,e) = span' sdate
|
|
where
|
|
span' :: SmartDate -> (EFDay, EFDay)
|
|
span' (SmartCompleteDate day) = (Exact day, Exact $ nextday day)
|
|
span' (SmartAssumeStart y Nothing) = (Flex $ startofyear day, Flex $ nextyear day) where day = fromGregorian y 1 1
|
|
span' (SmartAssumeStart y (Just m)) = (Flex $ startofmonth day, Flex $ nextmonth day) where day = fromGregorian y m 1
|
|
span' (SmartFromReference m d) = (Exact day, Exact $ nextday day) where day = fromGregorian ry (fromMaybe rm m) d
|
|
span' (SmartMonth m) = (Flex $ startofmonth day, Flex $ nextmonth day) where day = fromGregorian ry m 1
|
|
span' (SmartRelative n Day) = (Exact $ addDays n refdate, Exact $ addDays (n+1) refdate)
|
|
span' (SmartRelative n Week) = (Flex $ addDays (7*n) d, Flex $ addDays (7*n+7) d) where d = thisweek refdate
|
|
span' (SmartRelative n Month) = (Flex $ addGregorianMonthsClip n d, Flex $ addGregorianMonthsClip (n+1) d) where d = thismonth refdate
|
|
span' (SmartRelative n Quarter) = (Flex $ addGregorianMonthsClip (3*n) d, Flex $ addGregorianMonthsClip (3*n+3) d) where d = thisquarter refdate
|
|
span' (SmartRelative n Year) = (Flex $ addGregorianYearsClip n d, Flex $ addGregorianYearsClip (n+1) d) where d = thisyear refdate
|
|
|
|
-- showDay :: Day -> String
|
|
-- showDay day = printf "%04d/%02d/%02d" y m d where (y,m,d) = toGregorian day
|
|
|
|
-- | Convert a smart date string to an explicit yyyy\/mm\/dd string using
|
|
-- the provided reference date, or raise an error.
|
|
fixSmartDateStr :: Day -> Text -> Text
|
|
fixSmartDateStr d s =
|
|
either (error' . printf "could not parse date %s %s" (show s) . show) id $ -- PARTIAL:
|
|
(fixSmartDateStrEither d s :: Either HledgerParseErrors Text)
|
|
|
|
-- | A safe version of fixSmartDateStr.
|
|
fixSmartDateStrEither :: Day -> Text -> Either HledgerParseErrors Text
|
|
fixSmartDateStrEither d = fmap showEFDate . fixSmartDateStrEither' d
|
|
|
|
fixSmartDateStrEither' :: Day -> Text -> Either HledgerParseErrors EFDay
|
|
fixSmartDateStrEither' d s = case parsewith smartdateonly (T.toLower s) of
|
|
Right sd -> Right $ fixSmartDate d sd
|
|
Left e -> Left e
|
|
|
|
-- | Convert a SmartDate to a specific date using the provided reference date.
|
|
-- This date will be exact or flexible depending on whether the day was
|
|
-- specified exactly. (Missing least-significant parts produces a flex date.)
|
|
--
|
|
-- ==== Examples:
|
|
-- >>> :set -XOverloadedStrings
|
|
-- >>> let t = fixSmartDateStr (fromGregorian 2008 11 26)
|
|
-- >>> t "0000-01-01"
|
|
-- "0000-01-01"
|
|
-- >>> t "1999-12-02"
|
|
-- "1999-12-02"
|
|
-- >>> t "1999.12.02"
|
|
-- "1999-12-02"
|
|
-- >>> t "1999/3/2"
|
|
-- "1999-03-02"
|
|
-- >>> t "19990302"
|
|
-- "1999-03-02"
|
|
-- >>> t "2008/2"
|
|
-- "2008-02-01"
|
|
-- >>> t "0020/2"
|
|
-- "0020-02-01"
|
|
-- >>> t "1000"
|
|
-- "1000-01-01"
|
|
-- >>> t "4/2"
|
|
-- "2008-04-02"
|
|
-- >>> t "2"
|
|
-- "2008-11-02"
|
|
-- >>> t "January"
|
|
-- "2008-01-01"
|
|
-- >>> t "feb"
|
|
-- "2008-02-01"
|
|
-- >>> t "today"
|
|
-- "2008-11-26"
|
|
-- >>> t "yesterday"
|
|
-- "2008-11-25"
|
|
-- >>> t "tomorrow"
|
|
-- "2008-11-27"
|
|
-- >>> t "this day"
|
|
-- "2008-11-26"
|
|
-- >>> t "last day"
|
|
-- "2008-11-25"
|
|
-- >>> t "next day"
|
|
-- "2008-11-27"
|
|
-- >>> t "this week" -- last monday
|
|
-- "2008-11-24"
|
|
-- >>> t "last week" -- previous monday
|
|
-- "2008-11-17"
|
|
-- >>> t "next week" -- next monday
|
|
-- "2008-12-01"
|
|
-- >>> t "this month"
|
|
-- "2008-11-01"
|
|
-- >>> t "last month"
|
|
-- "2008-10-01"
|
|
-- >>> t "next month"
|
|
-- "2008-12-01"
|
|
-- >>> t "this quarter"
|
|
-- "2008-10-01"
|
|
-- >>> t "last quarter"
|
|
-- "2008-07-01"
|
|
-- >>> t "next quarter"
|
|
-- "2009-01-01"
|
|
-- >>> t "this year"
|
|
-- "2008-01-01"
|
|
-- >>> t "last year"
|
|
-- "2007-01-01"
|
|
-- >>> t "next year"
|
|
-- "2009-01-01"
|
|
--
|
|
-- t "last wed"
|
|
-- "2008-11-19"
|
|
-- t "next friday"
|
|
-- "2008-11-28"
|
|
-- t "next january"
|
|
-- "2009-01-01"
|
|
--
|
|
-- >>> t "in 5 days"
|
|
-- "2008-12-01"
|
|
-- >>> t "in 7 months"
|
|
-- "2009-06-01"
|
|
-- >>> t "in -2 weeks"
|
|
-- "2008-11-10"
|
|
-- >>> t "1 quarter ago"
|
|
-- "2008-07-01"
|
|
-- >>> t "1 week ahead"
|
|
-- "2008-12-01"
|
|
fixSmartDate :: Day -> SmartDate -> EFDay
|
|
fixSmartDate refdate = fix
|
|
where
|
|
fix :: SmartDate -> EFDay
|
|
fix (SmartCompleteDate d) = Exact d
|
|
fix (SmartAssumeStart y m) = Flex $ fromGregorian y (fromMaybe 1 m) 1
|
|
fix (SmartFromReference m d) = Exact $ fromGregorian ry (fromMaybe rm m) d
|
|
fix (SmartMonth m) = Flex $ fromGregorian ry m 1
|
|
fix (SmartRelative n Day) = Exact $ addDays n refdate
|
|
fix (SmartRelative n Week) = Flex $ addDays (7*n) $ thisweek refdate
|
|
fix (SmartRelative n Month) = Flex $ addGregorianMonthsClip n $ thismonth refdate
|
|
fix (SmartRelative n Quarter) = Flex $ addGregorianMonthsClip (3*n) $ thisquarter refdate
|
|
fix (SmartRelative n Year) = Flex $ addGregorianYearsClip n $ thisyear refdate
|
|
(ry, rm, _) = toGregorian refdate
|
|
|
|
prevday :: Day -> Day
|
|
prevday = addDays (-1)
|
|
nextday = addDays 1
|
|
|
|
thisweek = startofweek
|
|
prevweek = startofweek . addDays (-7)
|
|
nextweek = startofweek . addDays 7
|
|
startofweek day = fromMondayStartWeek y w 1
|
|
where
|
|
(y,_,_) = toGregorian day
|
|
(w,_) = mondayStartWeek day
|
|
|
|
thismonth = startofmonth
|
|
prevmonth = startofmonth . addGregorianMonthsClip (-1)
|
|
nextmonth = startofmonth . addGregorianMonthsClip 1
|
|
startofmonth day = fromGregorian y m 1 where (y,m,_) = toGregorian day
|
|
nthdayofmonth d day = fromGregorian y m d where (y,m,_) = toGregorian day
|
|
|
|
thisquarter = startofquarter
|
|
startofquarter day = fromGregorian y (firstmonthofquarter m) 1
|
|
where
|
|
(y,m,_) = toGregorian day
|
|
firstmonthofquarter m2 = ((m2-1) `div` 3) * 3 + 1
|
|
|
|
thisyear = startofyear
|
|
-- prevyear = startofyear . addGregorianYearsClip (-1)
|
|
nextyear = startofyear . addGregorianYearsClip 1
|
|
startofyear day = fromGregorian y 1 1 where (y,_,_) = toGregorian day
|
|
|
|
-- | Find the next occurrence of the specified month and day of month, on or after the given date.
|
|
-- The month should be 1-12 and the day of month should be 1-31, or an error will be raised.
|
|
--
|
|
-- >>> let wed22nd = fromGregorian 2017 11 22
|
|
-- >>> nextmonthandday 11 21 wed22nd
|
|
-- 2018-11-21
|
|
-- >>> nextmonthandday 11 22 wed22nd
|
|
-- 2017-11-22
|
|
-- >>> nextmonthandday 11 23 wed22nd
|
|
-- 2017-11-23
|
|
nextmonthandday :: Month -> MonthDay -> Day -> Day
|
|
nextmonthandday m n date
|
|
-- PARTIAL:
|
|
| not (validMonth m) = error' $ "nextmonthandday: month should be 1..12, not "++show m
|
|
| not (validDay n) = error' $ "nextmonthandday: day should be 1..31, not " ++show n
|
|
| mdthisyear >= date = mdthisyear
|
|
| otherwise = mdnextyear
|
|
where
|
|
s = startofyear date
|
|
advancetomonth = applyN (m-1) nextmonth
|
|
advancetoday = addDays (toInteger n-1)
|
|
mdthisyear = advancetoday $ advancetomonth s
|
|
mdnextyear = advancetoday $ advancetomonth $ nextyear s
|
|
|
|
-- | Find the next occurrence of the specified day of month, on or after the given date.
|
|
-- The day of month should be 1-31, or an error will be raised.
|
|
--
|
|
-- >>> let wed22nd = fromGregorian 2017 11 22
|
|
-- >>> nextnthdayofmonth 21 wed22nd
|
|
-- 2017-12-21
|
|
-- >>> nextnthdayofmonth 22 wed22nd
|
|
-- 2017-11-22
|
|
-- >>> nextnthdayofmonth 23 wed22nd
|
|
-- 2017-11-23
|
|
nextnthdayofmonth :: MonthDay -> Day -> Day
|
|
nextnthdayofmonth n date
|
|
-- PARTIAL:
|
|
| not (validDay n) = error' $ "nextnthdayofmonth: day should be 1..31, not " ++show n
|
|
| nthofthismonth >= date = nthofthismonth
|
|
| otherwise = nthofnextmonth
|
|
where
|
|
s = startofmonth date
|
|
nthofthismonth = nthdayofmonth n s
|
|
nthofnextmonth = nthdayofmonth n $ nextmonth s
|
|
|
|
-- | For given date d find week-long interval that starts on nth day of week
|
|
-- and covers it.
|
|
--
|
|
-- Examples: 2017-11-22 is Wed. Week-long intervals that cover it and
|
|
-- start on Mon, Tue or Wed will start in the same week. However
|
|
-- intervals that start on Thu or Fri should start in prev week:
|
|
-- >>> let wed22nd = fromGregorian 2017 11 22
|
|
-- >>> nthdayofweekcontaining 1 wed22nd
|
|
-- 2017-11-20
|
|
-- >>> nthdayofweekcontaining 2 wed22nd
|
|
-- 2017-11-21
|
|
-- >>> nthdayofweekcontaining 3 wed22nd
|
|
-- 2017-11-22
|
|
-- >>> nthdayofweekcontaining 4 wed22nd
|
|
-- 2017-11-16
|
|
-- >>> nthdayofweekcontaining 5 wed22nd
|
|
-- 2017-11-17
|
|
nthdayofweekcontaining :: WeekDay -> Day -> Day
|
|
nthdayofweekcontaining n d | nthOfSameWeek <= d = nthOfSameWeek
|
|
| otherwise = nthOfPrevWeek
|
|
where nthOfSameWeek = addDays (toInteger n-1) s
|
|
nthOfPrevWeek = addDays (toInteger n-1) $ prevweek s
|
|
s = startofweek d
|
|
|
|
-- -- | Find the next occurrence of some weekday, on or after the given date d.
|
|
-- --
|
|
-- -- >>> let wed22nd = fromGregorian 2017 11 22
|
|
-- -- >>> nextnthdayofweek 1 wed22nd
|
|
-- -- 2017-11-20
|
|
-- -- >>> nextnthdayofweek 2 wed22nd
|
|
-- -- 2017-11-21
|
|
-- -- >>> nextnthdayofweek 3 wed22nd
|
|
-- -- 2017-11-22
|
|
-- -- >>> nextnthdayofweek 4 wed22nd
|
|
-- -- 2017-11-16
|
|
-- -- >>> nextnthdayofweek 5 wed22nd
|
|
-- -- 2017-11-17
|
|
-- nextdayofweek :: WeekDay -> Day -> Day
|
|
-- nextdayofweek n d | nthOfSameWeek <= d = nthOfSameWeek
|
|
-- | otherwise = nthOfPrevWeek
|
|
-- where nthOfSameWeek = addDays (toInteger n-1) s
|
|
-- nthOfPrevWeek = addDays (toInteger n-1) $ prevweek s
|
|
-- s = startofweek d
|
|
|
|
-- | Find the next occurrence of some nth weekday of a month, on or after the given date d.
|
|
--
|
|
-- >>> let wed22nd = fromGregorian 2017 11 22
|
|
-- >>> nextNthWeekdayOfMonth 3 3 wed22nd -- next third wednesday
|
|
-- 2017-12-20
|
|
-- >>> nextNthWeekdayOfMonth 4 3 wed22nd -- next fourth wednesday
|
|
-- 2017-11-22
|
|
-- >>> nextNthWeekdayOfMonth 5 3 wed22nd -- next fifth wednesday
|
|
-- 2017-11-29
|
|
nextNthWeekdayOfMonth :: Int -> WeekDay -> Day -> Day
|
|
nextNthWeekdayOfMonth n wd d
|
|
| nthweekdaythismonth >= d = nthweekdaythismonth
|
|
| otherwise = nthweekdaynextmonth
|
|
where
|
|
nthweekdaythismonth = advanceToNthWeekday n wd $ startofmonth d
|
|
nthweekdaynextmonth = advanceToNthWeekday n wd $ nextmonth d
|
|
|
|
-- | Find the previous occurrence of some nth weekday of a month, on or before the given date d.
|
|
--
|
|
-- >>> let wed22nd = fromGregorian 2017 11 22
|
|
-- >>> prevNthWeekdayOfMonth 4 3 wed22nd
|
|
-- 2017-11-22
|
|
-- >>> prevNthWeekdayOfMonth 5 2 wed22nd
|
|
-- 2017-10-31
|
|
prevNthWeekdayOfMonth :: Int -> WeekDay -> Day -> Day
|
|
prevNthWeekdayOfMonth n wd d
|
|
| nthweekdaythismonth <= d = nthweekdaythismonth
|
|
| otherwise = nthweekdayprevmonth
|
|
where
|
|
nthweekdaythismonth = advanceToNthWeekday n wd $ startofmonth d
|
|
nthweekdayprevmonth = advanceToNthWeekday n wd $ prevmonth d
|
|
|
|
-- | Advance to the nth occurrence of the given weekday, on or after the given date.
|
|
-- Can call error.
|
|
advanceToNthWeekday :: Int -> WeekDay -> Day -> Day
|
|
advanceToNthWeekday n wd s =
|
|
-- PARTIAL:
|
|
maybe err (addWeeks (n-1)) $ firstMatch (>=s) $ iterate (addWeeks 1) $ firstweekday s
|
|
where
|
|
err = error' "advanceToNthWeekday: should not happen"
|
|
addWeeks k = addDays (7 * toInteger k)
|
|
firstMatch p = headMay . dropWhile (not . p)
|
|
firstweekday = addDays (toInteger wd-1) . startofweek
|
|
|
|
----------------------------------------------------------------------
|
|
-- parsing
|
|
|
|
-- -- | Parse a couple of date-time string formats to a time type.
|
|
-- parsedatetime :: String -> Maybe LocalTime
|
|
-- parsedatetime s = asum [
|
|
-- parseTimeM TruedefaultTimeLocale "%Y/%m/%d %H:%M:%S" s,
|
|
-- parseTimeM TruedefaultTimeLocale "%Y-%m-%d %H:%M:%S" s
|
|
-- ]
|
|
|
|
-- | A simple date parsing helper: parses these YMD date string formats:
|
|
-- `YYYY-MM-DD`, `YYYY/MM/DD`, `YYYY.MM.DD` or `YYYYMMDD`,
|
|
-- where the month and day each have two digits and the year has one or more.
|
|
--
|
|
-- This is different from the Smart Dates of the CLI and period expressions ("smartdate", below)
|
|
-- and not quite the same as the Simple Dates of the journal ("datep", in Hledger.Read.Common).
|
|
-- It's mainly for internal or interactive use, eg when debugging -
|
|
-- but currently is also used in a few user-facing places, such as:
|
|
-- parsing --value's argument,
|
|
-- parsing .latest files,
|
|
-- and parsing hledger's --version output (which uses unseparated dates).
|
|
--
|
|
-- Unseparated dates were added in 2025 for convenience.
|
|
-- Note it means many integers will now parse successfully.
|
|
--
|
|
-- >>> parsedate "2008/02/03"
|
|
-- Just 2008-02-03
|
|
-- >>> parsedate "2008/02/03/"
|
|
-- Nothing
|
|
-- >>> parsedate "2008/02/30"
|
|
-- Nothing
|
|
-- >>> parsedate "2025-01-01"
|
|
-- Just 2025-01-01
|
|
-- >>> parsedate "2025.01.01"
|
|
-- Just 2025-01-01
|
|
-- >>> parsedate "20250101"
|
|
-- Just 2025-01-01
|
|
-- >>> parsedate "00101"
|
|
-- Just 0000-01-01
|
|
parsedate :: String -> Maybe Day
|
|
parsedate s = asum [
|
|
parseTimeM True defaultTimeLocale "%Y-%m-%d" s,
|
|
parseTimeM True defaultTimeLocale "%Y/%m/%d" s,
|
|
parseTimeM True defaultTimeLocale "%Y.%m.%d" s,
|
|
parseTimeM True defaultTimeLocale "%Y%m%d" s
|
|
]
|
|
|
|
{-|
|
|
Parse a date in any of the formats allowed in Ledger's period expressions, and some others.
|
|
Assumes any text in the parse stream has been lowercased.
|
|
Returns a SmartDate, to be converted to a full date later (see fixSmartDate).
|
|
|
|
Examples:
|
|
|
|
> 2004 (start of year, which must have 4+ digits)
|
|
> 2004/10 (start of month, which must be 1-12)
|
|
> 2004/10/1 (exact date, day must be 1-31)
|
|
> 10/1 (month and day in current year)
|
|
> 21 (day in current month)
|
|
> october, oct (start of month in current year)
|
|
> yesterday, today, tomorrow (-1, 0, 1 days from today)
|
|
> last/this/next day/week/month/quarter/year (-1, 0, 1 periods from the current period)
|
|
> in n days/weeks/months/quarters/years (n periods from the current period)
|
|
> n days/weeks/months/quarters/years ago (-n periods from the current period)
|
|
> 20181201 (8 digit YYYYMMDD with valid year month and day)
|
|
> 201812 (6 digit YYYYMM with valid year and month)
|
|
|
|
Note malformed digit sequences might give surprising results:
|
|
|
|
> 201813 (6 digits with an invalid month is parsed as start of 6-digit year)
|
|
> 20181301 (8 digits with an invalid month is parsed as start of 8-digit year)
|
|
> 20181232 (8 digits with an invalid day gives an error)
|
|
> 201801012 (9+ digits beginning with a valid YYYYMMDD gives an error)
|
|
|
|
Eg:
|
|
|
|
YYYYMMDD is parsed as year-month-date if those parts are valid
|
|
(>=4 digits, 1-12, and 1-31 respectively):
|
|
>>> parsewith (smartdate <* eof) "20181201"
|
|
Right (SmartCompleteDate 2018-12-01)
|
|
|
|
YYYYMM is parsed as year-month-01 if year and month are valid:
|
|
>>> parsewith (smartdate <* eof) "201804"
|
|
Right (SmartAssumeStart 2018 (Just 4))
|
|
|
|
With an invalid month, it's parsed as a year:
|
|
>>> parsewith (smartdate <* eof) "201813"
|
|
Right (SmartAssumeStart 201813 Nothing)
|
|
|
|
A 9+ digit number beginning with valid YYYYMMDD gives an error:
|
|
>>> parsewith (smartdate <* eof) "201801012"
|
|
Left (...)
|
|
|
|
Big numbers not beginning with a valid YYYYMMDD are parsed as a year:
|
|
>>> parsewith (smartdate <* eof) "201813012"
|
|
Right (SmartAssumeStart 201813012 Nothing)
|
|
|
|
-}
|
|
smartdate :: TextParser m SmartDate
|
|
smartdate = choice'
|
|
-- XXX maybe obscures date errors ? see ledgerdate
|
|
[ relativeP
|
|
, yyyymmdd
|
|
, ymd
|
|
, (\(m,d) -> SmartFromReference (Just m) d) <$> md
|
|
, failIfInvalidDate . SmartFromReference Nothing =<< decimal
|
|
, SmartMonth <$> (month <|> mon)
|
|
, SmartRelative 0 Day <$ string' "today"
|
|
, SmartRelative (-1) Day <$ string' "yesterday"
|
|
, SmartRelative 1 Day <$ string' "tomorrow"
|
|
]
|
|
where
|
|
relativeP = do
|
|
optional $ string' "in" <* skipNonNewlineSpaces
|
|
num <- seqP <* skipNonNewlineSpaces
|
|
interval <- intervalP <* skipNonNewlineSpaces
|
|
sign <- choice [negate <$ string' "ago", id <$ string' "ahead", pure id]
|
|
return $ SmartRelative (sign num) interval
|
|
|
|
seqP = choice [ 0 <$ string' "this", -1 <$ string' "last", 1 <$ string' "next", signed skipNonNewlineSpaces decimal ]
|
|
intervalP = choice [ Day <$ string' "day", Week <$ string' "week", Month <$ string' "month"
|
|
, Quarter <$ string' "quarter", Year <$ string' "year" ] <* optional (char' 's')
|
|
|
|
-- | Like smartdate, but there must be nothing other than whitespace after the date.
|
|
smartdateonly :: TextParser m SmartDate
|
|
smartdateonly = smartdate <* skipNonNewlineSpaces <* eof
|
|
|
|
datesepchars :: String
|
|
datesepchars = "/-."
|
|
|
|
datesepchar :: TextParser m Char
|
|
datesepchar = satisfy isDateSepChar
|
|
|
|
isDateSepChar :: Char -> Bool
|
|
isDateSepChar c = c == '-' || c == '/' || c == '.'
|
|
|
|
validMonth, validDay :: Int -> Bool
|
|
validMonth n = n >= 1 && n <= 12
|
|
validDay n = n >= 1 && n <= 31
|
|
|
|
failIfInvalidDate :: Fail.MonadFail m => SmartDate -> m SmartDate
|
|
failIfInvalidDate s = unless isValid (Fail.fail $ "bad smart date: " ++ show s) $> s
|
|
where isValid = case s of
|
|
SmartAssumeStart _ (Just m) -> validMonth m
|
|
SmartFromReference mm d -> isJust $ fromGregorianValid 2004 (fromMaybe 1 mm) d
|
|
SmartMonth m -> validMonth m
|
|
_ -> True
|
|
|
|
showBadDate :: Integer -> Int -> Int -> String
|
|
showBadDate y m d = "bad smart date: " ++ show y ++ "-" ++ show m ++ "-" ++ show d
|
|
|
|
yyyymmdd :: TextParser m SmartDate
|
|
yyyymmdd = do
|
|
y <- read <$> count 4 digitChar
|
|
m <- read <$> count 2 digitChar
|
|
mdy <- optional $ read <$> count 2 digitChar
|
|
case mdy of
|
|
Nothing -> failIfInvalidDate $ SmartAssumeStart y (Just m)
|
|
Just d -> maybe (Fail.fail $ showBadDate y m d) (return . SmartCompleteDate) $
|
|
fromGregorianValid y m d
|
|
|
|
ymd :: TextParser m SmartDate
|
|
ymd = do
|
|
y <- yearp
|
|
emd <- optional . try $ do
|
|
sep <- datesepchar
|
|
m <- decimal
|
|
unless (validMonth m) $ Fail.fail ("Bad month " <> show m)
|
|
option (Left m) . try $ Right <$> do
|
|
_ <- char sep
|
|
d <- decimal
|
|
maybe (Fail.fail $ showBadDate y m d) return $ fromGregorianValid y m d
|
|
return $ case emd of
|
|
Nothing -> SmartAssumeStart y Nothing
|
|
Just (Left m) -> SmartAssumeStart y (Just m)
|
|
Just (Right day) -> SmartCompleteDate day
|
|
|
|
md :: TextParser m (Month, MonthDay)
|
|
md = do
|
|
m <- decimal
|
|
datesepchar
|
|
d <- decimal
|
|
_ <- failIfInvalidDate $ SmartFromReference (Just m) d
|
|
return (m, d)
|
|
|
|
-- | Parse a year number from a Text, making sure that at least four digits are
|
|
-- used.
|
|
yearp :: TextParser m Integer
|
|
yearp = do
|
|
year <- takeWhile1P (Just "year") isDigit
|
|
unless (T.length year >= 4) . Fail.fail $ "Year must contain at least 4 digits: " <> T.unpack year
|
|
return $ readDecimal year
|
|
|
|
-- These are compared case insensitively, and should all be kept lower case.
|
|
months = ["january","february","march","april","may","june",
|
|
"july","august","september","october","november","december"]
|
|
monthabbrevs = ["jan","feb","mar","apr","may","jun","jul","aug","sep","oct","nov","dec"]
|
|
weekdays = ["monday","tuesday","wednesday","thursday","friday","saturday","sunday"]
|
|
weekdayabbrevs = ["mon","tue","wed","thu","fri","sat","sun"]
|
|
|
|
month, mon :: TextParser m Month
|
|
month = choice $ zipWith (\i m -> i <$ string' m) [1..12] months
|
|
mon = choice $ zipWith (\i m -> i <$ string' m) [1..12] monthabbrevs
|
|
|
|
weekday :: TextParser m Int
|
|
weekday = do
|
|
wday <- T.toLower <$> (choice . map string' $ weekdays ++ weekdayabbrevs)
|
|
case catMaybes $ [wday `elemIndex` weekdays, wday `elemIndex` weekdayabbrevs] of
|
|
(i:_) -> return (i+1)
|
|
[] -> Fail.fail $ "weekday: should not happen: attempted to find " <>
|
|
show wday <> " in " <> show (weekdays ++ weekdayabbrevs)
|
|
|
|
weekdaysp :: TextParser m [Int]
|
|
weekdaysp = fmap headErr . group . sort <$> sepBy1 weekday (string' ",") -- PARTIAL headErr will succeed because of sepBy1
|
|
|
|
-- | Parse a period expression, specifying a date span and optionally
|
|
-- a reporting interval. Requires a reference "today" date for
|
|
-- resolving any relative start/end dates (only; it is not needed for
|
|
-- parsing the reporting interval).
|
|
--
|
|
-- >>> let p = parsePeriodExpr (fromGregorian 2008 11 26)
|
|
-- >>> p "from Aug to Oct"
|
|
-- Right (NoInterval,DateSpan 2008-08-01..2008-09-30)
|
|
-- >>> p "aug to oct"
|
|
-- Right (NoInterval,DateSpan 2008-08-01..2008-09-30)
|
|
-- >>> p "2009q2"
|
|
-- Right (NoInterval,DateSpan 2009Q2)
|
|
-- >>> p "Q3"
|
|
-- Right (NoInterval,DateSpan 2008Q3)
|
|
-- >>> p "every 3 days in Aug"
|
|
-- Right (Days 3,DateSpan 2008-08)
|
|
-- >>> p "daily from aug"
|
|
-- Right (Days 1,DateSpan 2008-08-01..)
|
|
-- >>> p "every week to 2009"
|
|
-- Right (Weeks 1,DateSpan ..2008-12-31)
|
|
-- >>> p "every 2nd day of month"
|
|
-- Right (MonthDay 2,DateSpan ..)
|
|
-- >>> p "every 2nd day"
|
|
-- Right (MonthDay 2,DateSpan ..)
|
|
-- >>> p "every 2nd day 2009.."
|
|
-- Right (MonthDay 2,DateSpan 2009-01-01..)
|
|
-- >>> p "every 2nd day 2009-"
|
|
-- Right (MonthDay 2,DateSpan 2009-01-01..)
|
|
-- >>> p "every 29th Nov"
|
|
-- Right (MonthAndDay 11 29,DateSpan ..)
|
|
-- >>> p "every 29th nov ..2009"
|
|
-- Right (MonthAndDay 11 29,DateSpan ..2008-12-31)
|
|
-- >>> p "every nov 29th"
|
|
-- Right (MonthAndDay 11 29,DateSpan ..)
|
|
-- >>> p "every Nov 29th 2009.."
|
|
-- Right (MonthAndDay 11 29,DateSpan 2009-01-01..)
|
|
-- >>> p "every 11/29 from 2009"
|
|
-- Right (MonthAndDay 11 29,DateSpan 2009-01-01..)
|
|
-- >>> p "every 11/29 since 2009"
|
|
-- Right (MonthAndDay 11 29,DateSpan 2009-01-01..)
|
|
-- >>> p "every 2nd Thursday of month to 2009"
|
|
-- Right (NthWeekdayOfMonth 2 4,DateSpan ..2008-12-31)
|
|
-- >>> p "every 1st monday of month to 2009"
|
|
-- Right (NthWeekdayOfMonth 1 1,DateSpan ..2008-12-31)
|
|
-- >>> p "every tue"
|
|
-- Right (DaysOfWeek [2],DateSpan ..)
|
|
-- >>> p "every 2nd day of week"
|
|
-- Right (DaysOfWeek [2],DateSpan ..)
|
|
-- >>> p "every 2nd day of month"
|
|
-- Right (MonthDay 2,DateSpan ..)
|
|
-- >>> p "every 2nd day"
|
|
-- Right (MonthDay 2,DateSpan ..)
|
|
-- >>> p "every 2nd day 2009.."
|
|
-- Right (MonthDay 2,DateSpan 2009-01-01..)
|
|
-- >>> p "every 2nd day of month 2009.."
|
|
-- Right (MonthDay 2,DateSpan 2009-01-01..)
|
|
periodexprp :: Day -> TextParser m (Interval, DateSpan)
|
|
periodexprp rdate = do
|
|
skipNonNewlineSpaces
|
|
choice' [ intervalanddateperiodexprp rdate
|
|
, (,) NoInterval <$> periodexprdatespanp rdate
|
|
]
|
|
|
|
-- Parse a reporting interval and a date span.
|
|
intervalanddateperiodexprp :: Day -> TextParser m (Interval, DateSpan)
|
|
intervalanddateperiodexprp rdate = do
|
|
i <- reportingintervalp
|
|
s <- option def . try $ do
|
|
skipNonNewlineSpaces
|
|
periodexprdatespanp rdate
|
|
return (i,s)
|
|
|
|
-- Parse a reporting interval.
|
|
reportingintervalp :: TextParser m Interval
|
|
reportingintervalp = choice'
|
|
[ tryinterval "day" "daily" Days
|
|
, tryinterval "month" "monthly" Months
|
|
, tryinterval "quarter" "quarterly" Quarters
|
|
, tryinterval "year" "yearly" Years
|
|
, Weeks 2 <$ string' "biweekly"
|
|
, Weeks 2 <$ string' "fortnightly"
|
|
, Months 2 <$ string' "bimonthly"
|
|
, string' "every" *> skipNonNewlineSpaces *> choice'
|
|
[ DaysOfWeek . pure <$> (nth <* skipNonNewlineSpaces <* string' "day" <* of_ "week")
|
|
, MonthDay <$> (nth <* skipNonNewlineSpaces <* string' "day" <* optOf_ "month")
|
|
, liftA2 NthWeekdayOfMonth nth $ skipNonNewlineSpaces *> weekday <* optOf_ "month"
|
|
, uncurry MonthAndDay <$> (md <* optOf_ "year")
|
|
, DaysOfWeek <$> weekdaysp
|
|
, DaysOfWeek [1..5] <$ string' "weekday"
|
|
, DaysOfWeek [6..7] <$ string' "weekendday"
|
|
, d_o_y <* optOf_ "year"
|
|
]
|
|
-- NB: the ordering is important here since the parse for `every weekday`
|
|
-- would match the `tryinterval` first and then error on `d`. Perhaps it
|
|
-- would be clearer to factor some of this into the `every` choice or other
|
|
-- left-factorings.
|
|
, tryinterval "week" "weekly" Weeks
|
|
]
|
|
where
|
|
of_ period =
|
|
skipNonNewlineSpaces *> string' "of" *> skipNonNewlineSpaces *> string' period
|
|
|
|
optOf_ period = optional . try $ of_ period
|
|
|
|
nth = decimal <* choice (map string' ["st","nd","rd","th"])
|
|
d_o_y = runPermutation $ liftA2 MonthAndDay (toPermutation $ (month <|> mon) <* skipNonNewlineSpaces)
|
|
(toPermutation $ nth <* skipNonNewlineSpaces)
|
|
|
|
-- Parse any of several variants of a basic interval, eg "daily", "every day", "every N days".
|
|
tryinterval :: Text -> Text -> (Int -> Interval) -> TextParser m Interval
|
|
tryinterval singular compact intcons = intcons <$> choice'
|
|
[ 1 <$ string' compact
|
|
, string' "every" *> skipNonNewlineSpaces *> choice
|
|
[ 1 <$ string' singular
|
|
, decimal <* skipNonNewlineSpaces <* string' (singular <> "s")
|
|
]
|
|
]
|
|
|
|
periodexprdatespanp :: Day -> TextParser m DateSpan
|
|
periodexprdatespanp rdate = choice' [
|
|
doubledatespanp rdate,
|
|
fromdatespanp rdate,
|
|
todatespanp rdate,
|
|
indatespanp 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 rdate = liftA2 fromToSpan
|
|
(optional ((string' "from" <|> string' "since") *> skipNonNewlineSpaces) *> smartdateorquarterstartp rdate)
|
|
(skipNonNewlineSpaces *> choice [string' "to", string "..", string "-"]
|
|
*> skipNonNewlineSpaces *> smartdateorquarterstartp rdate)
|
|
where
|
|
fromToSpan = DateSpan `on` (Just . fixSmartDate rdate)
|
|
|
|
-- |
|
|
-- >>> let p = parsewith (fromdatespanp (fromGregorian 2024 02 02) <* eof)
|
|
-- >>> p "2025-01-01.."
|
|
-- Right DateSpan 2025-01-01..
|
|
-- >>> p "2025Q1.."
|
|
-- Right DateSpan 2025-01-01..
|
|
-- >>> p "from q2"
|
|
-- Right DateSpan 2024-04-01..
|
|
fromdatespanp :: Day -> TextParser m DateSpan
|
|
fromdatespanp rdate = fromSpan <$> choice
|
|
[ (string' "from" <|> string' "since") *> skipNonNewlineSpaces *> smartdateorquarterstartp rdate
|
|
, smartdateorquarterstartp rdate <* choice [string "..", string "-"]
|
|
]
|
|
where
|
|
fromSpan b = DateSpan (Just $ fixSmartDate rdate b) Nothing
|
|
|
|
-- |
|
|
-- >>> let p = parsewith (todatespanp (fromGregorian 2024 02 02) <* eof)
|
|
-- >>> p "..2025-01-01"
|
|
-- Right DateSpan ..2024-12-31
|
|
-- >>> p "..2025Q1"
|
|
-- Right DateSpan ..2024-12-31
|
|
-- >>> p "to q2"
|
|
-- Right DateSpan ..2024-03-31
|
|
todatespanp :: Day -> TextParser m DateSpan
|
|
todatespanp rdate =
|
|
choice [string' "to", string' "until", string "..", string "-"]
|
|
*> skipNonNewlineSpaces
|
|
*> (DateSpan Nothing . Just . fixSmartDate rdate <$> smartdateorquarterstartp rdate)
|
|
|
|
-- |j
|
|
-- >>> let p = parsewith (indatespanp (fromGregorian 2024 02 02) <* eof)
|
|
-- >>> p "2025-01-01"
|
|
-- Right DateSpan 2025-01-01
|
|
-- >>> p "2025q1"
|
|
-- Right DateSpan 2025Q1
|
|
-- >>> p "in Q2"
|
|
-- Right DateSpan 2024Q2
|
|
indatespanp :: Day -> TextParser m DateSpan
|
|
indatespanp rdate =
|
|
optional (string' "in" *> skipNonNewlineSpaces)
|
|
*> choice' [
|
|
quarterspanp rdate,
|
|
spanFromSmartDate rdate <$> smartdate
|
|
]
|
|
|
|
-- Helper: parse a quarter number, optionally preceded by a year.
|
|
quarterp :: Day -> TextParser m (Year, Int)
|
|
quarterp rdate = do
|
|
y <- yearp <|> pure (first3 $ toGregorian rdate)
|
|
n <- char' 'q' *> satisfy (`elem` ['1' .. '4']) >>= return . digitToInt
|
|
return (y, n)
|
|
|
|
-- | Parse a single quarter (YYYYqN or qN, case insensitive q) as a date span.
|
|
--
|
|
-- >>> parsewith (quarterspanp (fromGregorian 2018 01 01) <* eof) "q1"
|
|
-- Right DateSpan 2018Q1
|
|
-- >>> parsewith (quarterspanp (fromGregorian 2018 01 01) <* eof) "Q1"
|
|
-- Right DateSpan 2018Q1
|
|
-- >>> parsewith (quarterspanp (fromGregorian 2018 01 01) <* eof) "2020q4"
|
|
-- Right DateSpan 2020Q4
|
|
quarterspanp :: Day -> TextParser m DateSpan
|
|
quarterspanp rdate = do
|
|
(y,q) <- quarterp rdate
|
|
return . periodAsDateSpan $ QuarterPeriod y q
|
|
|
|
-- | Parse a quarter (YYYYqN or qN, case insensitive q) as its start date.
|
|
--
|
|
-- >>> parsewith (quarterstartp (fromGregorian 2025 02 02) <* eof) "q1"
|
|
-- Right 2025-01-01
|
|
-- >>> parsewith (quarterstartp (fromGregorian 2025 02 02) <* eof) "Q2"
|
|
-- Right 2025-04-01
|
|
-- >>> parsewith (quarterstartp (fromGregorian 2025 02 02) <* eof) "2025q4"
|
|
-- Right 2025-10-01
|
|
quarterstartp :: Day -> TextParser m Day
|
|
quarterstartp rdate = do
|
|
(y,q) <- quarterp rdate
|
|
return $
|
|
fromMaybe (error' "Hledger.Data.Dates.quarterstartp: invalid date found") $ -- PARTIAL, shouldn't happen
|
|
periodStart $ QuarterPeriod y q
|
|
|
|
smartdateorquarterstartp :: Day -> TextParser m SmartDate
|
|
smartdateorquarterstartp rdate = choice' [SmartCompleteDate <$> quarterstartp rdate, smartdate]
|
|
|
|
nulldatespan :: DateSpan
|
|
nulldatespan = DateSpan Nothing Nothing
|
|
|
|
-- | An exact datespan of zero length, that matches no date.
|
|
emptydatespan :: DateSpan
|
|
emptydatespan = DateSpan (Just $ Exact $ addDays 1 nulldate) (Just $ Exact nulldate)
|
|
|
|
nulldate :: Day
|
|
nulldate = fromGregorian 0 1 1
|