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

ref: smartdate: Improve ergonomics of SmartDate constructors.

Browse Source
This commit is contained in:
Stephen Morgan 2022-03-15 00:02:24 +11:00 committed by Simon Michael
parent 97e57c2cb5
commit bffb6c8c82
2 changed files with 37 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -390,16 +390,16 @@ 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 (SmartRelative n Day) = (addDays n refdate, addDays (n+1) refdate) span (SmartCompleteDate day) = (day, nextday day)
span (SmartRelative n Week) = let d = thisweek refdate in (addDays (7*n) d, addDays (7*n+7) d) span (SmartAssumeStart y Nothing) = (startofyear day, nextyear day) where day = fromGregorian y 1 1
span (SmartRelative n Month) = let d = thismonth refdate in (addGregorianMonthsClip n d, addGregorianMonthsClip (n+1) d) span (SmartAssumeStart y (Just m)) = (startofmonth day, nextmonth day) where day = fromGregorian y m 1
span (SmartRelative n Quarter) = let d = thisquarter refdate in (addGregorianMonthsClip (3*n) d, addGregorianMonthsClip (3*n+3) d) span (SmartFromReference m d) = (day, nextday day) where day = fromGregorian ry (fromMaybe rm m) d
span (SmartRelative n Year) = let d = thisyear refdate in (addGregorianYearsClip n d, addGregorianYearsClip (n+1) d) span (SmartMonth m) = (startofmonth day, nextmonth day) where day = fromGregorian ry m 1
span (SmartAssumeStart y Nothing) = (startofyear day, nextyear day) where day = fromGregorian y 1 1 span (SmartRelative n Day) = (addDays n refdate, addDays (n+1) refdate)
span (SmartAssumeStart y (Just (m, Nothing))) = (startofmonth day, nextmonth day) where day = fromGregorian y m 1 span (SmartRelative n Week) = (addDays (7*n) d, addDays (7*n+7) d) where d = thisweek refdate
span (SmartAssumeStart y (Just (m, Just d))) = (day, nextday day) where day = fromGregorian y m d span (SmartRelative n Month) = (addGregorianMonthsClip n d, addGregorianMonthsClip (n+1) d) where d = thismonth refdate
span (SmartFromReference m d) = (day, nextday day) where day = fromGregorian ry (fromMaybe rm m) d span (SmartRelative n Quarter) = (addGregorianMonthsClip (3*n) d, addGregorianMonthsClip (3*n+3) d) where d = thisquarter refdate
span (SmartMonth m) = (startofmonth day, nextmonth day) where day = fromGregorian ry m 1 span (SmartRelative n Year) = (addGregorianYearsClip n d, addGregorianYearsClip (n+1) d) where d = thisyear refdate
-- 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
@ -508,14 +508,15 @@ fixSmartDate :: Day -> SmartDate -> Day
fixSmartDate refdate = fix fixSmartDate refdate = fix
where where
fix :: SmartDate -> Day fix :: SmartDate -> Day
fix (SmartCompleteDate d) = d
fix (SmartAssumeStart y m) = fromGregorian y (fromMaybe 1 m) 1
fix (SmartFromReference m d) = fromGregorian ry (fromMaybe rm m) d
fix (SmartMonth m) = fromGregorian ry m 1
fix (SmartRelative n Day) = addDays n refdate fix (SmartRelative n Day) = addDays n refdate
fix (SmartRelative n Week) = addDays (7*n) $ thisweek refdate fix (SmartRelative n Week) = addDays (7*n) $ thisweek refdate
fix (SmartRelative n Month) = addGregorianMonthsClip n $ thismonth refdate fix (SmartRelative n Month) = addGregorianMonthsClip n $ thismonth refdate
fix (SmartRelative n Quarter) = addGregorianMonthsClip (3*n) $ thisquarter refdate fix (SmartRelative n Quarter) = addGregorianMonthsClip (3*n) $ thisquarter refdate
fix (SmartRelative n Year) = addGregorianYearsClip n $ thisyear refdate fix (SmartRelative n Year) = addGregorianYearsClip n $ thisyear refdate
fix (SmartAssumeStart y md) = fromGregorian y (maybe 1 fst md) (fromMaybe 1 $ snd =<< 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
@ -725,11 +726,11 @@ 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 (SmartAssumeStart 2018 (Just (12,Just 1))) Right (SmartCompleteDate 2018-12-01)
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 (SmartAssumeStart 2018 (Just (4,Nothing))) Right (SmartAssumeStart 2018 (Just 4))
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"
@ -788,31 +789,39 @@ validDay n = n >= 1 && n <= 31
failIfInvalidDate :: Fail.MonadFail m => SmartDate -> m SmartDate failIfInvalidDate :: Fail.MonadFail m => SmartDate -> m SmartDate
failIfInvalidDate s = unless isValid (Fail.fail $ "bad smart date: " ++ show s) $> s failIfInvalidDate s = unless isValid (Fail.fail $ "bad smart date: " ++ show s) $> s
where isValid = case s of where isValid = case s of
SmartAssumeStart y (Just (m, md)) -> isJust $ fromGregorianValid y m (fromMaybe 1 md) SmartAssumeStart _ (Just m) -> validMonth m
SmartFromReference mm d -> isJust $ fromGregorianValid 2004 (fromMaybe 1 mm) d SmartFromReference mm d -> isJust $ fromGregorianValid 2004 (fromMaybe 1 mm) d
SmartMonth m -> validMonth m SmartMonth m -> validMonth m
_ -> True _ -> True
showBadDate :: Integer -> Int -> Int -> String
showBadDate y m d = "bad smart date: " ++ show y ++ "-" ++ show m ++ "-" ++ show d
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 md <- optional $ read <$> count 2 digitChar
let date = SmartAssumeStart y $ Just (m, d) case md of
failIfInvalidDate date 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 :: TextParser m SmartDate
ymd = do ymd = do
y <- yearp y <- yearp
fmap (SmartAssumeStart y) . optional . try $ do emd <- optional . try $ do
sep <- datesepchar sep <- datesepchar
m <- decimal m <- decimal
unless (validMonth m) $ Fail.fail ("Bad month " <> show m) unless (validMonth m) $ Fail.fail ("Bad month " <> show m)
fmap (m,) . optional . try $ do option (Left m) . try $ Right <$> do
_ <- char sep _ <- char sep
d <- decimal d <- decimal
failIfInvalidDate $ SmartAssumeStart y (Just (m, Just d)) maybe (Fail.fail $ showBadDate y m d) return $ fromGregorianValid y m d
return 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 :: TextParser m (Month, MonthDay)
md = do md = do

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

@ -81,7 +81,8 @@ type WeekDay = Int -- 1-7
-- (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
= SmartAssumeStart Year (Maybe (Month, Maybe MonthDay)) = SmartCompleteDate Day
| SmartAssumeStart Year (Maybe Month)
| SmartFromReference (Maybe Month) MonthDay | SmartFromReference (Maybe Month) MonthDay
| SmartMonth Month | SmartMonth Month
| SmartRelative Integer SmartInterval | SmartRelative Integer SmartInterval