From c23087f1246e9a4da8190bf3c66ec5b2d91fde52 Mon Sep 17 00:00:00 2001
From: Simon Michael <simon@joyful.com>
Date: Fri, 20 Dec 2024 10:01:16 -1000
Subject: [PATCH] fix: show a week period beginning in the previous year
 correctly [#2304]

Eg the week beginning 2024-12-30 (which is week 1 of 2025 because the
thursday falls in 2025) was previously shown as 2024-W01, now 2025-W01.
---
 hledger-lib/Hledger/Data/Dates.hs  |  3 ++-
 hledger-lib/Hledger/Data/Period.hs | 12 +++++++++++-
 2 files changed, 13 insertions(+), 2 deletions(-)

diff --git a/hledger-lib/Hledger/Data/Dates.hs b/hledger-lib/Hledger/Data/Dates.hs
index b43f5ca4823..0d55bd8c3a7 100644
--- a/hledger-lib/Hledger/Data/Dates.hs
+++ b/hledger-lib/Hledger/Data/Dates.hs
@@ -218,7 +218,7 @@ spansSpan spans = DateSpan (spanStartDate =<< headMay spans) (spanEndDate =<< la
 -- >>> t (Months 2) 2008 01 01 2008 04 01
 -- [DateSpan 2008-01-01..2008-02-29,DateSpan 2008-03-01..2008-04-30]
 -- >>> t (Weeks 1) 2008 01 01 2008 01 15
--- [DateSpan 2007-W01,DateSpan 2008-W02,DateSpan 2008-W03]
+-- [DateSpan 2008-W01,DateSpan 2008-W02,DateSpan 2008-W03]
 -- >>> t (Weeks 2) 2008 01 01 2008 01 15
 -- [DateSpan 2007-12-31..2008-01-13,DateSpan 2008-01-14..2008-01-27]
 -- >>> t (MonthDay 2) 2008 01 01 2008   04 01
@@ -252,6 +252,7 @@ splitSpan _      (DaysOfWeek [])          ds = [ds]
 splitSpan _      (DaysOfWeek days@(n:_))  ds = spansFromBoundaries e bdrys
   where
     (s, e) = dateSpanSplitLimits (nthdayofweekcontaining n) nextday ds
+    -- can't show this when debugging, it'll hang:
     bdrys = concatMap (flip map starts . addDays) [0,7..]
     -- The first representative of each weekday
     starts = map (\d -> addDays (toInteger $ d - n) $ nthdayofweekcontaining n s) days
diff --git a/hledger-lib/Hledger/Data/Period.hs b/hledger-lib/Hledger/Data/Period.hs
index 6077ac5e168..b2c7ed60c92 100644
--- a/hledger-lib/Hledger/Data/Period.hs
+++ b/hledger-lib/Hledger/Data/Period.hs
@@ -26,6 +26,7 @@ module Hledger.Data.Period (
   ,periodGrow
   ,periodShrink
   ,mondayBefore
+  ,thursdayOfWeekContaining
   ,yearMonthContainingWeekStarting
   ,quarterContainingMonth
   ,firstMonthOfQuarter
@@ -174,9 +175,14 @@ periodTextWidth = periodTextWidth' . simplifyPeriod
 --
 -- >>> showPeriod (WeekPeriod (fromGregorian 2016 7 25))
 -- "2016-W30"
+-- >>> showPeriod (WeekPeriod (fromGregorian 2024 12 30))
+-- "2025-W01"
 showPeriod :: Period -> Text
 showPeriod (DayPeriod b)       = T.pack $ formatTime defaultTimeLocale "%F" b              -- DATE
-showPeriod (WeekPeriod b)      = T.pack $ formatTime defaultTimeLocale "%0Y-W%V" b         -- YYYY-Www
+showPeriod (WeekPeriod b)      = T.pack $ y <> "-W" <> w                                   -- YYYY-Www
+  where
+    y = formatTime defaultTimeLocale "%0Y" $ thursdayOfWeekContaining b  -- be careful at year boundary
+    w = formatTime defaultTimeLocale "%V" b
 showPeriod (MonthPeriod y m)   = T.pack $ printf "%04d-%02d" y m                           -- YYYY-MM
 showPeriod (QuarterPeriod y q) = T.pack $ printf "%04dQ%d" y q                             -- YYYYQN
 showPeriod (YearPeriod y)      = T.pack $ printf "%04d" y                                  -- YYYY
@@ -190,6 +196,8 @@ showPeriod PeriodAll           = ".."
 -- an abbreviated form.
 -- >>> showPeriodAbbrev (WeekPeriod (fromGregorian 2016 7 25))
 -- "W30"
+-- >>> showPeriodAbbrev (WeekPeriod (fromGregorian 2024 12 30))
+-- "W01"
 showPeriodAbbrev :: Period -> Text
 showPeriodAbbrev (MonthPeriod _ m)                                              -- Jan
   | m > 0 && m <= length monthnames = T.pack . snd $ monthnames !! (m-1)
@@ -325,6 +333,8 @@ mondayBefore d = addDays (1 - toInteger wd) d
   where
     (_,_,wd) = toWeekDate d
 
+thursdayOfWeekContaining = (addDays 3).mondayBefore
+
 yearMonthContainingWeekStarting weekstart = (y,m)
   where
     thu = addDays 3 weekstart