slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

lib: Refactor reportingintervalp to be more compact and do less backtracking.

Browse Source
This commit is contained in:
Stephen Morgan 2020-07-21 13:48:55 +10:00 committed by Simon Michael
parent 696d9c73b0
commit 7b9f9ae49c
4 changed files with 171 additions and 264 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

382
hledger-lib/Hledger/Data/Dates.hs
View File

@ -49,9 +49,6 @@ module Hledger.Data.Dates (
parsePeriodExpr', parsePeriodExpr',
nulldatespan, nulldatespan,
emptydatespan, emptydatespan,
failIfInvalidYear,
failIfInvalidMonth,
failIfInvalidDay,
datesepchar, datesepchar,
datesepchars, datesepchars,
isDateSepChar, isDateSepChar,
@ -104,9 +101,10 @@ import Data.Time.Calendar
import Data.Time.Calendar.OrdinalDate import Data.Time.Calendar.OrdinalDate
import Data.Time.Clock import Data.Time.Clock
import Data.Time.LocalTime import Data.Time.LocalTime
import Safe (headMay, lastMay, readMay, maximumMay, minimumMay) import Safe (headMay, lastMay, maximumMay, minimumMay)
import Text.Megaparsec import Text.Megaparsec
import Text.Megaparsec.Char import Text.Megaparsec.Char
import Text.Megaparsec.Char.Lexer (decimal)
import Text.Megaparsec.Custom import Text.Megaparsec.Custom
import Text.Printf import Text.Printf
@ -370,30 +368,26 @@ spanFromSmartDate refdate sdate = DateSpan (Just b) (Just e)
(ry,rm,_) = toGregorian refdate (ry,rm,_) = toGregorian refdate
(b,e) = span sdate (b,e) = span sdate
span :: SmartDate -> (Day,Day) span :: SmartDate -> (Day,Day)
span ("","","today") = (refdate, nextday refdate) span (SmartRel This Day) = (refdate, nextday refdate)
span ("","this","day") = (refdate, nextday refdate) span (SmartRel Last Day) = (prevday refdate, refdate)
span ("","","yesterday") = (prevday refdate, refdate) span (SmartRel Next Day) = (nextday refdate, addDays 2 refdate)
span ("","last","day") = (prevday refdate, refdate) span (SmartRel This Week) = (thisweek refdate, nextweek refdate)
span ("","","tomorrow") = (nextday refdate, addDays 2 refdate) span (SmartRel Last Week) = (prevweek refdate, thisweek refdate)
span ("","next","day") = (nextday refdate, addDays 2 refdate) span (SmartRel Next Week) = (nextweek refdate, startofweek $ addDays 14 refdate)
span ("","last","week") = (prevweek refdate, thisweek refdate) span (SmartRel This Month) = (thismonth refdate, nextmonth refdate)
span ("","this","week") = (thisweek refdate, nextweek refdate) span (SmartRel Last Month) = (prevmonth refdate, thismonth refdate)
span ("","next","week") = (nextweek refdate, startofweek $ addDays 14 refdate) span (SmartRel Next Month) = (nextmonth refdate, startofmonth $ addGregorianMonthsClip 2 refdate)
span ("","last","month") = (prevmonth refdate, thismonth refdate) span (SmartRel This Quarter) = (thisquarter refdate, nextquarter refdate)
span ("","this","month") = (thismonth refdate, nextmonth refdate) span (SmartRel Last Quarter) = (prevquarter refdate, thisquarter refdate)
span ("","next","month") = (nextmonth refdate, startofmonth $ addGregorianMonthsClip 2 refdate) span (SmartRel Next Quarter) = (nextquarter refdate, startofquarter $ addGregorianMonthsClip 6 refdate)
span ("","last","quarter") = (prevquarter refdate, thisquarter refdate) span (SmartRel This Year) = (thisyear refdate, nextyear refdate)
span ("","this","quarter") = (thisquarter refdate, nextquarter refdate) span (SmartRel Last Year) = (prevyear refdate, thisyear refdate)
span ("","next","quarter") = (nextquarter refdate, startofquarter $ addGregorianMonthsClip 6 refdate) span (SmartRel Next Year) = (nextyear refdate, startofyear $ addGregorianYearsClip 2 refdate)
span ("","last","year") = (prevyear refdate, thisyear refdate) span s@(SmartYMD Nothing Nothing Nothing) = error' $ "Ill-defined SmartDate " ++ show s
span ("","this","year") = (thisyear refdate, nextyear refdate) span s@(SmartYMD (Just _) Nothing (Just _)) = error' $ "Ill-defined SmartDate " ++ show s
span ("","next","year") = (nextyear refdate, startofyear $ addGregorianYearsClip 2 refdate) span (SmartYMD y m (Just d)) = (day, nextday day) where day = fromGregorian (fromMaybe ry y) (fromMaybe rm m) d
span ("","",d) = (day, nextday day) where day = fromGregorian ry rm (read d) span (SmartYMD y (Just m) Nothing) = (startofmonth day, nextmonth day) where day = fromGregorian (fromMaybe ry y) m 1
span ("",m,"") = (startofmonth day, nextmonth day) where day = fromGregorian ry (read m) 1 span (SmartYMD (Just y) Nothing Nothing) = (startofyear day, nextyear day) where day = fromGregorian y 1 1
span ("",m,d) = (day, nextday day) where day = fromGregorian ry (read m) (read d)
span (y,"","") = (startofyear day, nextyear day) where day = fromGregorian (read y) 1 1
span (y,m,"") = (startofmonth day, nextmonth day) where day = fromGregorian (read y) (read m) 1
span (y,m,d) = (day, nextday day) where day = fromGregorian (read y) (read m) (read d)
-- showDay :: Day -> String -- showDay :: Day -> String
-- showDay day = printf "%04d/%02d/%02d" y m d where (y,m,d) = toGregorian day -- showDay day = printf "%04d/%02d/%02d" y m d where (y,m,d) = toGregorian day
@ -492,31 +486,24 @@ fixSmartDate :: Day -> SmartDate -> Day
fixSmartDate refdate = fix fixSmartDate refdate = fix
where where
fix :: SmartDate -> Day fix :: SmartDate -> Day
fix ("", "", "today") = fromGregorian ry rm rd fix (SmartRel This Day) = refdate
fix ("", "this", "day") = fromGregorian ry rm rd fix (SmartRel Last Day) = prevday refdate
fix ("", "", "yesterday") = prevday refdate fix (SmartRel Next Day) = nextday refdate
fix ("", "last", "day") = prevday refdate fix (SmartRel This Week) = thisweek refdate
fix ("", "", "tomorrow") = nextday refdate fix (SmartRel Last Week) = prevweek refdate
fix ("", "next", "day") = nextday refdate fix (SmartRel Next Week) = nextweek refdate
fix ("", "last", "week") = prevweek refdate fix (SmartRel This Month) = thismonth refdate
fix ("", "this", "week") = thisweek refdate fix (SmartRel Last Month) = prevmonth refdate
fix ("", "next", "week") = nextweek refdate fix (SmartRel Next Month) = nextmonth refdate
fix ("", "last", "month") = prevmonth refdate fix (SmartRel This Quarter) = thisquarter refdate
fix ("", "this", "month") = thismonth refdate fix (SmartRel Last Quarter) = prevquarter refdate
fix ("", "next", "month") = nextmonth refdate fix (SmartRel Next Quarter) = nextquarter refdate
fix ("", "last", "quarter") = prevquarter refdate fix (SmartRel This Year) = thisyear refdate
fix ("", "this", "quarter") = thisquarter refdate fix (SmartRel Last Year) = prevyear refdate
fix ("", "next", "quarter") = nextquarter refdate fix (SmartRel Next Year) = nextyear refdate
fix ("", "last", "year") = prevyear refdate fix (SmartYMD Nothing Nothing (Just d)) = fromGregorian ry rm d
fix ("", "this", "year") = thisyear refdate fix (SmartYMD my mm md) = fromGregorian (fromMaybe ry my) (fromMaybe 1 mm) (fromMaybe 1 md)
fix ("", "next", "year") = nextyear refdate (ry, rm, _) = toGregorian refdate
fix ("", "", d) = fromGregorian ry rm (read d)
fix ("", m, "") = fromGregorian ry (read m) 1
fix ("", m, d) = fromGregorian ry (read m) (read d)
fix (y, "", "") = fromGregorian (read y) 1 1
fix (y, m, "") = fromGregorian (read y) (read m) 1
fix (y, m, d) = fromGregorian (read y) (read m) (read d)
(ry, rm, rd) = toGregorian refdate
prevday :: Day -> Day prevday :: Day -> Day
prevday = addDays (-1) prevday = addDays (-1)
@ -573,8 +560,8 @@ startofyear day = fromGregorian y 1 1 where (y,_,_) = toGregorian day
-- 2017-01-01 -- 2017-01-01
nthdayofyearcontaining :: Month -> MonthDay -> Day -> Day nthdayofyearcontaining :: Month -> MonthDay -> Day -> Day
nthdayofyearcontaining m md date nthdayofyearcontaining m md date
| not (validMonth $ show m) = error' $ "nthdayofyearcontaining: invalid month "++show m | not (validMonth m) = error' $ "nthdayofyearcontaining: invalid month "++show m
| not (validDay $ show md) = error' $ "nthdayofyearcontaining: invalid day " ++show md | not (validDay md) = error' $ "nthdayofyearcontaining: invalid day " ++show md
| mmddOfSameYear <= date = mmddOfSameYear | mmddOfSameYear <= date = mmddOfSameYear
| otherwise = mmddOfPrevYear | otherwise = mmddOfPrevYear
where mmddOfSameYear = addDays (fromIntegral md-1) $ applyN (m-1) nextmonth s where mmddOfSameYear = addDays (fromIntegral md-1) $ applyN (m-1) nextmonth s
@ -601,7 +588,7 @@ nthdayofyearcontaining m md date
-- 2017-10-30 -- 2017-10-30
nthdayofmonthcontaining :: MonthDay -> Day -> Day nthdayofmonthcontaining :: MonthDay -> Day -> Day
nthdayofmonthcontaining md date nthdayofmonthcontaining md date
| not (validDay $ show md) = error' $ "nthdayofmonthcontaining: invalid day " ++show md | not (validDay md) = error' $ "nthdayofmonthcontaining: invalid day " ++show md
| nthOfSameMonth <= date = nthOfSameMonth | nthOfSameMonth <= date = nthOfSameMonth
| otherwise = nthOfPrevMonth | otherwise = nthOfPrevMonth
where nthOfSameMonth = nthdayofmonth md s where nthOfSameMonth = nthdayofmonth md s
@ -754,15 +741,15 @@ Eg:
YYYYMMDD is parsed as year-month-date if those parts are valid YYYYMMDD is parsed as year-month-date if those parts are valid
(>=4 digits, 1-12, and 1-31 respectively): (>=4 digits, 1-12, and 1-31 respectively):
>>> parsewith (smartdate <* eof) "20181201" >>> parsewith (smartdate <* eof) "20181201"
Right ("2018","12","01") Right (SmartYMD (Just 2018) (Just 12) (Just 1))
YYYYMM is parsed as year-month-01 if year and month are valid: YYYYMM is parsed as year-month-01 if year and month are valid:
>>> parsewith (smartdate <* eof) "201804" >>> parsewith (smartdate <* eof) "201804"
Right ("2018","04","01") Right (SmartYMD (Just 2018) (Just 4) Nothing)
With an invalid month, it's parsed as a year: With an invalid month, it's parsed as a year:
>>> parsewith (smartdate <* eof) "201813" >>> parsewith (smartdate <* eof) "201813"
Right ("201813","","") Right (SmartYMD (Just 201813) Nothing Nothing)
A 9+ digit number beginning with valid YYYYMMDD gives an error: A 9+ digit number beginning with valid YYYYMMDD gives an error:
>>> parsewith (smartdate <* eof) "201801012" >>> parsewith (smartdate <* eof) "201801012"
@ -770,22 +757,31 @@ Left (...)
Big numbers not beginning with a valid YYYYMMDD are parsed as a year: Big numbers not beginning with a valid YYYYMMDD are parsed as a year:
>>> parsewith (smartdate <* eof) "201813012" >>> parsewith (smartdate <* eof) "201813012"
Right ("201813012","","") Right (SmartYMD (Just 201813012) Nothing Nothing)
-} -}
smartdate :: TextParser m SmartDate smartdate :: TextParser m SmartDate
smartdate = do smartdate = choice'
-- XXX maybe obscures date errors ? see ledgerdate -- XXX maybe obscures date errors ? see ledgerdate
(y,m,d) <- choice' [yyyymmdd, yyyymm, ymd, ym, md, y, d, month, mon, today, yesterday, tomorrow, lastthisnextthing] [ yyyymmdd
return (y,m,d) , md
, ymd
, yd
, month
, mon
, SmartRel This Day <$ string' "today"
, SmartRel Last Day <$ string' "yesterday"
, SmartRel Next Day <$ string' "tomorrow"
, liftA2 SmartRel (seqP <* skipNonNewlineSpaces) intervalP
]
where
seqP = choice [This <$ string' "this", Last <$ string' "last", Next <$ string' "next"]
intervalP = choice [Day <$ string' "day", Week <$ string' "week", Month <$ string' "month",
Quarter <$ string' "quarter", Year <$ string' "year"]
-- | Like smartdate, but there must be nothing other than whitespace after the date. -- | Like smartdate, but there must be nothing other than whitespace after the date.
smartdateonly :: TextParser m SmartDate smartdateonly :: TextParser m SmartDate
smartdateonly = do smartdateonly = smartdate <* skipNonNewlineSpaces <* eof
d <- smartdate
skipNonNewlineSpaces
eof
return d
datesepchars :: String datesepchars :: String
datesepchars = "/-." datesepchars = "/-."
@ -796,73 +792,49 @@ datesepchar = satisfy isDateSepChar
isDateSepChar :: Char -> Bool isDateSepChar :: Char -> Bool
isDateSepChar c = c == '-' || c == '/' || c == '.' isDateSepChar c = c == '-' || c == '/' || c == '.'
validYear, validMonth, validDay :: String -> Bool validMonth, validDay :: Int -> Bool
validYear s = length s >= 4 && isJust (readMay s :: Maybe Year) validMonth n = n >= 1 && n <= 12
validMonth s = maybe False (\n -> n>=1 && n<=12) $ readMay s validDay n = n >= 1 && n <= 31
validDay s = maybe False (\n -> n>=1 && n<=31) $ readMay s
failIfInvalidYear, failIfInvalidMonth, failIfInvalidDay :: (Fail.MonadFail m) => String -> m () failIfInvalidDate :: Fail.MonadFail m => SmartDate -> m ()
failIfInvalidYear s = unless (validYear s) $ Fail.fail $ "bad year number: " ++ s failIfInvalidDate s@(SmartYMD y m d) = unless isValid $ Fail.fail $ "bad smart date: " ++ show s
failIfInvalidMonth s = unless (validMonth s) $ Fail.fail $ "bad month number: " ++ s where isValid = isJust $ fromGregorianValid (fromMaybe 2004 y) (fromMaybe 1 m) (fromMaybe 1 d)
failIfInvalidDay s = unless (validDay s) $ Fail.fail $ "bad day number: " ++ s failIfInvalidDate _ = return ()
yyyymmdd :: TextParser m SmartDate yyyymmdd :: TextParser m SmartDate
yyyymmdd = do yyyymmdd = do
y <- count 4 digitChar y <- read <$> count 4 digitChar
m <- count 2 digitChar m <- read <$> count 2 digitChar
failIfInvalidMonth m d <- optional $ read <$> count 2 digitChar
d <- count 2 digitChar let date = SmartYMD (Just y) (Just m) d
failIfInvalidDay d failIfInvalidDate date
return (y,m,d) return date
yyyymm :: TextParser m SmartDate
yyyymm = do
y <- count 4 digitChar
m <- count 2 digitChar
failIfInvalidMonth m
return (y,m,"01")
ymd :: TextParser m SmartDate ymd :: TextParser m SmartDate
ymd = do ymd = do
y <- some digitChar y <- decimal
failIfInvalidYear y
sep <- datesepchar sep <- datesepchar
m <- some digitChar m <- decimal
failIfInvalidMonth m d <- optional $ char sep *> decimal
char sep let date = SmartYMD (Just y) (Just m) d
d <- some digitChar failIfInvalidDate date
failIfInvalidDay d return date
return $ (y,m,d)
ym :: TextParser m SmartDate
ym = do
y <- some digitChar
failIfInvalidYear y
datesepchar
m <- some digitChar
failIfInvalidMonth m
return (y,m,"")
y :: TextParser m SmartDate
y = do
y <- some digitChar
failIfInvalidYear y
return (y,"","")
d :: TextParser m SmartDate
d = do
d <- some digitChar
failIfInvalidDay d
return ("","",d)
md :: TextParser m SmartDate md :: TextParser m SmartDate
md = do md = do
m <- some digitChar m <- decimal
failIfInvalidMonth m
datesepchar datesepchar
d <- some digitChar d <- decimal
failIfInvalidDay d let date = SmartYMD Nothing (Just m) (Just d)
return ("",m,d) failIfInvalidDate date
return date
yd :: TextParser m SmartDate
yd = do
n <- decimal
if n >= 1 && n <= 31
then return $ SmartYMD Nothing Nothing (Just $ fromInteger n)
else return $ SmartYMD (Just n) Nothing Nothing
-- These are compared case insensitively, and should all be kept lower case. -- These are compared case insensitively, and should all be kept lower case.
months = ["january","february","march","april","may","june", months = ["january","february","march","april","may","june",
@ -871,23 +843,9 @@ monthabbrevs = ["jan","feb","mar","apr","may","jun","jul","aug","sep","oct","n
weekdays = ["monday","tuesday","wednesday","thursday","friday","saturday","sunday"] weekdays = ["monday","tuesday","wednesday","thursday","friday","saturday","sunday"]
weekdayabbrevs = ["mon","tue","wed","thu","fri","sat","sun"] weekdayabbrevs = ["mon","tue","wed","thu","fri","sat","sun"]
-- | Convert a case insensitive english month name to a month number. month, mon :: TextParser m SmartDate
monthIndex name = maybe 0 (+1) $ T.toLower name `elemIndex` months month = choice $ zipWith (\i m -> SmartYMD Nothing (Just i) Nothing <$ string' m) [1..12] months
mon = choice $ zipWith (\i m -> SmartYMD Nothing (Just i) Nothing <$ string' m) [1..12] monthabbrevs
-- | Convert a case insensitive english three-letter month abbreviation to a month number.
monIndex name = maybe 0 (+1) $ T.toLower name `elemIndex` monthabbrevs
month :: TextParser m SmartDate
month = do
m <- choice $ map string' months
let i = monthIndex m
return ("",show i,"")
mon :: TextParser m SmartDate
mon = do
m <- choice $ map string' monthabbrevs
let i = monIndex m
return ("",show i,"")
weekday :: TextParser m Int weekday :: TextParser m Int
weekday = do weekday = do
@ -897,31 +855,6 @@ weekday = do
[] -> Fail.fail $ "weekday: should not happen: attempted to find " <> [] -> Fail.fail $ "weekday: should not happen: attempted to find " <>
show wday <> " in " <> show (weekdays ++ weekdayabbrevs) show wday <> " in " <> show (weekdays ++ weekdayabbrevs)
today,yesterday,tomorrow :: TextParser m SmartDate
today = string' "today" *> return ("","","today")
yesterday = string' "yesterday" *> return ("","","yesterday")
tomorrow = string' "tomorrow" *> return ("","","tomorrow")
lastthisnextthing :: TextParser m SmartDate
lastthisnextthing = do
r <- choice $ map string' [
"last"
,"this"
,"next"
]
skipNonNewlineSpaces -- make the space optional for easier scripting
p <- choice $ map string' [
"day"
,"week"
,"month"
,"quarter"
,"year"
]
-- XXX support these in fixSmartDate
-- ++ (map string' $ months ++ monthabbrevs ++ weekdays ++ weekdayabbrevs)
return ("", T.unpack r, T.unpack p)
-- | Parse a period expression, specifying a date span and optionally -- | Parse a period expression, specifying a date span and optionally
-- a reporting interval. Requires a reference "today" date for -- a reporting interval. Requires a reference "today" date for
-- resolving any relative start/end dates (only; it is not needed for -- resolving any relative start/end dates (only; it is not needed for
@ -991,89 +924,48 @@ intervalanddateperiodexprp rdate = do
-- Parse a reporting interval. -- Parse a reporting interval.
reportingintervalp :: TextParser m Interval reportingintervalp :: TextParser m Interval
reportingintervalp = choice' [ reportingintervalp = choice'
tryinterval "day" "daily" Days, [ tryinterval "day" "daily" Days
tryinterval "week" "weekly" Weeks, , tryinterval "week" "weekly" Weeks
tryinterval "month" "monthly" Months, , tryinterval "month" "monthly" Months
tryinterval "quarter" "quarterly" Quarters, , tryinterval "quarter" "quarterly" Quarters
tryinterval "year" "yearly" Years, , tryinterval "year" "yearly" Years
do string' "biweekly" , Weeks 2 <$ string' "biweekly"
return $ Weeks 2, , Weeks 2 <$ string' "fortnightly"
do string' "fortnightly" , Months 2 <$ string' "bimonthly"
return $ Weeks 2, , string' "every" *> skipNonNewlineSpaces *> choice'
do string' "bimonthly" [ DayOfWeek <$> (nth <* skipNonNewlineSpaces <* string' "day" <* of_ "week")
return $ Months 2, , DayOfMonth <$> (nth <* skipNonNewlineSpaces <* string' "day" <* optOf_ "month")
do string' "every" , liftA2 WeekdayOfMonth nth $ skipNonNewlineSpaces *> weekday <* optOf_ "month"
skipNonNewlineSpaces , (\(SmartYMD Nothing (Just m) (Just d)) -> DayOfYear m d) <$> (md <* optOf_ "year")
n <- nth , DayOfWeek <$> weekday
skipNonNewlineSpaces , d_o_y <* optOf_ "year"
string' "day" ]
of_ "week" ]
return $ DayOfWeek n, where
do string' "every" of_ period =
skipNonNewlineSpaces skipNonNewlineSpaces *> string' "of" *> skipNonNewlineSpaces *> string' period
DayOfWeek <$> weekday,
do string' "every"
skipNonNewlineSpaces
n <- nth
skipNonNewlineSpaces
string' "day"
optOf_ "month"
return $ DayOfMonth n,
do string' "every"
let mnth = choice' [month, mon] >>= \(_,m,_) -> return (read m)
d_o_y <- runPermutation $
DayOfYear <$> toPermutation (try (skipNonNewlineSpaces *> mnth))
<*> toPermutation (try (skipNonNewlineSpaces *> nth))
optOf_ "year"
return d_o_y,
do string' "every"
skipNonNewlineSpaces
("",m,d) <- md
optOf_ "year"
return $ DayOfYear (read m) (read d),
do string' "every"
skipNonNewlineSpaces
n <- nth
skipNonNewlineSpaces
wd <- weekday
optOf_ "month"
return $ WeekdayOfMonth n wd
]
where
of_ period = do
skipNonNewlineSpaces
string' "of"
skipNonNewlineSpaces
string' period
optOf_ period = optional $ try $ of_ period optOf_ period = optional . try $ of_ period
nth = do n <- some digitChar nth = decimal <* choice (map string' ["st","nd","rd","th"])
choice' $ map string' ["st","nd","rd","th"] mnth = (\(SmartYMD Nothing (Just m) Nothing) -> m) <$> choice' [month, mon]
return $ read n d_o_y = runPermutation $ liftA2 DayOfYear (toPermutation $ mnth <* skipNonNewlineSpaces)
(toPermutation $ nth <* skipNonNewlineSpaces)
-- Parse any of several variants of a basic interval, eg "daily", "every day", "every N days". -- 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 singular compact intcons = tryinterval singular compact intcons = intcons <$> choice'
choice' [ [ 1 <$ string' compact'
do string' compact' , string' "every" *> skipNonNewlineSpaces *> choice
return $ intcons 1, [ 1 <$ string' singular'
do string' "every" , decimal <* skipNonNewlineSpaces <* string' plural'
skipNonNewlineSpaces ]
string' singular' ]
return $ intcons 1, where
do string' "every" compact' = T.pack compact
skipNonNewlineSpaces singular' = T.pack singular
n <- read <$> some digitChar plural' = T.pack $ singular ++ "s"
skipNonNewlineSpaces
string' plural'
return $ intcons n
]
where
compact' = T.pack compact
singular' = T.pack singular
plural' = T.pack $ singular ++ "s"
periodexprdatespanp :: Day -> TextParser m DateSpan periodexprdatespanp :: Day -> TextParser m DateSpan
periodexprdatespanp rdate = choice $ map try [ periodexprdatespanp rdate = choice $ map try [

20
hledger-lib/Hledger/Data/PeriodicTransaction.hs
View File

@ -196,16 +196,16 @@ instance Show PeriodicTransaction where
-- ... -- ...
-- --
-- >>> _ptgen "weekly from 2017" -- >>> _ptgen "weekly from 2017"
-- *** Exception: Unable to generate transactions according to "weekly from 2017" because 2017-01-01 is not a first day of the week -- *** Exception: Unable to generate transactions according to "weekly from 2017" because 2017-01-01 is not a first day of the Week
-- --
-- >>> _ptgen "monthly from 2017/5/4" -- >>> _ptgen "monthly from 2017/5/4"
-- *** Exception: Unable to generate transactions according to "monthly from 2017/5/4" because 2017-05-04 is not a first day of the month -- *** Exception: Unable to generate transactions according to "monthly from 2017/5/4" because 2017-05-04 is not a first day of the Month
-- --
-- >>> _ptgen "every quarter from 2017/1/2" -- >>> _ptgen "every quarter from 2017/1/2"
-- *** Exception: Unable to generate transactions according to "every quarter from 2017/1/2" because 2017-01-02 is not a first day of the quarter -- *** Exception: Unable to generate transactions according to "every quarter from 2017/1/2" because 2017-01-02 is not a first day of the Quarter
-- --
-- >>> _ptgen "yearly from 2017/1/14" -- >>> _ptgen "yearly from 2017/1/14"
-- *** Exception: Unable to generate transactions according to "yearly from 2017/1/14" because 2017-01-14 is not a first day of the year -- *** Exception: Unable to generate transactions according to "yearly from 2017/1/14" because 2017-01-14 is not a first day of the Year
-- --
-- >>> let reportperiod="daily from 2018/01/03" in let (i,s) = parsePeriodExpr' nulldate reportperiod in runPeriodicTransaction (nullperiodictransaction{ptperiodexpr=reportperiod, ptspan=s, ptinterval=i, ptpostings=["a" `post` usd 1]}) (DateSpan (Just $ parsedate "2018-01-01") (Just $ parsedate "2018-01-03")) -- >>> let reportperiod="daily from 2018/01/03" in let (i,s) = parsePeriodExpr' nulldate reportperiod in runPeriodicTransaction (nullperiodictransaction{ptperiodexpr=reportperiod, ptspan=s, ptinterval=i, ptpostings=["a" `post` usd 1]}) (DateSpan (Just $ parsedate "2018-01-01") (Just $ parsedate "2018-01-03"))
-- [] -- []
@ -259,20 +259,20 @@ runPeriodicTransaction PeriodicTransaction{..} requestedspan =
checkPeriodicTransactionStartDate :: Interval -> DateSpan -> T.Text -> Maybe String checkPeriodicTransactionStartDate :: Interval -> DateSpan -> T.Text -> Maybe String
checkPeriodicTransactionStartDate i s periodexpr = checkPeriodicTransactionStartDate i s periodexpr =
case (i, spanStart s) of case (i, spanStart s) of
(Weeks _, Just d) -> checkStart d "week" (Weeks _, Just d) -> checkStart d Week
(Months _, Just d) -> checkStart d "month" (Months _, Just d) -> checkStart d Month
(Quarters _, Just d) -> checkStart d "quarter" (Quarters _, Just d) -> checkStart d Quarter
(Years _, Just d) -> checkStart d "year" (Years _, Just d) -> checkStart d Year
_ -> Nothing _ -> Nothing
where where
checkStart d x = checkStart d x =
let firstDate = fixSmartDate d ("","this",x) let firstDate = fixSmartDate d $ SmartRel This x
in in
if d == firstDate if d == firstDate
then Nothing then Nothing
else Just $ else Just $
"Unable to generate transactions according to "++show (T.unpack periodexpr) "Unable to generate transactions according to "++show (T.unpack periodexpr)
++" because "++show d++" is not a first day of the "++x ++" because "++show d++" is not a first day of the "++show x
---- | What is the interval of this 'PeriodicTransaction's period expression, if it can be parsed ? ---- | What is the interval of this 'PeriodicTransaction's period expression, if it can be parsed ?
--periodTransactionInterval :: PeriodicTransaction -> Maybe Interval --periodTransactionInterval :: PeriodicTransaction -> Maybe Interval

24
hledger-lib/Hledger/Data/Types.hs
View File

@ -44,10 +44,26 @@ import Text.Printf
import Hledger.Utils.Regex import Hledger.Utils.Regex
-- | A possibly incomplete date, whose missing parts will be filled from a reference date. -- | A possibly incomplete year-month-day date provided by the user, to be
-- A numeric year, month, and day of month, or the empty string for any of these. -- interpreted as either a date or a date span depending on context. Missing
-- See the smartdate parser. -- parts "on the left" will be filled from the provided reference date, e.g. if
type SmartDate = (String,String,String) -- the year and month are missing, the reference date's year and month are used.
-- Missing parts "on the right" are assumed, when interpreting as a date, to be
-- 1, (e.g. if the year and month are present but the day is missing, it means
-- first day of that month); or when interpreting as a date span, to be a
-- wildcard (so it would mean all days of that month). See the `smartdate`
-- parser for more examples.
--
-- Or, one of the standard periods and an offset relative to the reference date:
-- (last|this|next) (day|week|month|quarter|year), where "this" means the period
-- containing the reference date.
data SmartDate
= SmartYMD (Maybe Year) (Maybe Month) (Maybe MonthDay)
| SmartRel SmartSequence SmartInterval
deriving (Show)
data SmartSequence = Last | This | Next deriving (Show)
data SmartInterval = Day | Week | Month | Quarter | Year deriving (Show)
data WhichDate = PrimaryDate | SecondaryDate deriving (Eq,Show) data WhichDate = PrimaryDate | SecondaryDate deriving (Eq,Show)

9
hledger-lib/Hledger/Read/JournalReader.hs
View File

@ -98,6 +98,7 @@ import Data.Time.LocalTime
import Safe import Safe
import Text.Megaparsec hiding (parse) import Text.Megaparsec hiding (parse)
import Text.Megaparsec.Char import Text.Megaparsec.Char
import Text.Megaparsec.Char.Lexer (decimal)
import Text.Megaparsec.Custom import Text.Megaparsec.Custom
import Text.Printf import Text.Printf
import System.FilePath import System.FilePath
@ -552,10 +553,8 @@ defaultyeardirectivep :: JournalParser m ()
defaultyeardirectivep = do defaultyeardirectivep = do
char 'Y' <?> "default year" char 'Y' <?> "default year"
lift skipNonNewlineSpaces lift skipNonNewlineSpaces
y <- some digitChar y <- decimal
let y' = read y setYear y
failIfInvalidYear y
setYear y'
defaultcommoditydirectivep :: JournalParser m () defaultcommoditydirectivep :: JournalParser m ()
defaultcommoditydirectivep = do defaultcommoditydirectivep = do
@ -997,7 +996,7 @@ tests_JournalReader = tests "JournalReader" [
,tests "defaultyeardirectivep" [ ,tests "defaultyeardirectivep" [
test "1000" $ assertParse defaultyeardirectivep "Y 1000" -- XXX no \n like the others test "1000" $ assertParse defaultyeardirectivep "Y 1000" -- XXX no \n like the others
,test "999" $ assertParseError defaultyeardirectivep "Y 999" "bad year number" -- ,test "999" $ assertParseError defaultyeardirectivep "Y 999" "bad year number"
,test "12345" $ assertParse defaultyeardirectivep "Y 12345" ,test "12345" $ assertParse defaultyeardirectivep "Y 12345"
] ]