From 7b9f9ae49cb632ab93256d436a3c75fbc27a239d Mon Sep 17 00:00:00 2001 From: Stephen Morgan Date: Tue, 21 Jul 2020 13:48:55 +1000 Subject: [PATCH] lib: Refactor reportingintervalp to be more compact and do less backtracking. --- hledger-lib/Hledger/Data/Dates.hs | 382 +++++++----------- .../Hledger/Data/PeriodicTransaction.hs | 20 +- hledger-lib/Hledger/Data/Types.hs | 24 +- hledger-lib/Hledger/Read/JournalReader.hs | 9 +- 4 files changed, 171 insertions(+), 264 deletions(-) diff --git a/hledger-lib/Hledger/Data/Dates.hs b/hledger-lib/Hledger/Data/Dates.hs index 86dbd0f32..7465c1b6c 100644 --- a/hledger-lib/Hledger/Data/Dates.hs +++ b/hledger-lib/Hledger/Data/Dates.hs @@ -49,9 +49,6 @@ module Hledger.Data.Dates ( parsePeriodExpr', nulldatespan, emptydatespan, - failIfInvalidYear, - failIfInvalidMonth, - failIfInvalidDay, datesepchar, datesepchars, isDateSepChar, @@ -104,9 +101,10 @@ import Data.Time.Calendar import Data.Time.Calendar.OrdinalDate import Data.Time.Clock import Data.Time.LocalTime -import Safe (headMay, lastMay, readMay, maximumMay, minimumMay) +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 @@ -370,30 +368,26 @@ spanFromSmartDate refdate sdate = DateSpan (Just b) (Just e) (ry,rm,_) = toGregorian refdate (b,e) = span sdate span :: SmartDate -> (Day,Day) - span ("","","today") = (refdate, nextday refdate) - span ("","this","day") = (refdate, nextday refdate) - span ("","","yesterday") = (prevday refdate, refdate) - span ("","last","day") = (prevday refdate, refdate) - span ("","","tomorrow") = (nextday refdate, addDays 2 refdate) - span ("","next","day") = (nextday refdate, addDays 2 refdate) - span ("","last","week") = (prevweek refdate, thisweek refdate) - span ("","this","week") = (thisweek refdate, nextweek refdate) - span ("","next","week") = (nextweek refdate, startofweek $ addDays 14 refdate) - span ("","last","month") = (prevmonth refdate, thismonth refdate) - span ("","this","month") = (thismonth refdate, nextmonth refdate) - span ("","next","month") = (nextmonth refdate, startofmonth $ addGregorianMonthsClip 2 refdate) - span ("","last","quarter") = (prevquarter refdate, thisquarter refdate) - span ("","this","quarter") = (thisquarter refdate, nextquarter refdate) - span ("","next","quarter") = (nextquarter refdate, startofquarter $ addGregorianMonthsClip 6 refdate) - span ("","last","year") = (prevyear refdate, thisyear refdate) - span ("","this","year") = (thisyear refdate, nextyear refdate) - span ("","next","year") = (nextyear refdate, startofyear $ addGregorianYearsClip 2 refdate) - span ("","",d) = (day, nextday day) where day = fromGregorian ry rm (read d) - span ("",m,"") = (startofmonth day, nextmonth day) where day = fromGregorian ry (read m) 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) + span (SmartRel This Day) = (refdate, nextday refdate) + span (SmartRel Last Day) = (prevday refdate, refdate) + span (SmartRel Next Day) = (nextday refdate, addDays 2 refdate) + span (SmartRel This Week) = (thisweek refdate, nextweek refdate) + span (SmartRel Last Week) = (prevweek refdate, thisweek refdate) + span (SmartRel Next Week) = (nextweek refdate, startofweek $ addDays 14 refdate) + span (SmartRel This Month) = (thismonth refdate, nextmonth refdate) + span (SmartRel Last Month) = (prevmonth refdate, thismonth refdate) + span (SmartRel Next Month) = (nextmonth refdate, startofmonth $ addGregorianMonthsClip 2 refdate) + span (SmartRel This Quarter) = (thisquarter refdate, nextquarter refdate) + span (SmartRel Last Quarter) = (prevquarter refdate, thisquarter refdate) + span (SmartRel Next Quarter) = (nextquarter refdate, startofquarter $ addGregorianMonthsClip 6 refdate) + span (SmartRel This Year) = (thisyear refdate, nextyear refdate) + span (SmartRel Last Year) = (prevyear refdate, thisyear refdate) + span (SmartRel Next Year) = (nextyear refdate, startofyear $ addGregorianYearsClip 2 refdate) + span s@(SmartYMD Nothing Nothing Nothing) = error' $ "Ill-defined SmartDate " ++ show s + span s@(SmartYMD (Just _) Nothing (Just _)) = error' $ "Ill-defined SmartDate " ++ show s + span (SmartYMD y m (Just d)) = (day, nextday day) where day = fromGregorian (fromMaybe ry y) (fromMaybe rm m) d + span (SmartYMD y (Just m) Nothing) = (startofmonth day, nextmonth day) where day = fromGregorian (fromMaybe ry y) m 1 + span (SmartYMD (Just y) Nothing Nothing) = (startofyear day, nextyear day) where day = fromGregorian y 1 1 -- showDay :: Day -> String -- 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 where fix :: SmartDate -> Day - fix ("", "", "today") = fromGregorian ry rm rd - fix ("", "this", "day") = fromGregorian ry rm rd - fix ("", "", "yesterday") = prevday refdate - fix ("", "last", "day") = prevday refdate - fix ("", "", "tomorrow") = nextday refdate - fix ("", "next", "day") = nextday refdate - fix ("", "last", "week") = prevweek refdate - fix ("", "this", "week") = thisweek refdate - fix ("", "next", "week") = nextweek refdate - fix ("", "last", "month") = prevmonth refdate - fix ("", "this", "month") = thismonth refdate - fix ("", "next", "month") = nextmonth refdate - fix ("", "last", "quarter") = prevquarter refdate - fix ("", "this", "quarter") = thisquarter refdate - fix ("", "next", "quarter") = nextquarter refdate - fix ("", "last", "year") = prevyear refdate - fix ("", "this", "year") = thisyear refdate - fix ("", "next", "year") = nextyear 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 + fix (SmartRel This Day) = refdate + fix (SmartRel Last Day) = prevday refdate + fix (SmartRel Next Day) = nextday refdate + fix (SmartRel This Week) = thisweek refdate + fix (SmartRel Last Week) = prevweek refdate + fix (SmartRel Next Week) = nextweek refdate + fix (SmartRel This Month) = thismonth refdate + fix (SmartRel Last Month) = prevmonth refdate + fix (SmartRel Next Month) = nextmonth refdate + fix (SmartRel This Quarter) = thisquarter refdate + fix (SmartRel Last Quarter) = prevquarter refdate + fix (SmartRel Next Quarter) = nextquarter refdate + fix (SmartRel This Year) = thisyear refdate + fix (SmartRel Last Year) = prevyear refdate + fix (SmartRel Next Year) = nextyear refdate + fix (SmartYMD Nothing Nothing (Just d)) = fromGregorian ry rm d + fix (SmartYMD my mm md) = fromGregorian (fromMaybe ry my) (fromMaybe 1 mm) (fromMaybe 1 md) + (ry, rm, _) = toGregorian refdate prevday :: Day -> Day prevday = addDays (-1) @@ -573,8 +560,8 @@ startofyear day = fromGregorian y 1 1 where (y,_,_) = toGregorian day -- 2017-01-01 nthdayofyearcontaining :: Month -> MonthDay -> Day -> Day nthdayofyearcontaining m md date - | not (validMonth $ show m) = error' $ "nthdayofyearcontaining: invalid month "++show m - | not (validDay $ show md) = error' $ "nthdayofyearcontaining: invalid day " ++show md + | not (validMonth m) = error' $ "nthdayofyearcontaining: invalid month "++show m + | not (validDay md) = error' $ "nthdayofyearcontaining: invalid day " ++show md | mmddOfSameYear <= date = mmddOfSameYear | otherwise = mmddOfPrevYear where mmddOfSameYear = addDays (fromIntegral md-1) $ applyN (m-1) nextmonth s @@ -601,7 +588,7 @@ nthdayofyearcontaining m md date -- 2017-10-30 nthdayofmonthcontaining :: MonthDay -> Day -> Day 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 | otherwise = nthOfPrevMonth where nthOfSameMonth = nthdayofmonth md s @@ -754,15 +741,15 @@ 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 ("2018","12","01") +Right (SmartYMD (Just 2018) (Just 12) (Just 1)) YYYYMM is parsed as year-month-01 if year and month are valid: >>> 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: >>> parsewith (smartdate <* eof) "201813" -Right ("201813","","") +Right (SmartYMD (Just 201813) Nothing Nothing) A 9+ digit number beginning with valid YYYYMMDD gives an error: >>> parsewith (smartdate <* eof) "201801012" @@ -770,22 +757,31 @@ Left (...) Big numbers not beginning with a valid YYYYMMDD are parsed as a year: >>> parsewith (smartdate <* eof) "201813012" -Right ("201813012","","") +Right (SmartYMD (Just 201813012) Nothing Nothing) -} smartdate :: TextParser m SmartDate -smartdate = do +smartdate = choice' -- XXX maybe obscures date errors ? see ledgerdate - (y,m,d) <- choice' [yyyymmdd, yyyymm, ymd, ym, md, y, d, month, mon, today, yesterday, tomorrow, lastthisnextthing] - return (y,m,d) + [ yyyymmdd + , 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. smartdateonly :: TextParser m SmartDate -smartdateonly = do - d <- smartdate - skipNonNewlineSpaces - eof - return d +smartdateonly = smartdate <* skipNonNewlineSpaces <* eof datesepchars :: String datesepchars = "/-." @@ -796,73 +792,49 @@ datesepchar = satisfy isDateSepChar isDateSepChar :: Char -> Bool isDateSepChar c = c == '-' || c == '/' || c == '.' -validYear, validMonth, validDay :: String -> Bool -validYear s = length s >= 4 && isJust (readMay s :: Maybe Year) -validMonth s = maybe False (\n -> n>=1 && n<=12) $ readMay s -validDay s = maybe False (\n -> n>=1 && n<=31) $ readMay s +validMonth, validDay :: Int -> Bool +validMonth n = n >= 1 && n <= 12 +validDay n = n >= 1 && n <= 31 -failIfInvalidYear, failIfInvalidMonth, failIfInvalidDay :: (Fail.MonadFail m) => String -> m () -failIfInvalidYear s = unless (validYear s) $ Fail.fail $ "bad year number: " ++ s -failIfInvalidMonth s = unless (validMonth s) $ Fail.fail $ "bad month number: " ++ s -failIfInvalidDay s = unless (validDay s) $ Fail.fail $ "bad day number: " ++ s +failIfInvalidDate :: Fail.MonadFail m => SmartDate -> m () +failIfInvalidDate s@(SmartYMD y m d) = unless isValid $ Fail.fail $ "bad smart date: " ++ show s + where isValid = isJust $ fromGregorianValid (fromMaybe 2004 y) (fromMaybe 1 m) (fromMaybe 1 d) +failIfInvalidDate _ = return () yyyymmdd :: TextParser m SmartDate yyyymmdd = do - y <- count 4 digitChar - m <- count 2 digitChar - failIfInvalidMonth m - d <- count 2 digitChar - failIfInvalidDay d - return (y,m,d) - -yyyymm :: TextParser m SmartDate -yyyymm = do - y <- count 4 digitChar - m <- count 2 digitChar - failIfInvalidMonth m - return (y,m,"01") + y <- read <$> count 4 digitChar + m <- read <$> count 2 digitChar + d <- optional $ read <$> count 2 digitChar + let date = SmartYMD (Just y) (Just m) d + failIfInvalidDate date + return date ymd :: TextParser m SmartDate ymd = do - y <- some digitChar - failIfInvalidYear y + y <- decimal sep <- datesepchar - m <- some digitChar - failIfInvalidMonth m - char sep - d <- some digitChar - failIfInvalidDay d - 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) + m <- decimal + d <- optional $ char sep *> decimal + let date = SmartYMD (Just y) (Just m) d + failIfInvalidDate date + return date md :: TextParser m SmartDate md = do - m <- some digitChar - failIfInvalidMonth m + m <- decimal datesepchar - d <- some digitChar - failIfInvalidDay d - return ("",m,d) + d <- decimal + let date = SmartYMD Nothing (Just m) (Just 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. 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"] weekdayabbrevs = ["mon","tue","wed","thu","fri","sat","sun"] --- | Convert a case insensitive english month name to a month number. -monthIndex name = maybe 0 (+1) $ T.toLower name `elemIndex` months - --- | 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,"") +month, mon :: TextParser m SmartDate +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 weekday :: TextParser m Int weekday = do @@ -897,31 +855,6 @@ weekday = do [] -> Fail.fail $ "weekday: should not happen: attempted to find " <> 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 -- a reporting interval. Requires a reference "today" date for -- resolving any relative start/end dates (only; it is not needed for @@ -991,89 +924,48 @@ intervalanddateperiodexprp rdate = do -- Parse a reporting interval. reportingintervalp :: TextParser m Interval -reportingintervalp = choice' [ - tryinterval "day" "daily" Days, - tryinterval "week" "weekly" Weeks, - tryinterval "month" "monthly" Months, - tryinterval "quarter" "quarterly" Quarters, - tryinterval "year" "yearly" Years, - do string' "biweekly" - return $ Weeks 2, - do string' "fortnightly" - return $ Weeks 2, - do string' "bimonthly" - return $ Months 2, - do string' "every" - skipNonNewlineSpaces - n <- nth - skipNonNewlineSpaces - string' "day" - of_ "week" - return $ DayOfWeek n, - do string' "every" - skipNonNewlineSpaces - 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 +reportingintervalp = choice' + [ tryinterval "day" "daily" Days + , tryinterval "week" "weekly" Weeks + , 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' + [ DayOfWeek <$> (nth <* skipNonNewlineSpaces <* string' "day" <* of_ "week") + , DayOfMonth <$> (nth <* skipNonNewlineSpaces <* string' "day" <* optOf_ "month") + , liftA2 WeekdayOfMonth nth $ skipNonNewlineSpaces *> weekday <* optOf_ "month" + , (\(SmartYMD Nothing (Just m) (Just d)) -> DayOfYear m d) <$> (md <* optOf_ "year") + , DayOfWeek <$> weekday + , d_o_y <* optOf_ "year" + ] + ] + where + of_ period = + skipNonNewlineSpaces *> string' "of" *> skipNonNewlineSpaces *> string' period - optOf_ period = optional $ try $ of_ period + optOf_ period = optional . try $ of_ period - nth = do n <- some digitChar - choice' $ map string' ["st","nd","rd","th"] - return $ read n + nth = decimal <* choice (map string' ["st","nd","rd","th"]) + mnth = (\(SmartYMD Nothing (Just m) Nothing) -> m) <$> choice' [month, mon] + 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". - tryinterval :: String -> String -> (Int -> Interval) -> TextParser m Interval - tryinterval singular compact intcons = - choice' [ - do string' compact' - return $ intcons 1, - do string' "every" - skipNonNewlineSpaces - string' singular' - return $ intcons 1, - do string' "every" - skipNonNewlineSpaces - n <- read <$> some digitChar - skipNonNewlineSpaces - string' plural' - return $ intcons n - ] - where - compact' = T.pack compact - singular' = T.pack singular - plural' = T.pack $ singular ++ "s" + -- 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 singular compact intcons = intcons <$> choice' + [ 1 <$ string' compact' + , string' "every" *> skipNonNewlineSpaces *> choice + [ 1 <$ string' singular' + , decimal <* skipNonNewlineSpaces <* string' plural' + ] + ] + where + compact' = T.pack compact + singular' = T.pack singular + plural' = T.pack $ singular ++ "s" periodexprdatespanp :: Day -> TextParser m DateSpan periodexprdatespanp rdate = choice $ map try [ diff --git a/hledger-lib/Hledger/Data/PeriodicTransaction.hs b/hledger-lib/Hledger/Data/PeriodicTransaction.hs index f2dee2356..e4420b281 100644 --- a/hledger-lib/Hledger/Data/PeriodicTransaction.hs +++ b/hledger-lib/Hledger/Data/PeriodicTransaction.hs @@ -196,16 +196,16 @@ instance Show PeriodicTransaction where -- ... -- -- >>> _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" --- *** 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" --- *** 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" --- *** 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")) -- [] @@ -259,20 +259,20 @@ runPeriodicTransaction PeriodicTransaction{..} requestedspan = checkPeriodicTransactionStartDate :: Interval -> DateSpan -> T.Text -> Maybe String checkPeriodicTransactionStartDate i s periodexpr = case (i, spanStart s) of - (Weeks _, Just d) -> checkStart d "week" - (Months _, Just d) -> checkStart d "month" - (Quarters _, Just d) -> checkStart d "quarter" - (Years _, Just d) -> checkStart d "year" + (Weeks _, Just d) -> checkStart d Week + (Months _, Just d) -> checkStart d Month + (Quarters _, Just d) -> checkStart d Quarter + (Years _, Just d) -> checkStart d Year _ -> Nothing where checkStart d x = - let firstDate = fixSmartDate d ("","this",x) + let firstDate = fixSmartDate d $ SmartRel This x in if d == firstDate then Nothing else Just $ "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 ? --periodTransactionInterval :: PeriodicTransaction -> Maybe Interval diff --git a/hledger-lib/Hledger/Data/Types.hs b/hledger-lib/Hledger/Data/Types.hs index 5c2457059..4a2424025 100644 --- a/hledger-lib/Hledger/Data/Types.hs +++ b/hledger-lib/Hledger/Data/Types.hs @@ -44,10 +44,26 @@ import Text.Printf import Hledger.Utils.Regex --- | A possibly incomplete date, whose missing parts will be filled from a reference date. --- A numeric year, month, and day of month, or the empty string for any of these. --- See the smartdate parser. -type SmartDate = (String,String,String) +-- | A possibly incomplete year-month-day date provided by the user, to be +-- interpreted as either a date or a date span depending on context. Missing +-- parts "on the left" will be filled from the provided reference date, e.g. if +-- 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) diff --git a/hledger-lib/Hledger/Read/JournalReader.hs b/hledger-lib/Hledger/Read/JournalReader.hs index 5f7057803..475d0fc6b 100644 --- a/hledger-lib/Hledger/Read/JournalReader.hs +++ b/hledger-lib/Hledger/Read/JournalReader.hs @@ -98,6 +98,7 @@ import Data.Time.LocalTime import Safe import Text.Megaparsec hiding (parse) import Text.Megaparsec.Char +import Text.Megaparsec.Char.Lexer (decimal) import Text.Megaparsec.Custom import Text.Printf import System.FilePath @@ -552,10 +553,8 @@ defaultyeardirectivep :: JournalParser m () defaultyeardirectivep = do char 'Y' "default year" lift skipNonNewlineSpaces - y <- some digitChar - let y' = read y - failIfInvalidYear y - setYear y' + y <- decimal + setYear y defaultcommoditydirectivep :: JournalParser m () defaultcommoditydirectivep = do @@ -997,7 +996,7 @@ tests_JournalReader = tests "JournalReader" [ ,tests "defaultyeardirectivep" [ 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" ]