From 038ebd8c7a03a7bbaa353776da110ce4dfd99e90 Mon Sep 17 00:00:00 2001 From: Simon Michael Date: Wed, 4 Sep 2024 14:59:14 +0100 Subject: [PATCH] fix: three more interval start date cases; add tests; cleanup [#2218] --- hledger-lib/Hledger/Data/Dates.hs | 197 ++++++++++-------- .../Hledger/Data/PeriodicTransaction.hs | 8 - hledger/hledger.m4.md | 4 +- hledger/test/cli/date-options.test | 2 +- hledger/test/register/intervals.test | 111 ++++++++++ 5 files changed, 226 insertions(+), 96 deletions(-) diff --git a/hledger-lib/Hledger/Data/Dates.hs b/hledger-lib/Hledger/Data/Dates.hs index b8dd93955..ab4e3e895 100644 --- a/hledger-lib/Hledger/Data/Dates.hs +++ b/hledger-lib/Hledger/Data/Dates.hs @@ -188,14 +188,20 @@ spansSpan :: [DateSpan] -> DateSpan spansSpan spans = DateSpan (spanStartDate =<< headMay spans) (spanEndDate =<< lastMay spans) -- | Split a DateSpan into consecutive exact spans of the specified Interval. --- If the first argument is true and the interval is Weeks, Months, Quarters or Years, --- the start date will be adjusted backward if needed to nearest natural interval boundary --- (a monday, first of month, first of quarter or first of year). -- If no interval is specified, the original span is returned. -- If the original span is the null date span, ie unbounded, the null date span is returned. -- If the original span is empty, eg if the end date is <= the start date, no spans are returned. -- --- ==== Examples: +-- ==== Date adjustment +-- Some intervals respect the "adjust" flag (years, quarters, months, weeks, every Nth weekday +-- of month seem to be the ones that need it). This will move the start date earlier, if needed, +-- to the previous natural interval boundary (first of year, first of quarter, first of month, +-- monday, previous Nth weekday of month). Related: #1982 #2218 +-- +-- The end date is always moved later if needed to the next natural interval boundary, +-- so that the last period is the same length as the others. +-- +-- ==== Examples -- >>> let t i y1 m1 d1 y2 m2 d2 = splitSpan True i $ DateSpan (Just $ Flex $ fromGregorian y1 m1 d1) (Just $ Flex $ fromGregorian y2 m2 d2) -- >>> t NoInterval 2008 01 01 2009 01 01 -- [DateSpan 2008] @@ -221,27 +227,25 @@ spansSpan spans = DateSpan (spanStartDate =<< headMay spans) (spanEndDate =<< la -- [DateSpan 2010-12-09..2011-01-12,DateSpan 2011-01-13..2011-02-09,DateSpan 2011-02-10..2011-03-09] -- >>> t (DaysOfWeek [2]) 2011 01 01 2011 01 15 -- [DateSpan 2010-12-28..2011-01-03,DateSpan 2011-01-04..2011-01-10,DateSpan 2011-01-11..2011-01-17] --- >>> t (DayOfYear 11 29) 2011 10 01 2011 10 15 --- [DateSpan 2010-11-29..2011-11-28] --- >>> t (DayOfYear 11 29) 2011 12 01 2012 12 15 --- [DateSpan 2011-11-29..2012-11-28,DateSpan 2012-11-29..2013-11-28] +-- >>> t (DayOfYear 11 29) 2012 10 01 2013 10 15 +-- [DateSpan 2012-11-29..2013-11-28] -- splitSpan :: Bool -> Interval -> DateSpan -> [DateSpan] -splitSpan _ _ (DateSpan Nothing Nothing) = [DateSpan Nothing Nothing] -splitSpan _ _ ds | isEmptySpan ds = [] -splitSpan _ _ ds@(DateSpan (Just s) (Just e)) | s == e = [ds] -splitSpan _ NoInterval ds = [ds] -splitSpan _ (Days n) ds = splitspan id addDays n ds -splitSpan adjust (Weeks n) ds = splitspan (if adjust then startofweek else id) addDays (7*n) ds -splitSpan adjust (Months n) ds = splitspan (if adjust then startofmonth else id) addGregorianMonthsClip n ds -splitSpan adjust (Quarters n) ds = splitspan (if adjust then startofquarter else id) addGregorianMonthsClip (3*n) ds -splitSpan adjust (Years n) ds = splitspan (if adjust then startofyear else id) addGregorianYearsClip n ds -splitSpan _ (DayOfMonth dom) ds = splitspan (nextnthdayofmonth dom) (addGregorianMonthsToMonthday dom) 1 ds -splitSpan _ (DayOfYear m n) ds = splitspan (nthdayofyearcontaining m n) (addGregorianYearsClip) 1 ds -splitSpan _ (WeekdayOfMonth n wd) ds = splitspan (nthweekdayofmonthcontaining n wd) advancemonths 1 ds +splitSpan _ _ (DateSpan Nothing Nothing) = [DateSpan Nothing Nothing] +splitSpan _ _ ds | isEmptySpan ds = [] +splitSpan _ _ ds@(DateSpan (Just s) (Just e)) | s == e = [ds] +splitSpan _ NoInterval ds = [ds] +splitSpan _ (Days n) ds = splitspan id addDays n ds +splitSpan adjust (Weeks n) ds = splitspan (if adjust then startofweek else id) addDays (7*n) ds +splitSpan adjust (Months n) ds = splitspan (if adjust then startofmonth else id) addGregorianMonthsClip n ds +splitSpan adjust (Quarters n) ds = splitspan (if adjust then startofquarter else id) addGregorianMonthsClip (3*n) ds +splitSpan adjust (Years n) ds = splitspan (if adjust then startofyear else id) addGregorianYearsClip n ds +splitSpan _ (DayOfMonth dom) ds = splitspan (nextnthdayofmonth dom) (addGregorianMonthsToMonthday dom) 1 ds +splitSpan _ (DayOfYear m n) ds = splitspan (nextmonthandday m n) (addGregorianYearsClip) 1 ds +splitSpan adjust (WeekdayOfMonth n wd) ds = splitspan (if adjust then prevNthWeekdayOfMonth n wd else nextNthWeekdayOfMonth n wd) advancemonths 1 ds where advancemonths 0 = id - advancemonths w = advancetonthweekday n wd . startofmonth . addGregorianMonthsClip w + advancemonths m = advanceToNthWeekday n wd . startofmonth . addGregorianMonthsClip m splitSpan _ (DaysOfWeek []) ds = [ds] splitSpan _ (DaysOfWeek days@(n:_)) ds = spansFromBoundaries e bdrys where @@ -260,16 +264,18 @@ addGregorianMonthsToMonthday dom n d = in fromGregorian y m dom -- Split the given span into exact spans using the provided helper functions: --- 1. The start function is applied to the span's start date to get the first sub-span's start date. --- 2. The addInterval function is used to calculate the subsequent spans' start dates, --- possibly with stride increased by the mult multiplier. --- It should handle spans of varying length, eg when splitting on "every 31st of month", --- it adjusts to 28/29/30 in short months but returns to 31 in the long months. +-- +-- 1. The start function is used to adjust the provided span's start date to get the first sub-span's start date. +-- +-- 2. The next function is used to calculate subsequent sub-spans' start dates, possibly with stride increased by a multiplier. +-- It should handle spans of varying length, eg when splitting on "every 31st of month", +-- it adjusts to 28/29/30 in short months but returns to 31 in the long months. +-- splitspan :: (Day -> Day) -> (Integer -> Day -> Day) -> Int -> DateSpan -> [DateSpan] -splitspan start addInterval mult ds = spansFromBoundaries e bdrys +splitspan start next mult ds = spansFromBoundaries e bdrys where - (s, e) = dateSpanSplitLimits start (addInterval (toInteger mult)) ds - bdrys = mapM (addInterval . toInteger) [0,mult..] $ start s + (s, e) = dateSpanSplitLimits start (next (toInteger mult)) ds + bdrys = mapM (next . toInteger) [0,mult..] $ start s -- | Fill in missing start/end dates for calculating 'splitSpan'. dateSpanSplitLimits :: (Day -> Day) -> (Day -> Day) -> DateSpan -> (Day, Day) @@ -620,7 +626,7 @@ startofquarter day = fromGregorian y (firstmonthofquarter m) 1 firstmonthofquarter m2 = ((m2-1) `div` 3) * 3 + 1 thisyear = startofyear -prevyear = startofyear . addGregorianYearsClip (-1) +-- prevyear = startofyear . addGregorianYearsClip (-1) nextyear = startofyear . addGregorianYearsClip 1 startofyear day = fromGregorian y 1 1 where (y,_,_) = toGregorian day @@ -632,40 +638,32 @@ intervalBoundaryBefore i d = (DateSpan (Just start) _:_) -> fromEFDay start _ -> d --- | For given date d find year-long interval that starts on given --- MM/DD of year and covers it. --- The given MM and DD should be basically valid (1-12 & 1-31), --- or an error is raised. +-- | 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. -- --- Examples: lets take 2017-11-22. Year-long intervals covering it that --- starts before Nov 22 will start in 2017. However --- intervals that start after Nov 23rd should start in 2016: -- >>> let wed22nd = fromGregorian 2017 11 22 --- >>> nthdayofyearcontaining 11 21 wed22nd --- 2017-11-21 --- >>> nthdayofyearcontaining 11 22 wed22nd +-- >>> nextmonthandday 11 21 wed22nd +-- 2018-11-21 +-- >>> nextmonthandday 11 22 wed22nd -- 2017-11-22 --- >>> nthdayofyearcontaining 11 23 wed22nd --- 2016-11-23 --- >>> nthdayofyearcontaining 12 02 wed22nd --- 2016-12-02 --- >>> nthdayofyearcontaining 12 31 wed22nd --- 2016-12-31 --- >>> nthdayofyearcontaining 1 1 wed22nd --- 2017-01-01 -nthdayofyearcontaining :: Month -> MonthDay -> Day -> Day -nthdayofyearcontaining m mdy date +-- >>> nextmonthandday 11 23 wed22nd +-- 2017-11-23 +nextmonthandday :: Month -> MonthDay -> Day -> Day +nextmonthandday m n date -- PARTIAL: - | not (validMonth m) = error' $ "nthdayofyearcontaining: invalid month "++show m - | not (validDay mdy) = error' $ "nthdayofyearcontaining: invalid day " ++show mdy - | mmddOfSameYear <= date = mmddOfSameYear - | otherwise = mmddOfPrevYear - where mmddOfSameYear = addDays (toInteger mdy-1) $ applyN (m-1) nextmonth s - mmddOfPrevYear = addDays (toInteger mdy-1) $ applyN (m-1) nextmonth $ prevyear s - s = startofyear date + | 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 occurence of the specified "nth day of month" that occurs on or after the given date. --- The nth day of month should be in the range 1-31, or an error will be raised. +-- | 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 @@ -709,37 +707,66 @@ nthdayofweekcontaining n d | nthOfSameWeek <= d = nthOfSameWeek nthOfPrevWeek = addDays (toInteger n-1) $ prevweek s s = startofweek d --- | For given date d find month-long interval that starts on nth weekday of month --- and covers it. --- --- Examples: 2017-11-22 is 3rd Wed of Nov. Month-long intervals that cover it and --- start on 1st-4th Wed will start in Nov. However --- intervals that start on 4th Thu or Fri or later should start in Oct: --- >>> let wed22nd = fromGregorian 2017 11 22 --- >>> nthweekdayofmonthcontaining 1 3 wed22nd --- 2017-11-01 --- >>> nthweekdayofmonthcontaining 3 2 wed22nd --- 2017-11-21 --- >>> nthweekdayofmonthcontaining 4 3 wed22nd --- 2017-11-22 --- >>> nthweekdayofmonthcontaining 4 4 wed22nd --- 2017-10-26 --- >>> nthweekdayofmonthcontaining 4 5 wed22nd --- 2017-10-27 -nthweekdayofmonthcontaining :: Int -> WeekDay -> Day -> Day -nthweekdayofmonthcontaining n wd d | nthWeekdaySameMonth <= d = nthWeekdaySameMonth - | otherwise = nthWeekdayPrevMonth - where nthWeekdaySameMonth = advancetonthweekday n wd $ startofmonth d - nthWeekdayPrevMonth = advancetonthweekday n wd $ prevmonth 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 --- | Advance to nth weekday wd after given start day s +-- | 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 = +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" + err = error' "advanceToNthWeekday: should not happen" addWeeks k = addDays (7 * toInteger k) firstMatch p = headMay . dropWhile (not . p) firstweekday = addDays (toInteger wd-1) . startofweek diff --git a/hledger-lib/Hledger/Data/PeriodicTransaction.hs b/hledger-lib/Hledger/Data/PeriodicTransaction.hs index 25143145e..3a636f45e 100644 --- a/hledger-lib/Hledger/Data/PeriodicTransaction.hs +++ b/hledger-lib/Hledger/Data/PeriodicTransaction.hs @@ -142,10 +142,6 @@ instance Show PeriodicTransaction where -- -- -- >>> _ptgen "every 2nd Thursday of month from 2017/1 to 2017/4" --- 2016-12-08 --- ; generated-transaction: ~ every 2nd Thursday of month from 2017/1 to 2017/4 --- a $1.00 --- -- 2017-01-12 -- ; generated-transaction: ~ every 2nd Thursday of month from 2017/1 to 2017/4 -- a $1.00 @@ -160,10 +156,6 @@ instance Show PeriodicTransaction where -- -- -- >>> _ptgen "every nov 29th from 2017 to 2019" --- 2016-11-29 --- ; generated-transaction: ~ every nov 29th from 2017 to 2019 --- a $1.00 --- -- 2017-11-29 -- ; generated-transaction: ~ every nov 29th from 2017 to 2019 -- a $1.00 diff --git a/hledger/hledger.m4.md b/hledger/hledger.m4.md index 239c99682..1291c19d3 100644 --- a/hledger/hledger.m4.md +++ b/hledger/hledger.m4.md @@ -4822,7 +4822,7 @@ Monthly on a custom day: - `every Nth day [of month]` (`31st day` will be adjusted to each month's last day) - `every Nth WEEKDAYNAME [of month]` -Yearly on a custom day: +Yearly on a custom month and day: - `every MM/DD [of year]` (month number and day of month number) - `every MONTHNAME DDth [of year]` (full or three-letter english month name, case insensitive, and day of month number) @@ -5210,7 +5210,7 @@ $ hledger print --forecast --today=2023/4/21 expenses:rent $1000 ``` -Here there are no ordinary transactions, so the forecasted transactions begin on the first occurence after today's date. +Here there are no ordinary transactions, so the forecasted transactions begin on the first occurrence after today's date. (You won't normally use `--today`; it's just to make these examples reproducible.) ## Forecast reports diff --git a/hledger/test/cli/date-options.test b/hledger/test/cli/date-options.test index df0e181dc..f3bcfa605 100644 --- a/hledger/test/cli/date-options.test +++ b/hledger/test/cli/date-options.test @@ -78,7 +78,7 @@ $ hledger -f- reg date:2019-01-01-2019-02-01 $ hledger -f- reg date:2019-01-2019-02 2019-01-01 (a) 2 2 -# ** 0. A "every Nth day (of month)" periodic rule will generate occurences only after the start date. (#2218) +# ** 0. A "every Nth day (of month)" periodic rule will generate occurrences only after the start date. (#2218) < ~ every 31st day from 2024-07 to 2024-09 (a) 1 diff --git a/hledger/test/register/intervals.test b/hledger/test/register/intervals.test index e2bc130ba..d9815d01e 100644 --- a/hledger/test/register/intervals.test +++ b/hledger/test/register/intervals.test @@ -136,3 +136,114 @@ $ hledger -f- register --monthly $ hledger -f- register -p monthly 2019-01 a 2 2 2019-02 a 1 3 + +# ** Date adjustment/clipping, with various intervals, of periodic reports and periodic transactions. +# With periodic reports generally: +# Start dates should be within the specified report period. +# If start date is unspecifed, it should be the inferred start date adjusted to a natural boundary. +# The end date should be adjusted so that the last period has equal length. +# With periodic transactions generally: +# All occurrences should be within the specified report period. +# If start date is unspecifed, it should be the inferred start date adjusted to a natural boundary. +# The end date should be adjusted so that the gap before last occurrence has equal length. (?) + +# ** 13. every Nth day of month from DATE. +< +2024-01-02 + (monthly1/02) 1 + +2024-01-10 + (monthly1/10) 1 + +2024-02-20 + (monthly2/20) 1 + +2024-02-24 + (monthly2/24) 1 + +$ hledger -f- reg monthly -p 'every 5th day of month from 2024/1/5 to 2024/2/14' +2024-01-05..2024-02-04 monthly1/10 1 1 +2024-02-05..2024-03-04 monthly2/20 1 2 + monthly2/24 1 3 + +# ** 14. every Nth day of month from DATE, periodic transactions. #2218, fixed in 1.40. +< +~ every 31st day from 2024-07 to 2024-09 + (a) 1 + +$ hledger -f- reg --forecast=2024 +2024-07-31 (a) 1 1 +2024-08-31 (a) 1 2 + +# ** 15. every M/D from DATE. Fixed in 1.40. +< +2023-01-10 + (yearly2023/1/10) 1 + +2024-01-10 + (yearly2024/1/10) 1 + +2025-01-10 + (yearly2025/1/10) 1 + +2026-01-10 + (yearly2026/1/10) 1 + +$ hledger -f- reg yearly -p 'every 1/20 from 2024 to 2026' +2024-01-20..2025-01-19 yearly2025/1/10 1 1 +2025-01-20..2026-01-19 yearly2026/1/10 1 2 + +# ** 16. every M/D from DATE, periodic transactions. Fixed in 1.40. +< +~ every 14th February from 2024 to 2026 + (yearly) 1 + +$ hledger -f- reg yearly --forecast=2022-2027 +2024-02-14 (yearly) 1 1 +2025-02-14 (yearly) 1 2 + + +# ** 17. every Nth WEEKDAY, inferred start date. +# The start date is adjusted to 2023/12/11, encompassing the 2024/1/1 posting. +< +2024-01-01 + (mondays2024/01/01) 1 + +2024-01-08 + (mondays2024/01/08) 1 + +2024-01-15 + (mondays2024/01/15) 1 + +2024-02-05 + (mondays2024/02/05) 1 + +2024-02-12 + (mondays2024/02/12) 1 + +2024-02-19 + (mondays2024/02/19) 1 + +$ hledger -f- reg mondays -p 'every 2nd monday' +2023-12-11..2024-01-07 mondays2024/01/01 1 1 +2024-01-08..2024-02-11 mondays2024/01/08 1 2 + mondays2024/01/15 1 3 + mondays2024/02/05 1 4 +2024-02-12..2024-03-10 mondays2024/02/12 1 5 + mondays2024/02/19 1 6 + +# ** 18. every Nth WEEKDAY from DATE. Fixed in 1.40. +$ hledger -f- reg mondays -p 'every 2nd monday from 2024/1/5 to 2024/2' +2024-01-08..2024-02-11 mondays2024/01/08 1 1 + mondays2024/01/15 1 2 + mondays2024/02/05 1 3 + +# ** 19. every Nth WEEKDAY from DATE, periodic transactions. +< +~ every 2nd monday from 2024/1/5 to 2024/3 + (mondays) 1 + +$ hledger -f- reg mondays --forecast=2024 +2024-01-08 (mondays) 1 1 +2024-02-12 (mondays) 1 2 +