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

dev!: lib: Refactor splitSpan to return Maybe DayPartition.

Browse Source 
This eliminates all error calls from the chain calculating report
periods.
This commit is contained in:
Stephen Morgan 2025-09-10 10:59:48 +02:00 committed by Simon Michael
parent b9caa4d948
commit 4e9fa1615c
7 changed files with 220 additions and 195 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -66,14 +66,14 @@ import Hledger.Data.Valuation
tests_Data = testGroup "Data" [ tests_Data = testGroup "Data" [
tests_Account tests_Account
,tests_AccountName ,tests_AccountName
,tests_BalanceData
,tests_PeriodData
,tests_Amount ,tests_Amount
,tests_BalanceData
,tests_Balancing ,tests_Balancing
,tests_DayPartition
-- ,tests_Currency -- ,tests_Currency
,tests_Dates
,tests_Journal ,tests_Journal
,tests_Ledger ,tests_Ledger
,tests_PeriodData
,tests_Posting ,tests_Posting
,tests_Valuation ,tests_Valuation
,tests_StringFormat ,tests_StringFormat

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

@ -70,8 +70,6 @@ module Hledger.Data.Dates (
daysSpan, daysSpan,
latestSpanContaining, latestSpanContaining,
smartdate, smartdate,
splitSpan,
spansFromBoundaries,
groupByDateSpan, groupByDateSpan,
fixSmartDate, fixSmartDate,
fixSmartDateStr, fixSmartDateStr,
@ -80,9 +78,22 @@ module Hledger.Data.Dates (
yearp, yearp,
daysInSpan, daysInSpan,
tests_Dates -- Temp exports
, intervalBoundaryBefore) startofyear,
where startofquarter,
startofmonth,
startofweek,
nextday,
nextweek,
nextmonthandday,
nextnthdayofmonth,
prevNthWeekdayOfMonth,
nthdayofweekcontaining,
addGregorianMonthsToMonthday,
advanceToNthWeekday,
nextNthWeekdayOfMonth,
isEmptySpan
) where
import Prelude hiding (Applicative(..)) import Prelude hiding (Applicative(..))
import Control.Applicative (Applicative(..)) import Control.Applicative (Applicative(..))
@ -188,76 +199,6 @@ spanYears (DateSpan ma mb) = mapMaybe (fmap (first3 . toGregorian. fromEFDay)) [
spansSpan :: [DateSpan] -> DateSpan spansSpan :: [DateSpan] -> DateSpan
spansSpan spans = DateSpan (spanStartDate =<< headMay spans) (spanEndDate =<< lastMay spans) spansSpan spans = DateSpan (spanStartDate =<< headMay spans) (spanEndDate =<< lastMay spans)
-- | Split a DateSpan into consecutive exact spans of the specified Interval.
-- 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.
--
-- ==== 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]
-- >>> t (Quarters 1) 2008 01 01 2009 01 01
-- [DateSpan 2008Q1,DateSpan 2008Q2,DateSpan 2008Q3,DateSpan 2008Q4]
-- >>> splitSpan True (Quarters 1) nulldatespan
-- [DateSpan ..]
-- >>> t (Days 1) 2008 01 01 2008 01 01 -- an empty datespan
-- []
-- >>> t (Quarters 1) 2008 01 01 2008 01 01
-- []
-- >>> t (Months 1) 2008 01 01 2008 04 01
-- [DateSpan 2008-01,DateSpan 2008-02,DateSpan 2008-03]
-- >>> 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 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
-- [DateSpan 2008-01-02..2008-02-01,DateSpan 2008-02-02..2008-03-01,DateSpan 2008-03-02..2008-04-01]
-- >>> t (NthWeekdayOfMonth 2 4) 2011 01 01 2011 02 15
-- [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 (MonthAndDay 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 adjust (NthWeekdayOfMonth n wd) ds = splitspan (if adjust then prevstart else nextstart) advancemonths 1 ds
where
prevstart = prevNthWeekdayOfMonth n wd
nextstart = nextNthWeekdayOfMonth n wd
advancemonths 0 = id
advancemonths m = advanceToNthWeekday n wd . startofmonth . addGregorianMonthsClip m
splitSpan _ (MonthDay dom) ds = splitspan (nextnthdayofmonth dom) (addGregorianMonthsToMonthday dom) 1 ds
splitSpan _ (MonthAndDay m d) ds = splitspan (nextmonthandday m d) (addGregorianYearsClip) 1 ds
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
-- Like addGregorianMonthsClip, add one month to the given date, clipping when needed -- Like addGregorianMonthsClip, add one month to the given date, clipping when needed
-- to fit it within the next month's length. But also, keep a target day of month in mind, -- to fit it within the next month's length. But also, keep a target day of month in mind,
-- and revert to that or as close to it as possible in subsequent longer months. -- and revert to that or as close to it as possible in subsequent longer months.
@ -267,31 +208,6 @@ addGregorianMonthsToMonthday dom n d =
let (y,m,_) = toGregorian $ addGregorianMonthsClip n d let (y,m,_) = toGregorian $ addGregorianMonthsClip n d
in fromGregorian y m dom in fromGregorian y m dom
-- Split the given span into exact spans using the provided helper functions:
--
-- 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 next mult ds = spansFromBoundaries e bdrys
where
(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)
dateSpanSplitLimits start _ (DateSpan (Just s) (Just e)) = (start $ fromEFDay s, fromEFDay e)
dateSpanSplitLimits start next (DateSpan (Just s) Nothing) = (start $ fromEFDay s, next $ start $ fromEFDay s)
dateSpanSplitLimits start next (DateSpan Nothing (Just e)) = (start $ fromEFDay e, next $ start $ fromEFDay e)
dateSpanSplitLimits _ _ (DateSpan Nothing Nothing) = error' "dateSpanSplitLimits: should not be nulldatespan" -- PARTIAL: This case should have been handled in splitSpan
-- | Construct a list of exact 'DateSpan's from a list of boundaries, which fit within a given range.
spansFromBoundaries :: Day -> [Day] -> [DateSpan]
spansFromBoundaries e bdrys = zipWith (DateSpan `on` (Just . Exact)) (takeWhile (< e) bdrys) $ drop 1 bdrys
-- | Count the days in a DateSpan, or if it is open-ended return Nothing. -- | Count the days in a DateSpan, or if it is open-ended return Nothing.
daysInSpan :: DateSpan -> Maybe Integer daysInSpan :: DateSpan -> Maybe Integer
daysInSpan (DateSpan (Just d1) (Just d2)) = Just $ diffDays (fromEFDay d2) (fromEFDay d1) daysInSpan (DateSpan (Just d1) (Just d2)) = Just $ diffDays (fromEFDay d2) (fromEFDay d1)
@ -669,14 +585,6 @@ thisyear = startofyear
nextyear = startofyear . addGregorianYearsClip 1 nextyear = startofyear . addGregorianYearsClip 1
startofyear day = fromGregorian y 1 1 where (y,_,_) = toGregorian day startofyear day = fromGregorian y 1 1 where (y,_,_) = toGregorian day
-- Get the natural start for the given interval that falls on or before the given day,
-- when applicable. Works for Weeks, Months, Quarters, Years, eg.
intervalBoundaryBefore :: Interval -> Day -> Day
intervalBoundaryBefore i d =
case splitSpan True i (DateSpan (Just $ Exact d) (Just $ Exact $ addDays 1 d)) of
(DateSpan (Just start) _:_) -> fromEFDay start
_ -> d
-- | Find the next occurrence of the specified month and day of month, on or after the given date. -- | 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. -- The month should be 1-12 and the day of month should be 1-31, or an error will be raised.
-- --
@ -1263,45 +1171,3 @@ emptydatespan = DateSpan (Just $ Exact $ addDays 1 nulldate) (Just $ Exact nulld
nulldate :: Day nulldate :: Day
nulldate = fromGregorian 0 1 1 nulldate = fromGregorian 0 1 1
-- tests
tests_Dates = testGroup "Dates"
[ testCase "weekday" $ do
splitSpan False (DaysOfWeek [1..5]) (DateSpan (Just $ Exact $ fromGregorian 2021 07 01) (Just $ Exact $ fromGregorian 2021 07 08))
@?= [ (DateSpan (Just $ Exact $ fromGregorian 2021 06 28) (Just $ Exact $ fromGregorian 2021 06 29))
, (DateSpan (Just $ Exact $ fromGregorian 2021 06 29) (Just $ Exact $ fromGregorian 2021 06 30))
, (DateSpan (Just $ Exact $ fromGregorian 2021 06 30) (Just $ Exact $ fromGregorian 2021 07 01))
, (DateSpan (Just $ Exact $ fromGregorian 2021 07 01) (Just $ Exact $ fromGregorian 2021 07 02))
, (DateSpan (Just $ Exact $ fromGregorian 2021 07 02) (Just $ Exact $ fromGregorian 2021 07 05))
-- next week
, (DateSpan (Just $ Exact $ fromGregorian 2021 07 05) (Just $ Exact $ fromGregorian 2021 07 06))
, (DateSpan (Just $ Exact $ fromGregorian 2021 07 06) (Just $ Exact $ fromGregorian 2021 07 07))
, (DateSpan (Just $ Exact $ fromGregorian 2021 07 07) (Just $ Exact $ fromGregorian 2021 07 08))
]
splitSpan False (DaysOfWeek [1, 5]) (DateSpan (Just $ Exact $ fromGregorian 2021 07 01) (Just $ Exact $ fromGregorian 2021 07 08))
@?= [ (DateSpan (Just $ Exact $ fromGregorian 2021 06 28) (Just $ Exact $ fromGregorian 2021 07 02))
, (DateSpan (Just $ Exact $ fromGregorian 2021 07 02) (Just $ Exact $ fromGregorian 2021 07 05))
-- next week
, (DateSpan (Just $ Exact $ fromGregorian 2021 07 05) (Just $ Exact $ fromGregorian 2021 07 09))
]
, testCase "match dayOfWeek" $ do
let dayofweek n = splitspan (nthdayofweekcontaining n) (\w -> (if w == 0 then id else applyN (n-1) nextday . applyN (fromInteger w) nextweek)) 1
matchdow ds day = splitSpan False (DaysOfWeek [day]) ds @?= dayofweek day ds
ys2021 = fromGregorian 2021 01 01
ye2021 = fromGregorian 2021 12 31
ys2022 = fromGregorian 2022 01 01
mapM_ (matchdow (DateSpan (Just $ Exact ys2021) (Just $ Exact ye2021))) [1..7]
mapM_ (matchdow (DateSpan (Just $ Exact ys2021) (Just $ Exact ys2022))) [1..7]
mapM_ (matchdow (DateSpan (Just $ Exact ye2021) (Just $ Exact ys2022))) [1..7]
mapM_ (matchdow (DateSpan (Just $ Exact ye2021) Nothing)) [1..7]
mapM_ (matchdow (DateSpan (Just $ Exact ys2022) Nothing)) [1..7]
mapM_ (matchdow (DateSpan Nothing (Just $ Exact ye2021))) [1..7]
mapM_ (matchdow (DateSpan Nothing (Just $ Exact ys2022))) [1..7]
]

188
hledger-lib/Hledger/Data/DayPartition.hs
View File

@ -11,16 +11,21 @@ module Hledger.Data.DayPartition
, dayPartitionToNonEmpty , dayPartitionToNonEmpty
, dayPartitionToList , dayPartitionToList
, dayPartitionToPeriodData , dayPartitionSpans
, dayPartitionToDateSpans , dayPartitionToDateSpans
, dayPartitionToPeriodData
, maybeDayPartitionToDateSpans , maybeDayPartitionToDateSpans
, dateSpansToDayPartition
, splitSpan
, intervalBoundaryBefore
, tests_DayPartition
) where ) where
import qualified Data.IntMap.Strict as IM import qualified Data.IntMap.Strict as IM
import Data.List.NonEmpty (NonEmpty(..)) import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NE import qualified Data.List.NonEmpty as NE
import Data.Time (Day, addDays) import Data.Time (Day(..), addDays, addGregorianMonthsClip, addGregorianYearsClip, fromGregorian)
import Hledger.Data.Dates import Hledger.Data.Dates
import Hledger.Data.PeriodData import Hledger.Data.PeriodData
@ -56,9 +61,10 @@ isValidDayPartition (DayPartition pd) = case ds of
-- | Construct a 'DayPartition' from a non-empty list of boundary days. -- | Construct a 'DayPartition' from a non-empty list of boundary days.
boundariesToDayPartition :: NonEmpty Day -> DayPartition boundariesToDayPartition :: NonEmpty Day -> DayPartition
boundariesToDayPartition xs = boundariesToDayPartition xs = DayPartition . periodDataFromList (addDays (-1) b) $ case bs of
DayPartition $ periodDataFromList (addDays (-1) b) $ zip (b:bs) (map (addDays (-1)) bs) [] -> [(b, b)] -- If only one boundary is supplied, it ends on the same day
where (b:|bs) = NE.nub $ NE.sort xs _:_ -> zip (b:bs) $ map (addDays (-1)) bs -- Guaranteed non-empty
where b:|bs = NE.nub $ NE.sort xs
-- | Construct a 'DayPartition' from a list of boundary days, returning -- | Construct a 'DayPartition' from a list of boundary days, returning
-- 'Nothing' for the empty list. -- 'Nothing' for the empty list.
@ -93,6 +99,12 @@ dayPartitionToNonEmpty (DayPartition xs) = NE.fromList . snd $ periodDataToList
dayPartitionToList :: DayPartition -> [(Day, Day)] dayPartitionToList :: DayPartition -> [(Day, Day)]
dayPartitionToList = NE.toList . dayPartitionToNonEmpty dayPartitionToList = NE.toList . dayPartitionToNonEmpty
-- | Return the whole day range spanned by a `PeriodData Day`.
dayPartitionSpans :: DayPartition -> (Day, Day)
dayPartitionSpans (DayPartition (PeriodData _ ds)) =
-- Guaranteed not to error because the IntMap in non-empty.
(intToDay . fst $ IM.findMin ds, snd $ IM.findMax ds)
-- | Convert 'DayPartition' to a list of 'DateSpan's. -- | Convert 'DayPartition' to a list of 'DateSpan's.
-- --
-- Note that the end date of each period will be equal to the start date of -- Note that the end date of each period will be equal to the start date of
@ -111,21 +123,153 @@ dayPartitionToDateSpans = map toDateSpan . dayPartitionToList
maybeDayPartitionToDateSpans :: Maybe DayPartition -> [DateSpan] maybeDayPartitionToDateSpans :: Maybe DayPartition -> [DateSpan]
maybeDayPartitionToDateSpans = maybe [DateSpan Nothing Nothing] dayPartitionToDateSpans maybeDayPartitionToDateSpans = maybe [DateSpan Nothing Nothing] dayPartitionToDateSpans
-- | Convert a list of 'DateSpan's to a 'DayPartition', or 'Nothing' if it is not well-formed.
-- | Split a 'DateSpan' into a 'DayPartition' consisting of consecutive exact
-- spans of the specified Interval, or `Nothing` if the span is invalid.
-- If no interval is specified, the original span is returned.
-- If the original span is the null date span, ie unbounded, `Nothing` is returned.
-- If the original span is empty, eg if the end date is <= the start date, `Nothing` is returned.
-- --
-- Warning: This can construct ill-formed 'DayPartitions' and can raise errors. -- ==== Date adjustment
-- It will be eliminated later. -- Some intervals respect the "adjust" flag (years, quarters, months, weeks, every Nth weekday
-- PARTIAL: -- of month seem to be the ones that need it). This will move the start date earlier, if needed,
dateSpansToDayPartition :: [DateSpan] -> Maybe DayPartition -- to the previous natural interval boundary (first of year, first of quarter, first of month,
-- Handle the cases of partitions which would arise from journals with no transactions -- monday, previous Nth weekday of month). Related: #1982 #2218
dateSpansToDayPartition [] = Nothing --
dateSpansToDayPartition [DateSpan Nothing Nothing] = Nothing -- The end date is always moved later if needed to the next natural interval boundary,
dateSpansToDayPartition [DateSpan Nothing (Just _)] = Nothing -- so that the last period is the same length as the others.
dateSpansToDayPartition [DateSpan (Just _) Nothing] = Nothing --
-- Handle properly defined reports -- ==== Examples
dateSpansToDayPartition (x:xs) = Just . DayPartition $ -- >>> let t i y1 m1 d1 y2 m2 d2 = fmap dayPartitionToNonEmpty . splitSpan True i $ DateSpan (Just $ Flex $ fromGregorian y1 m1 d1) (Just $ Flex $ fromGregorian y2 m2 d2)
periodDataFromList (addDays (-1) . fst $ boundaries x) (map boundaries (x:xs)) -- >>> t NoInterval 2008 01 01 2009 01 01
-- Just ((2008-01-01,2008-12-31) :| [])
-- >>> t (Quarters 1) 2008 01 01 2009 01 01
-- Just ((2008-01-01,2008-03-31) :| [(2008-04-01,2008-06-30),(2008-07-01,2008-09-30),(2008-10-01,2008-12-31)])
-- >>> splitSpan True (Quarters 1) nulldatespan
-- Nothing
-- >>> t (Days 1) 2008 01 01 2008 01 01 -- an empty datespan
-- Nothing
-- >>> t (Quarters 1) 2008 01 01 2008 01 01
-- Nothing
-- >>> t (Months 1) 2008 01 01 2008 04 01
-- Just ((2008-01-01,2008-01-31) :| [(2008-02-01,2008-02-29),(2008-03-01,2008-03-31)])
-- >>> t (Months 2) 2008 01 01 2008 04 01
-- Just ((2008-01-01,2008-02-29) :| [(2008-03-01,2008-04-30)])
-- >>> t (Weeks 1) 2008 01 01 2008 01 15
-- Just ((2007-12-31,2008-01-06) :| [(2008-01-07,2008-01-13),(2008-01-14,2008-01-20)])
-- >>> t (Weeks 2) 2008 01 01 2008 01 15
-- Just ((2007-12-31,2008-01-13) :| [(2008-01-14,2008-01-27)])
-- >>> t (MonthDay 2) 2008 01 01 2008 04 01
-- Just ((2008-01-02,2008-02-01) :| [(2008-02-02,2008-03-01),(2008-03-02,2008-04-01)])
-- >>> t (NthWeekdayOfMonth 2 4) 2011 01 01 2011 02 15
-- Just ((2010-12-09,2011-01-12) :| [(2011-01-13,2011-02-09),(2011-02-10,2011-03-09)])
-- >>> t (DaysOfWeek [2]) 2011 01 01 2011 01 15
-- Just ((2010-12-28,2011-01-03) :| [(2011-01-04,2011-01-10),(2011-01-11,2011-01-17)])
-- >>> t (MonthAndDay 11 29) 2012 10 01 2013 10 15
-- Just ((2012-11-29,2013-11-28) :| [])
splitSpan :: Bool -> Interval -> DateSpan -> Maybe DayPartition
splitSpan _ _ (DateSpan Nothing Nothing) = Nothing
splitSpan _ _ ds | isEmptySpan ds = Nothing
splitSpan _ NoInterval (DateSpan (Just s) (Just e)) = Just $ boundariesToDayPartition (fromEFDay s :| [fromEFDay e])
splitSpan _ NoInterval _ = Nothing
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 adjust (NthWeekdayOfMonth n wd) ds = splitspan (startWeekdayOfMonth n wd) advancemonths 1 ds
where where
boundaries spn = makeJust (spanStart spn, addDays (-1) <$> spanEnd spn) startWeekdayOfMonth = if adjust then prevNthWeekdayOfMonth else nextNthWeekdayOfMonth
makeJust (Just a, Just b) = (a, b) advancemonths 0 = id
makeJust ab = error' $ "dateSpansToDayPartition: expected all spans to have start and end dates, but one has " ++ show ab advancemonths m = advanceToNthWeekday n wd . startofmonth . addGregorianMonthsClip m
splitSpan _ (MonthDay dom) ds = splitspan (nextnthdayofmonth dom) (addGregorianMonthsToMonthday dom) 1 ds
splitSpan _ (MonthAndDay m d) ds = splitspan (nextmonthandday m d) addGregorianYearsClip 1 ds
splitSpan _ (DaysOfWeek []) _ = Nothing
splitSpan _ (DaysOfWeek days@(n:_)) ds = do
(s, e) <- dateSpanSplitLimits (nthdayofweekcontaining n) nextday ds
let -- can't show this when debugging, it'll hang:
bdrys = concatMap (\d -> map (addDays d) starts) [0,7..]
-- The first representative of each weekday
starts = map (\d -> addDays (toInteger $ d - n) $ nthdayofweekcontaining n s) days
spansFromBoundaries e bdrys
-- | Fill in missing start/end dates for calculating 'splitSpan'.
dateSpanSplitLimits :: (Day -> Day) -> (Day -> Day) -> DateSpan -> Maybe (Day, Day)
dateSpanSplitLimits _ _ (DateSpan Nothing Nothing) = Nothing
dateSpanSplitLimits _ _ ds | isEmptySpan ds = Nothing
dateSpanSplitLimits start _ (DateSpan (Just s) (Just e)) = Just (start $ fromEFDay s, fromEFDay e)
dateSpanSplitLimits start next (DateSpan (Just s) Nothing) = Just (start $ fromEFDay s, next $ start $ fromEFDay s)
dateSpanSplitLimits start next (DateSpan Nothing (Just e)) = Just (start $ fromEFDay e, next $ start $ fromEFDay e)
-- Split the given span into exact spans using the provided helper functions:
--
-- 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 -> Maybe DayPartition
splitspan start next mult ds = do
(s, e) <- dateSpanSplitLimits start (next (toInteger mult)) ds
let bdrys = mapM (next . toInteger) [0,mult..] $ start s
spansFromBoundaries e bdrys
-- | Construct a list of exact 'DateSpan's from a list of boundaries, which fit within a given range.
spansFromBoundaries :: Day -> [Day] -> Maybe DayPartition
spansFromBoundaries _ [] = Nothing
spansFromBoundaries e (x:_) | x >= e = Nothing
spansFromBoundaries e (x:xs) = Just . boundariesToDayPartition $ takeUntilFailsNE (<e) (x:|xs)
-- Get the natural start for the given interval that falls on or before the given day,
-- when applicable. Works for Weeks, Months, Quarters, Years, eg.
intervalBoundaryBefore :: Interval -> Day -> Day
intervalBoundaryBefore i d =
case dayPartitionToNonEmpty <$> splitSpan True i (DateSpan (Just $ Exact d) (Just . Exact $ addDays 1 d)) of
Just ((start, _) :| _ ) -> start
_ -> d
intToDay = ModifiedJulianDay . toInteger
tests_DayPartition =
testGroup "splitSpan" [
testCase "weekday" $ do
fmap dayPartitionToNonEmpty (splitSpan False (DaysOfWeek [1..5]) (DateSpan (Just $ Exact $ fromGregorian 2021 07 01) (Just $ Exact $ fromGregorian 2021 07 08)))
@?= Just ( (fromGregorian 2021 06 28, fromGregorian 2021 06 28) :|
[ (fromGregorian 2021 06 29, fromGregorian 2021 06 29)
, (fromGregorian 2021 06 30, fromGregorian 2021 06 30)
, (fromGregorian 2021 07 01, fromGregorian 2021 07 01)
, (fromGregorian 2021 07 02, fromGregorian 2021 07 04)
-- next week
, (fromGregorian 2021 07 05, fromGregorian 2021 07 05)
, (fromGregorian 2021 07 06, fromGregorian 2021 07 06)
, (fromGregorian 2021 07 07, fromGregorian 2021 07 07)
])
fmap dayPartitionToNonEmpty (splitSpan False (DaysOfWeek [1, 5]) (DateSpan (Just $ Exact $ fromGregorian 2021 07 01) (Just $ Exact $ fromGregorian 2021 07 08)))
@?= Just ( (fromGregorian 2021 06 28, fromGregorian 2021 07 01) :|
[ (fromGregorian 2021 07 02, fromGregorian 2021 07 04)
-- next week
, (fromGregorian 2021 07 05, fromGregorian 2021 07 08)
])
, testCase "match dayOfWeek" $ do
let dayofweek n = splitspan (nthdayofweekcontaining n) (\w -> (if w == 0 then id else applyN (n-1) nextday . applyN (fromInteger w) nextweek)) 1
matchdow ds day = splitSpan False (DaysOfWeek [day]) ds @?= dayofweek day ds
ys2021 = fromGregorian 2021 01 01
ye2021 = fromGregorian 2021 12 31
ys2022 = fromGregorian 2022 01 01
mapM_ (matchdow (DateSpan (Just $ Exact ys2021) (Just $ Exact ye2021))) [1..7]
mapM_ (matchdow (DateSpan (Just $ Exact ys2021) (Just $ Exact ys2022))) [1..7]
mapM_ (matchdow (DateSpan (Just $ Exact ye2021) (Just $ Exact ys2022))) [1..7]
mapM_ (matchdow (DateSpan (Just $ Exact ye2021) Nothing)) [1..7]
mapM_ (matchdow (DateSpan (Just $ Exact ys2022) Nothing)) [1..7]
mapM_ (matchdow (DateSpan Nothing (Just $ Exact ye2021))) [1..7]
mapM_ (matchdow (DateSpan Nothing (Just $ Exact ys2022))) [1..7]
]

14
hledger-lib/Hledger/Data/PeriodData.hs
View File

@ -133,12 +133,12 @@ tests_PeriodData =
dayMap2 = periodDataFromList (mixed [usd 2]) [(fromGregorian 2000 01 01, mixed [usd 4]), (fromGregorian 2004 02 28, mixed [usd 6])] dayMap2 = periodDataFromList (mixed [usd 2]) [(fromGregorian 2000 01 01, mixed [usd 4]), (fromGregorian 2004 02 28, mixed [usd 6])]
in testGroup "PeriodData" [ in testGroup "PeriodData" [
testCase "periodDataFromList" $ do testCase "periodDataFromList" $ do
length dayMap @?= 3, length dayMap @?= 3,
testCase "Semigroup instance" $ do testCase "Semigroup instance" $ do
dayMap <> dayMap @?= dayMap2, dayMap <> dayMap @?= dayMap2,
testCase "Monoid instance" $ do testCase "Monoid instance" $ do
dayMap <> mempty @?= dayMap dayMap <> mempty @?= dayMap
] ]

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

@ -19,6 +19,7 @@ import Text.Printf
import Hledger.Data.Types import Hledger.Data.Types
import Hledger.Data.Dates import Hledger.Data.Dates
import Hledger.Data.DayPartition
import Hledger.Data.Amount import Hledger.Data.Amount
import Hledger.Data.Posting (post, generatedTransactionTagName) import Hledger.Data.Posting (post, generatedTransactionTagName)
import Hledger.Data.Transaction import Hledger.Data.Transaction
@ -198,7 +199,7 @@ instance Show PeriodicTransaction where
runPeriodicTransaction :: Bool -> PeriodicTransaction -> DateSpan -> [Transaction] runPeriodicTransaction :: Bool -> PeriodicTransaction -> DateSpan -> [Transaction]
runPeriodicTransaction verbosetags PeriodicTransaction{..} requestedspan = runPeriodicTransaction verbosetags PeriodicTransaction{..} requestedspan =
[ t{tdate=d} | (DateSpan (Just efd) _) <- alltxnspans, let d = fromEFDay efd, spanContainsDate requestedspan d ] [ t{tdate=d} | (d, _) <- maybe [] dayPartitionToList alltxnspans, spanContainsDate requestedspan d ]
where where
t = nulltransaction{ t = nulltransaction{
tsourcepos = ptsourcepos tsourcepos = ptsourcepos

25
hledger-lib/Hledger/Reports/ReportOptions.hs
View File

@ -71,7 +71,7 @@ where
import Prelude hiding (Applicative(..)) import Prelude hiding (Applicative(..))
import Control.Applicative (Applicative(..), Const(..), (<|>)) import Control.Applicative (Applicative(..), Const(..), (<|>))
import Control.Monad ((<=<), guard, join) import Control.Monad (guard, join)
import Data.Char (toLower) import Data.Char (toLower)
import Data.Either (fromRight) import Data.Either (fromRight)
import Data.Either.Extra (eitherToMaybe) import Data.Either.Extra (eitherToMaybe)
@ -82,7 +82,7 @@ import Data.Maybe (fromMaybe, isJust, isNothing)
import Data.Text qualified as T import Data.Text qualified as T
import Data.Time.Calendar (Day, addDays) import Data.Time.Calendar (Day, addDays)
import Data.Default (Default(..)) import Data.Default (Default(..))
import Safe (headMay, lastDef, lastMay, maximumMay, readMay) import Safe (lastDef, lastMay, maximumMay, readMay)
import Hledger.Data import Hledger.Data
import Hledger.Query import Hledger.Query
@ -670,16 +670,17 @@ journalApplyValuationFromOptsWith rspec@ReportSpec{_rsReportOpts=ropts} j priceo
-- with no interval it's the last date of the overall report period -- with no interval it's the last date of the overall report period
-- (which for an end value report may have been extended to include the latest non-future P directive). -- (which for an end value report may have been extended to include the latest non-future P directive).
-- To get the period's last day, we subtract one from the (exclusive) period end date. -- To get the period's last day, we subtract one from the (exclusive) period end date.
postingperiodend = addDays (-1) . fromMaybe err . mPeriodEnd . postingDateOrDate2 (whichDate ropts) postingperiodend = postingPeriodEnd . postingDateOrDate2 (whichDate ropts)
where where
mPeriodEnd = case interval_ ropts of postingPeriodEnd d = fromMaybe err $ case interval_ ropts of
NoInterval -> const . spanEnd . fst $ reportSpan j rspec NoInterval -> fmap (snd . dayPartitionSpans) . snd $ reportSpan j rspec
_ -> spanEnd <=< latestSpanContaining (historical : spans) _ -> fmap (snd . lookupDayPartition d) . snd $ reportSpanBothDates j rspec
-- Should never happen, because there are only invalid dayPartitions
-- when there are no transactions, in which case this function is never called
err = error' "journalApplyValuationFromOpts: expected all spans to have an end date"
historical = DateSpan Nothing $ (fmap Exact . spanStart) =<< headMay spans
spans = maybeDayPartitionToDateSpans . snd $ reportSpanBothDates j rspec
styles = journalCommodityStyles j styles = journalCommodityStyles j
err = error' "journalApplyValuationFromOpts: expected all spans to have an end date"
-- | Select the Account valuation functions required for performing valuation after summing -- | Select the Account valuation functions required for performing valuation after summing
-- amounts. Used in MultiBalanceReport to value historical and similar reports. -- amounts. Used in MultiBalanceReport to value historical and similar reports.
@ -789,7 +790,7 @@ reportSpanBothDates = reportSpanHelper True
reportSpanHelper :: Bool -> Journal -> ReportSpec -> (DateSpan, Maybe DayPartition) reportSpanHelper :: Bool -> Journal -> ReportSpec -> (DateSpan, Maybe DayPartition)
reportSpanHelper bothdates j ReportSpec{_rsQuery=query, _rsReportOpts=ropts, _rsDay=today} = reportSpanHelper bothdates j ReportSpec{_rsQuery=query, _rsReportOpts=ropts, _rsDay=today} =
(enlargedreportspan, dateSpansToDayPartition $ if not (null intervalspans) then intervalspans else [enlargedreportspan]) (enlargedreportspan, intervalspans)
where where
-- The date span specified by -b/-e/-p options and query args if any. -- The date span specified by -b/-e/-p options and query args if any.
requestedspan = dbg3 "requestedspan" $ requestedspan = dbg3 "requestedspan" $
@ -823,8 +824,8 @@ reportSpanHelper bothdates j ReportSpec{_rsQuery=query, _rsReportOpts=ropts, _rs
-- The requested span enlarged to enclose a whole number of intervals. -- The requested span enlarged to enclose a whole number of intervals.
-- This can be the null span if there were no intervals. -- This can be the null span if there were no intervals.
enlargedreportspan = dbg3 "enlargedreportspan" $ enlargedreportspan = dbg3 "enlargedreportspan" $
DateSpan (fmap Exact . spanStart =<< headMay intervalspans) maybe (DateSpan Nothing Nothing) (mkSpan . dayPartitionSpans) intervalspans
(fmap Exact . spanEnd =<< lastMay intervalspans) where mkSpan (s, e) = DateSpan (Just $ Exact s) (Just . Exact $ addDays 1 e)
reportStartDate :: Journal -> ReportSpec -> Maybe Day reportStartDate :: Journal -> ReportSpec -> Maybe Day
reportStartDate j = spanStart . fst . reportSpan j reportStartDate j = spanStart . fst . reportSpan j

13
hledger-lib/Hledger/Utils.hs
View File

@ -25,6 +25,8 @@ module Hledger.Utils (
splitAtElement, splitAtElement,
sumStrict, sumStrict,
all1, all1,
takeUntilFails,
takeUntilFailsNE,
-- * Trees -- * Trees
treeLeaves, treeLeaves,
@ -73,6 +75,7 @@ where
import Data.Char (toLower) import Data.Char (toLower)
import Data.List (intersperse) import Data.List (intersperse)
import Data.List.Extra (chunksOf, foldl1', uncons, unsnoc) import Data.List.Extra (chunksOf, foldl1', uncons, unsnoc)
import qualified Data.List.NonEmpty as NE
#if !MIN_VERSION_base(4,20,0) #if !MIN_VERSION_base(4,20,0)
import Data.List (foldl') import Data.List (foldl')
#endif #endif
@ -181,6 +184,16 @@ all1 :: (a -> Bool) -> [a] -> Bool
all1 _ [] = False all1 _ [] = False
all1 p as = all p as all1 p as = all p as
-- | Take elements from a non-empty list until a predicate fails, and then keep
-- the first failing element as well.
takeUntilFailsNE :: (a -> Bool) -> NE.NonEmpty a -> NE.NonEmpty a
takeUntilFailsNE p = NE.fromList . takeUntilFails p . NE.toList -- Result guaranteed to be non-empty
-- | Take elements from a list until a predicate fails, and then keep the first
-- failing element as well.
takeUntilFails :: (a -> Bool) -> [a] -> [a]
takeUntilFails p = foldr (\x -> if p x then (x :) else const [x]) []
-- Trees -- Trees
-- | Get the leaves of this tree as a list. -- | Get the leaves of this tree as a list.