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

lib: Make ill-formed SmartDates unrepresentable.

Browse Source
This commit is contained in:
Stephen Morgan 2020-08-07 12:18:19 +10:00 committed by Simon Michael
parent 27d6b21dff
commit f2dcbd2fee
3 changed files with 79 additions and 84 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -370,27 +370,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 (SmartRel This Day) = (refdate, nextday refdate) span (SmartRelative This Day) = (refdate, nextday refdate)
span (SmartRel Last Day) = (prevday refdate, refdate) span (SmartRelative Last Day) = (prevday refdate, refdate)
span (SmartRel Next Day) = (nextday refdate, addDays 2 refdate) span (SmartRelative Next Day) = (nextday refdate, addDays 2 refdate)
span (SmartRel This Week) = (thisweek refdate, nextweek refdate) span (SmartRelative This Week) = (thisweek refdate, nextweek refdate)
span (SmartRel Last Week) = (prevweek refdate, thisweek refdate) span (SmartRelative Last Week) = (prevweek refdate, thisweek refdate)
span (SmartRel Next Week) = (nextweek refdate, startofweek $ addDays 14 refdate) span (SmartRelative Next Week) = (nextweek refdate, startofweek $ addDays 14 refdate)
span (SmartRel This Month) = (thismonth refdate, nextmonth refdate) span (SmartRelative This Month) = (thismonth refdate, nextmonth refdate)
span (SmartRel Last Month) = (prevmonth refdate, thismonth refdate) span (SmartRelative Last Month) = (prevmonth refdate, thismonth refdate)
span (SmartRel Next Month) = (nextmonth refdate, startofmonth $ addGregorianMonthsClip 2 refdate) span (SmartRelative Next Month) = (nextmonth refdate, startofmonth $ addGregorianMonthsClip 2 refdate)
span (SmartRel This Quarter) = (thisquarter refdate, nextquarter refdate) span (SmartRelative This Quarter) = (thisquarter refdate, nextquarter refdate)
span (SmartRel Last Quarter) = (prevquarter refdate, thisquarter refdate) span (SmartRelative Last Quarter) = (prevquarter refdate, thisquarter refdate)
span (SmartRel Next Quarter) = (nextquarter refdate, startofquarter $ addGregorianMonthsClip 6 refdate) span (SmartRelative Next Quarter) = (nextquarter refdate, startofquarter $ addGregorianMonthsClip 6 refdate)
span (SmartRel This Year) = (thisyear refdate, nextyear refdate) span (SmartRelative This Year) = (thisyear refdate, nextyear refdate)
span (SmartRel Last Year) = (prevyear refdate, thisyear refdate) span (SmartRelative Last Year) = (prevyear refdate, thisyear refdate)
span (SmartRel Next Year) = (nextyear refdate, startofyear $ addGregorianYearsClip 2 refdate) span (SmartRelative Next Year) = (nextyear refdate, startofyear $ addGregorianYearsClip 2 refdate)
-- PARTIAL: span (SmartAssumeStart y Nothing) = (startofyear day, nextyear day) where day = fromGregorian y 1 1
span s@(SmartYMD Nothing Nothing Nothing) = error' $ "Ill-defined SmartDate " ++ show s span (SmartAssumeStart y (Just (m, Nothing))) = (startofmonth day, nextmonth day) where day = fromGregorian y m 1
span s@(SmartYMD (Just _) Nothing (Just _)) = error' $ "Ill-defined SmartDate " ++ show s span (SmartAssumeStart y (Just (m, Just d))) = (day, nextday day) where day = fromGregorian y m d
span (SmartYMD y m (Just d)) = (day, nextday day) where day = fromGregorian (fromMaybe ry y) (fromMaybe rm m) d span (SmartFromReference m d) = (day, nextday day) where day = fromGregorian ry (fromMaybe rm m) d
span (SmartYMD y (Just m) Nothing) = (startofmonth day, nextmonth day) where day = fromGregorian (fromMaybe ry y) m 1 span (SmartMonth m) = (startofmonth day, nextmonth day) where day = fromGregorian ry m 1
span (SmartYMD (Just y) Nothing Nothing) = (startofyear day, nextyear day) where day = fromGregorian y 1 1
-- 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
@ -489,23 +488,24 @@ fixSmartDate :: Day -> SmartDate -> Day
fixSmartDate refdate = fix fixSmartDate refdate = fix
where where
fix :: SmartDate -> Day fix :: SmartDate -> Day
fix (SmartRel This Day) = refdate fix (SmartRelative This Day) = refdate
fix (SmartRel Last Day) = prevday refdate fix (SmartRelative Last Day) = prevday refdate
fix (SmartRel Next Day) = nextday refdate fix (SmartRelative Next Day) = nextday refdate
fix (SmartRel This Week) = thisweek refdate fix (SmartRelative This Week) = thisweek refdate
fix (SmartRel Last Week) = prevweek refdate fix (SmartRelative Last Week) = prevweek refdate
fix (SmartRel Next Week) = nextweek refdate fix (SmartRelative Next Week) = nextweek refdate
fix (SmartRel This Month) = thismonth refdate fix (SmartRelative This Month) = thismonth refdate
fix (SmartRel Last Month) = prevmonth refdate fix (SmartRelative Last Month) = prevmonth refdate
fix (SmartRel Next Month) = nextmonth refdate fix (SmartRelative Next Month) = nextmonth refdate
fix (SmartRel This Quarter) = thisquarter refdate fix (SmartRelative This Quarter) = thisquarter refdate
fix (SmartRel Last Quarter) = prevquarter refdate fix (SmartRelative Last Quarter) = prevquarter refdate
fix (SmartRel Next Quarter) = nextquarter refdate fix (SmartRelative Next Quarter) = nextquarter refdate
fix (SmartRel This Year) = thisyear refdate fix (SmartRelative This Year) = thisyear refdate
fix (SmartRel Last Year) = prevyear refdate fix (SmartRelative Last Year) = prevyear refdate
fix (SmartRel Next Year) = nextyear refdate fix (SmartRelative Next Year) = nextyear refdate
fix (SmartYMD Nothing Nothing (Just d)) = fromGregorian ry rm d fix (SmartAssumeStart y md) = fromGregorian y (maybe 1 fst md) (fromMaybe 1 $ snd =<< md)
fix (SmartYMD my mm md) = fromGregorian (fromMaybe ry my) (fromMaybe 1 mm) (fromMaybe 1 md) fix (SmartFromReference m d) = fromGregorian ry (fromMaybe rm m) d
fix (SmartMonth m) = fromGregorian ry m 1
(ry, rm, _) = toGregorian refdate (ry, rm, _) = toGregorian refdate
prevday :: Day -> Day prevday :: Day -> Day
@ -748,15 +748,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 (SmartYMD (Just 2018) (Just 12) (Just 1)) Right (SmartAssumeStart 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 (SmartYMD (Just 2018) (Just 4) Nothing) Right (SmartAssumeStart 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 (SmartYMD (Just 201813) Nothing Nothing) Right (SmartAssumeStart 201813 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"
@ -764,27 +764,25 @@ 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 (SmartYMD (Just 201813012) Nothing Nothing) Right (SmartAssumeStart 201813012 Nothing)
-} -}
smartdate :: TextParser m SmartDate smartdate :: TextParser m SmartDate
smartdate = choice' smartdate = choice'
-- XXX maybe obscures date errors ? see ledgerdate -- XXX maybe obscures date errors ? see ledgerdate
[ yyyymmdd, md, ymd, smartYear, smartDay, month, mon [ yyyymmdd, ymd
, SmartRel This Day <$ string' "today" , (\(m,d) -> SmartFromReference (Just m) d) <$> md
, SmartRel Last Day <$ string' "yesterday" , (SmartFromReference Nothing <$> decimal) >>= failIfInvalidDate
, SmartRel Next Day <$ string' "tomorrow" , SmartMonth <$> (month <|> mon)
, liftA2 SmartRel (seqP <* skipNonNewlineSpaces) intervalP , SmartRelative This Day <$ string' "today"
, SmartRelative Last Day <$ string' "yesterday"
, SmartRelative Next Day <$ string' "tomorrow"
, liftA2 SmartRelative (seqP <* skipNonNewlineSpaces) intervalP
] ]
where where
seqP = choice [This <$ string' "this", Last <$ string' "last", Next <$ string' "next"] seqP = choice [This <$ string' "this", Last <$ string' "last", Next <$ string' "next"]
intervalP = choice [Day <$ string' "day", Week <$ string' "week", Month <$ string' "month", intervalP = choice [Day <$ string' "day", Week <$ string' "week", Month <$ string' "month",
Quarter <$ string' "quarter", Year <$ string' "year"] Quarter <$ string' "quarter", Year <$ string' "year"]
smartYear = (\y -> SmartYMD (Just y) Nothing Nothing) <$> yearp
smartDay = do
d <- SmartYMD Nothing Nothing . Just <$> decimal
failIfInvalidDate d
return d
-- | 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
@ -803,38 +801,35 @@ validMonth, validDay :: Int -> Bool
validMonth n = n >= 1 && n <= 12 validMonth n = n >= 1 && n <= 12
validDay n = n >= 1 && n <= 31 validDay n = n >= 1 && n <= 31
failIfInvalidDate :: Fail.MonadFail m => SmartDate -> m () failIfInvalidDate :: Fail.MonadFail m => SmartDate -> m SmartDate
failIfInvalidDate s@(SmartYMD y m d) = unless isValid $ Fail.fail $ "bad smart date: " ++ show s failIfInvalidDate s = unless isValid (Fail.fail $ "bad smart date: " ++ show s) *> return s
where isValid = isJust $ fromGregorianValid (fromMaybe 2004 y) (fromMaybe 1 m) (fromMaybe 1 d) where isValid = case s of
failIfInvalidDate _ = return () SmartAssumeStart y (Just (m, md)) -> isJust $ fromGregorianValid y m (fromMaybe 1 md)
SmartFromReference mm d -> isJust $ fromGregorianValid 2004 (fromMaybe 1 mm) d
SmartMonth m -> validMonth m
_ -> True
yyyymmdd :: TextParser m SmartDate yyyymmdd :: TextParser m SmartDate
yyyymmdd = do yyyymmdd = do
y <- read <$> count 4 digitChar y <- read <$> count 4 digitChar
m <- read <$> count 2 digitChar m <- read <$> count 2 digitChar
d <- optional $ read <$> count 2 digitChar d <- optional $ read <$> count 2 digitChar
let date = SmartYMD (Just y) (Just m) d let date = SmartAssumeStart y $ Just (m, d)
failIfInvalidDate date failIfInvalidDate date
return date
ymd :: TextParser m SmartDate ymd :: TextParser m SmartDate
ymd = do ymd = liftA2 SmartAssumeStart yearp (optional $ try monthday) >>= failIfInvalidDate
y <- yearp where monthday = do
sep <- datesepchar sep <- datesepchar
m <- decimal liftA2 (,) decimal . optional $ char sep *> decimal
d <- optional $ char sep *> decimal
let date = SmartYMD (Just y) (Just m) d
failIfInvalidDate date
return date
md :: TextParser m SmartDate md :: TextParser m (Month, MonthDay)
md = do md = do
m <- decimal m <- decimal
datesepchar datesepchar
d <- decimal d <- decimal
let date = SmartYMD Nothing (Just m) (Just d) _ <- failIfInvalidDate $ SmartFromReference (Just m) d
failIfInvalidDate date return (m, d)
return date
-- | Parse a year number from a Text, making sure that at least four digits are -- | Parse a year number from a Text, making sure that at least four digits are
-- used. -- used.
@ -851,9 +846,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"]
month, mon :: TextParser m SmartDate month, mon :: TextParser m Month
month = choice $ zipWith (\i m -> SmartYMD Nothing (Just i) Nothing <$ string' m) [1..12] months month = choice $ zipWith (\i m -> i <$ string' m) [1..12] months
mon = choice $ zipWith (\i m -> SmartYMD Nothing (Just i) Nothing <$ string' m) [1..12] monthabbrevs mon = choice $ zipWith (\i m -> i <$ string' m) [1..12] monthabbrevs
weekday :: TextParser m Int weekday :: TextParser m Int
weekday = do weekday = do
@ -920,10 +915,9 @@ weekday = do
periodexprp :: Day -> TextParser m (Interval, DateSpan) periodexprp :: Day -> TextParser m (Interval, DateSpan)
periodexprp rdate = do periodexprp rdate = do
skipNonNewlineSpaces skipNonNewlineSpaces
choice $ map try [ choice' [ intervalanddateperiodexprp rdate
intervalanddateperiodexprp rdate, , (,) NoInterval <$> periodexprdatespanp rdate
(,) NoInterval <$> periodexprdatespanp rdate ]
]
-- Parse a reporting interval and a date span. -- Parse a reporting interval and a date span.
intervalanddateperiodexprp :: Day -> TextParser m (Interval, DateSpan) intervalanddateperiodexprp :: Day -> TextParser m (Interval, DateSpan)
@ -949,7 +943,7 @@ reportingintervalp = choice'
[ DayOfWeek <$> (nth <* skipNonNewlineSpaces <* string' "day" <* of_ "week") [ DayOfWeek <$> (nth <* skipNonNewlineSpaces <* string' "day" <* of_ "week")
, DayOfMonth <$> (nth <* skipNonNewlineSpaces <* string' "day" <* optOf_ "month") , DayOfMonth <$> (nth <* skipNonNewlineSpaces <* string' "day" <* optOf_ "month")
, liftA2 WeekdayOfMonth nth $ skipNonNewlineSpaces *> weekday <* optOf_ "month" , liftA2 WeekdayOfMonth nth $ skipNonNewlineSpaces *> weekday <* optOf_ "month"
, (\(SmartYMD Nothing (Just m) (Just d)) -> DayOfYear m d) <$> (md <* optOf_ "year") , uncurry DayOfYear <$> (md <* optOf_ "year")
, DayOfWeek <$> weekday , DayOfWeek <$> weekday
, d_o_y <* optOf_ "year" , d_o_y <* optOf_ "year"
] ]
@ -961,9 +955,8 @@ reportingintervalp = choice'
optOf_ period = optional . try $ of_ period optOf_ period = optional . try $ of_ period
nth = decimal <* choice (map string' ["st","nd","rd","th"]) 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 $ (month <|> mon) <* skipNonNewlineSpaces)
d_o_y = runPermutation $ liftA2 DayOfYear (toPermutation $ mnth <* skipNonNewlineSpaces) (toPermutation $ nth <* 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

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

@ -266,7 +266,7 @@ checkPeriodicTransactionStartDate i s periodexpr =
_ -> Nothing _ -> Nothing
where where
checkStart d x = checkStart d x =
let firstDate = fixSmartDate d $ SmartRel This x let firstDate = fixSmartDate d $ SmartRelative This x
in in
if d == firstDate if d == firstDate
then Nothing then Nothing

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

@ -58,8 +58,10 @@ import Hledger.Utils.Regex
-- (last|this|next) (day|week|month|quarter|year), where "this" means the period -- (last|this|next) (day|week|month|quarter|year), where "this" means the period
-- containing the reference date. -- containing the reference date.
data SmartDate data SmartDate
= SmartYMD (Maybe Year) (Maybe Month) (Maybe MonthDay) = SmartAssumeStart Year (Maybe (Month, Maybe MonthDay))
| SmartRel SmartSequence SmartInterval | SmartFromReference (Maybe Month) MonthDay
| SmartMonth Month
| SmartRelative SmartSequence SmartInterval
deriving (Show) deriving (Show)
data SmartSequence = Last | This | Next deriving (Show) data SmartSequence = Last | This | Next deriving (Show)