diff --git a/hledger-lib/Hledger/Data.hs b/hledger-lib/Hledger/Data.hs index 812e1890d01..3cada9f9275 100644 --- a/hledger-lib/Hledger/Data.hs +++ b/hledger-lib/Hledger/Data.hs @@ -10,19 +10,20 @@ functionality. This package re-exports all the Hledger.Data.* modules module Hledger.Data ( module Hledger.Data.Account, - module Hledger.Data.BalanceData, - module Hledger.Data.PeriodData, module Hledger.Data.AccountName, module Hledger.Data.Amount, + module Hledger.Data.BalanceData, module Hledger.Data.Balancing, module Hledger.Data.Currency, module Hledger.Data.Dates, + module Hledger.Data.DayPartition, module Hledger.Data.Errors, module Hledger.Data.Journal, module Hledger.Data.JournalChecks, module Hledger.Data.Json, module Hledger.Data.Ledger, module Hledger.Data.Period, + module Hledger.Data.PeriodData, module Hledger.Data.PeriodicTransaction, module Hledger.Data.Posting, module Hledger.Data.RawOptions, @@ -39,18 +40,19 @@ where import Test.Tasty (testGroup) import Hledger.Data.Account import Hledger.Data.BalanceData -import Hledger.Data.PeriodData import Hledger.Data.AccountName import Hledger.Data.Amount import Hledger.Data.Balancing import Hledger.Data.Currency import Hledger.Data.Dates +import Hledger.Data.DayPartition import Hledger.Data.Errors import Hledger.Data.Journal import Hledger.Data.JournalChecks import Hledger.Data.Json import Hledger.Data.Ledger import Hledger.Data.Period +import Hledger.Data.PeriodData import Hledger.Data.PeriodicTransaction import Hledger.Data.Posting import Hledger.Data.RawOptions @@ -64,14 +66,14 @@ import Hledger.Data.Valuation tests_Data = testGroup "Data" [ tests_Account ,tests_AccountName - ,tests_BalanceData - ,tests_PeriodData ,tests_Amount + ,tests_BalanceData ,tests_Balancing + ,tests_DayPartition -- ,tests_Currency - ,tests_Dates ,tests_Journal ,tests_Ledger + ,tests_PeriodData ,tests_Posting ,tests_Valuation ,tests_StringFormat diff --git a/hledger-lib/Hledger/Data/Dates.hs b/hledger-lib/Hledger/Data/Dates.hs index 4f9a563af73..9c9f6db476c 100644 --- a/hledger-lib/Hledger/Data/Dates.hs +++ b/hledger-lib/Hledger/Data/Dates.hs @@ -70,8 +70,6 @@ module Hledger.Data.Dates ( daysSpan, latestSpanContaining, smartdate, - splitSpan, - spansFromBoundaries, groupByDateSpan, fixSmartDate, fixSmartDateStr, @@ -80,9 +78,22 @@ module Hledger.Data.Dates ( yearp, daysInSpan, - tests_Dates -, intervalBoundaryBefore) -where + -- Temp exports + startofyear, + startofquarter, + startofmonth, + startofweek, + nextday, + nextweek, + nextmonthandday, + nextnthdayofmonth, + prevNthWeekdayOfMonth, + nthdayofweekcontaining, + addGregorianMonthsToMonthday, + advanceToNthWeekday, + nextNthWeekdayOfMonth, + isEmptySpan +) where import Prelude hiding (Applicative(..)) import Control.Applicative (Applicative(..)) @@ -188,76 +199,6 @@ spanYears (DateSpan ma mb) = mapMaybe (fmap (first3 . toGregorian. fromEFDay)) [ spansSpan :: [DateSpan] -> DateSpan 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 -- 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. @@ -267,31 +208,6 @@ addGregorianMonthsToMonthday dom n d = let (y,m,_) = toGregorian $ addGregorianMonthsClip n d 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. daysInSpan :: DateSpan -> Maybe Integer daysInSpan (DateSpan (Just d1) (Just d2)) = Just $ diffDays (fromEFDay d2) (fromEFDay d1) @@ -669,14 +585,6 @@ thisyear = startofyear nextyear = startofyear . addGregorianYearsClip 1 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. -- 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 = 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] - - ] diff --git a/hledger-lib/Hledger/Data/DayPartition.hs b/hledger-lib/Hledger/Data/DayPartition.hs new file mode 100644 index 00000000000..b4d23adc7ae --- /dev/null +++ b/hledger-lib/Hledger/Data/DayPartition.hs @@ -0,0 +1,275 @@ +{-| +A partition of time into contiguous spans, for defining reporting periods. +-} +module Hledger.Data.DayPartition +( DayPartition +, boundariesToDayPartition +, boundariesToMaybeDayPartition + +, lookupDayPartition +, unionDayPartitions + +, dayPartitionToNonEmpty +, dayPartitionToList +, dayPartitionSpans +, dayPartitionToDateSpans +, dayPartitionToPeriodData +, maybeDayPartitionToDateSpans + +, splitSpan +, intervalBoundaryBefore + +, tests_DayPartition +) where + +import qualified Data.IntMap.Strict as IM +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NE +import Data.Time (Day(..), addDays, addGregorianMonthsClip, addGregorianYearsClip, fromGregorian) + +import Hledger.Data.Dates +import Hledger.Data.PeriodData +import Hledger.Data.Types +import Hledger.Utils + + +-- | A partition of time into contiguous spans, along with a historical period +-- before any of the spans. +-- +-- This is a newtype wrapper around 'PeriodData Day', where the start dates are +-- the keys and the end dates are the values. Spans are stored in inclusive format +-- [start, end]. Note that this differs from 'DateSpan' which uses [start, end) +-- format. +-- +-- The constructor is not exported so that we can ensure the spans are valid +-- partitions of time. +newtype DayPartition = DayPartition { dayPartitionToPeriodData :: PeriodData Day } deriving (Eq, Ord, Show) + +-- Developer's note. All constructors must guarantee that: +-- 1. The value stored in pdperiods has at least one key. +-- 2. The value stored in pdpre equals one day before the smallest key in pdperiods. +-- 3. The value stored in each entry of pdperiods equals one day before the +-- next largest key, except for the value associated to the largest key. +isValidDayPartition :: DayPartition -> Bool +isValidDayPartition (DayPartition pd) = case ds of + [] -> False -- Must be at least one key in pdperiods + xs -> and $ zipWith isContiguous ((nulldate, h) : xs) xs + where + (h, ds) = periodDataToList pd + isContiguous (_, e) (s, _) = addDays 1 e == s + + +-- | Construct a 'DayPartition' from a non-empty list of boundary days. +boundariesToDayPartition :: NonEmpty Day -> DayPartition +boundariesToDayPartition xs = DayPartition . periodDataFromList (addDays (-1) b) $ case bs of + [] -> [(b, b)] -- If only one boundary is supplied, it ends on the same day + _:_ -> 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 +-- 'Nothing' for the empty list. +boundariesToMaybeDayPartition :: [Day] -> Maybe DayPartition +boundariesToMaybeDayPartition = fmap boundariesToDayPartition . NE.nonEmpty + + +-- | Find the span of a 'DayPartition' which contains a given day. +lookupDayPartition :: Day -> DayPartition -> (Maybe Day, Day) +lookupDayPartition d (DayPartition xs) = lookupPeriodDataOrHistorical d xs + +-- | Return the union of two 'DayPartition's if they are consistent, or 'Nothing' otherwise. +unionDayPartitions :: DayPartition -> DayPartition -> Maybe DayPartition +unionDayPartitions (DayPartition (PeriodData h as)) (DayPartition (PeriodData h' as')) = + if equalIntersection as as' && isValidDayPartition union then Just union else Nothing + where + union = DayPartition . PeriodData (min h h') $ as <> as' + equalIntersection x y = and $ IM.intersectionWith (==) x y + + +-- | Convert 'DayPartition' to a non-empty list of start and end dates for the periods. +-- +-- Note that the end date of each period will be one day before the start date +-- of the next period. +dayPartitionToNonEmpty :: DayPartition -> NonEmpty (Day, Day) +dayPartitionToNonEmpty (DayPartition xs) = NE.fromList . snd $ periodDataToList xs -- Constructors guarantee this is non-empty + +-- | Convert 'DayPartition' to a list of start and end dates for the periods. +-- +-- Note that the end date of each period will be one day before the start date +-- of the next period. +dayPartitionToList :: DayPartition -> [(Day, Day)] +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. +-- +-- Note that the end date of each period will be equal to the start date of +-- the next period. +dayPartitionToDateSpans :: DayPartition -> [DateSpan] +dayPartitionToDateSpans = map toDateSpan . dayPartitionToList + where + toDateSpan (s, e) = DateSpan (toEFDay s) (toEFDay $ addDays 1 e) + toEFDay = Just . Exact + +-- Convert a periodic report 'Maybe DayPartition' to a list of 'DateSpans', +-- replacing the empty case with an appropriate placeholder. +-- +-- Note that the end date of each period will be equal to the start date of +-- the next period. +maybeDayPartitionToDateSpans :: Maybe DayPartition -> [DateSpan] +maybeDayPartitionToDateSpans = maybe [DateSpan Nothing Nothing] dayPartitionToDateSpans + + +-- | 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. +-- +-- ==== 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 = fmap dayPartitionToNonEmpty . splitSpan True i $ DateSpan (Just $ Flex $ fromGregorian y1 m1 d1) (Just $ Flex $ fromGregorian y2 m2 d2) +-- >>> 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 + startWeekdayOfMonth = if adjust then prevNthWeekdayOfMonth else nextNthWeekdayOfMonth + 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 []) _ = 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 ( 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] + + ] diff --git a/hledger-lib/Hledger/Data/PeriodData.hs b/hledger-lib/Hledger/Data/PeriodData.hs index de74259f025..162897c09d7 100644 --- a/hledger-lib/Hledger/Data/PeriodData.hs +++ b/hledger-lib/Hledger/Data/PeriodData.hs @@ -18,10 +18,6 @@ module Hledger.Data.PeriodData , mergePeriodData , padPeriodData -, periodDataToDateSpans -, maybePeriodDataToDateSpans -, dateSpansToPeriodData - , tests_PeriodData ) where @@ -38,7 +34,6 @@ import Data.List (foldl') import Data.Time (Day(..), fromGregorian) import Hledger.Data.Amount -import Hledger.Data.Dates import Hledger.Data.Types import Hledger.Utils @@ -127,31 +122,6 @@ padPeriodData :: a -> PeriodData b -> PeriodData a -> PeriodData a padPeriodData x pad bal = bal{pdperiods = pdperiods bal <> (x <$ pdperiods pad)} --- | Convert 'PeriodData Day' to a list of 'DateSpan's. -periodDataToDateSpans :: PeriodData Day -> [DateSpan] -periodDataToDateSpans = map (\(s, e) -> DateSpan (toEFDay s) (toEFDay e)) . snd . periodDataToList - where toEFDay = Just . Exact - --- Convert a periodic report 'Maybe (PeriodData Day)' to a list of 'DateSpans', --- replacing the empty case with an appropriate placeholder. -maybePeriodDataToDateSpans :: Maybe (PeriodData Day) -> [DateSpan] -maybePeriodDataToDateSpans = maybe [DateSpan Nothing Nothing] periodDataToDateSpans - --- | Convert a list of 'DateSpan's to a 'PeriodData Day', or 'Nothing' if it is not well-formed. --- PARTIAL: -dateSpansToPeriodData :: [DateSpan] -> Maybe (PeriodData Day) --- Handle the cases of partitions which would arise from journals with no transactions -dateSpansToPeriodData [] = Nothing -dateSpansToPeriodData [DateSpan Nothing Nothing] = Nothing -dateSpansToPeriodData [DateSpan Nothing (Just _)] = Nothing -dateSpansToPeriodData [DateSpan (Just _) Nothing] = Nothing --- Handle properly defined reports -dateSpansToPeriodData (x:xs) = Just $ periodDataFromList (fst $ boundaries x) (map boundaries (x:xs)) - where - boundaries spn = makeJust (spanStart spn, spanEnd spn) - makeJust (Just a, Just b) = (a, b) - makeJust ab = error' $ "dateSpansToPeriodData: expected all spans to have start and end dates, but one has " ++ show ab - intToDay = ModifiedJulianDay . toInteger dayToInt = fromInteger . toModifiedJulianDay @@ -163,12 +133,12 @@ tests_PeriodData = dayMap2 = periodDataFromList (mixed [usd 2]) [(fromGregorian 2000 01 01, mixed [usd 4]), (fromGregorian 2004 02 28, mixed [usd 6])] in testGroup "PeriodData" [ - testCase "periodDataFromList" $ do - length dayMap @?= 3, + testCase "periodDataFromList" $ do + length dayMap @?= 3, - testCase "Semigroup instance" $ do - dayMap <> dayMap @?= dayMap2, + testCase "Semigroup instance" $ do + dayMap <> dayMap @?= dayMap2, - testCase "Monoid instance" $ do - dayMap <> mempty @?= dayMap - ] + testCase "Monoid instance" $ do + dayMap <> mempty @?= dayMap + ] diff --git a/hledger-lib/Hledger/Data/PeriodicTransaction.hs b/hledger-lib/Hledger/Data/PeriodicTransaction.hs index 8b16f85678a..042e344c0d3 100644 --- a/hledger-lib/Hledger/Data/PeriodicTransaction.hs +++ b/hledger-lib/Hledger/Data/PeriodicTransaction.hs @@ -19,6 +19,7 @@ import Text.Printf import Hledger.Data.Types import Hledger.Data.Dates +import Hledger.Data.DayPartition import Hledger.Data.Amount import Hledger.Data.Posting (post, generatedTransactionTagName) import Hledger.Data.Transaction @@ -198,7 +199,7 @@ instance Show PeriodicTransaction where runPeriodicTransaction :: Bool -> PeriodicTransaction -> DateSpan -> [Transaction] 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 t = nulltransaction{ tsourcepos = ptsourcepos diff --git a/hledger-lib/Hledger/Data/Types.hs b/hledger-lib/Hledger/Data/Types.hs index aaf8375b468..4d2e3627d5f 100644 --- a/hledger-lib/Hledger/Data/Types.hs +++ b/hledger-lib/Hledger/Data/Types.hs @@ -750,13 +750,16 @@ data Account a = Account { ,adata :: PeriodData a -- ^ associated data per report period } deriving (Generic, Functor) --- | Data values for zero or more report periods, and for the pre-report period. --- Report periods are assumed to be contiguous, and represented only by start dates --- (as keys of an IntMap). XXX how does that work, again ? +-- | A general container for storing data values associated to zero or more +-- report periods, and for the pre-report period. Report periods are assumed to +-- be contiguous, and represented only by start dates. +-- +-- Data is stored in an 'IntMap' for efficiency, where Days are stored as as +-- Int representing the underlying modified Julian date. data PeriodData a = PeriodData { pdpre :: a -- ^ data from the pre-report period (e.g. historical balances) ,pdperiods :: IM.IntMap a -- ^ data for the periods - } deriving (Eq, Functor, Generic) + } deriving (Eq, Ord, Functor, Generic) -- | Data that's useful in "balance" reports: -- subaccount-exclusive and -inclusive amounts, diff --git a/hledger-lib/Hledger/Reports/BudgetReport.hs b/hledger-lib/Hledger/Reports/BudgetReport.hs index 9a44311d6d6..229343dbcfe 100644 --- a/hledger-lib/Hledger/Reports/BudgetReport.hs +++ b/hledger-lib/Hledger/Reports/BudgetReport.hs @@ -24,7 +24,6 @@ import Data.Ord (comparing) import Data.Set qualified as S import Data.Text qualified as T import Data.These (These(..), these) -import Data.Time (Day) import Safe (minimumDef) import Hledger.Data @@ -84,12 +83,13 @@ budgetReport rspec bopts reportspan j = dbg4 "sortedbudgetreport" budgetreport (_, actualspans) = dbg5 "actualspans" $ reportSpan actualj rspec (_, budgetspans) = dbg5 "budgetspans" $ reportSpan budgetj rspec - allspans = case interval_ ropts of + allspans = dbg5 "allspans" $ case (interval_ ropts, budgetspans) of -- If no interval is specified: -- budgetgoalreport's span might be shorter actualreport's due to periodic txns; -- it should be safe to replace it with the latter, so they combine well. - NoInterval -> actualspans - _ -> maybe id (padPeriodData nulldate) budgetspans <$> actualspans + (NoInterval, _) -> actualspans + (_, Nothing) -> actualspans + (_, Just bspan) -> unionDayPartitions bspan =<< actualspans actualps = dbg5 "actualps" $ getPostings rspec actualj priceoracle reportspan budgetps = dbg5 "budgetps" $ getPostings rspec budgetj priceoracle reportspan @@ -107,7 +107,7 @@ budgetReport rspec bopts reportspan j = dbg4 "sortedbudgetreport" budgetreport -- | Lay out a set of postings grouped by date span into a regular matrix with rows -- given by AccountName and columns by DateSpan, then generate a MultiBalanceReport -- from the columns. -generateBudgetReport :: ReportOpts -> Maybe (PeriodData Day) -> Account (These BalanceData BalanceData) -> BudgetReport +generateBudgetReport :: ReportOpts -> Maybe DayPartition -> Account (These BalanceData BalanceData) -> BudgetReport generateBudgetReport = generatePeriodicReport makeBudgetReportRow treeActualBalance flatActualBalance where treeActualBalance = these bdincludingsubs (const nullmixedamt) (const . bdincludingsubs) diff --git a/hledger-lib/Hledger/Reports/MultiBalanceReport.hs b/hledger-lib/Hledger/Reports/MultiBalanceReport.hs index 0f403ecaca3..dd62c04d426 100644 --- a/hledger-lib/Hledger/Reports/MultiBalanceReport.hs +++ b/hledger-lib/Hledger/Reports/MultiBalanceReport.hs @@ -47,7 +47,7 @@ import Data.Maybe (fromMaybe, isJust) import Data.Ord (Down(..)) import Data.Semigroup (sconcat) import Data.These (these) -import Data.Time.Calendar (Day(..), addDays, fromGregorian) +import Data.Time.Calendar (Day(..), fromGregorian) import Data.Traversable (mapAccumL) import Hledger.Data @@ -162,7 +162,7 @@ compoundBalanceReportWith rspec' j priceoracle subreportspecs = cbr subreportTotal (_, sr, increasestotal) = (if increasestotal then id else fmap maNegate) $ prTotals sr - cbr = CompoundPeriodicReport "" (maybePeriodDataToDateSpans colspans) subreports overalltotals + cbr = CompoundPeriodicReport "" (maybeDayPartitionToDateSpans colspans) subreports overalltotals -- | Remove any date queries and insert queries from the report span. @@ -216,7 +216,7 @@ getPostings rspec@ReportSpec{_rsQuery=query, _rsReportOpts=ropts} j priceoracle -- | Generate the 'Account' for the requested multi-balance report from a list -- of 'Posting's. -generateMultiBalanceAccount :: ReportSpec -> Journal -> PriceOracle -> Maybe (PeriodData Day) -> [Posting] -> Account BalanceData +generateMultiBalanceAccount :: ReportSpec -> Journal -> PriceOracle -> Maybe DayPartition -> [Posting] -> Account BalanceData generateMultiBalanceAccount rspec@ReportSpec{_rsReportOpts=ropts} j priceoracle colspans = -- Add declared accounts if called with --declared and --empty (if (declared_ ropts && empty_ ropts) then addDeclaredAccounts rspec j else id) @@ -262,7 +262,7 @@ addDeclaredAccounts rspec j acct = -- | Gather the account balance changes into a regular matrix, then -- accumulate and value amounts, as specified by the report options. -- Makes sure all report columns have an entry. -calculateReportAccount :: ReportSpec -> Journal -> PriceOracle -> Maybe (PeriodData Day) -> [Posting] -> Account BalanceData +calculateReportAccount :: ReportSpec -> Journal -> PriceOracle -> Maybe DayPartition -> [Posting] -> Account BalanceData calculateReportAccount _ _ _ Nothing _ = accountFromBalances "root" $ periodDataFromList mempty [(nulldate, mempty)] calculateReportAccount rspec@ReportSpec{_rsReportOpts=ropts} j priceoracle (Just colspans) ps = @@ -292,18 +292,17 @@ calculateReportAccount rspec@ReportSpec{_rsReportOpts=ropts} j priceoracle (Just avalue = periodDataValuation ropts j priceoracle colspans changesAcct = dbg5With (\x -> "calculateReportAccount changesAcct\n" ++ showAccounts x) . - mapPeriodData (padPeriodData mempty colspans) $ + mapPeriodData (padPeriodData mempty (dayPartitionToPeriodData colspans)) $ accountFromPostings getIntervalStartDate ps - getIntervalStartDate p = fst <$> lookupPeriodData (getPostingDate p) colspans + getIntervalStartDate p = fst $ lookupDayPartition (getPostingDate p) colspans getPostingDate = postingDateOrDate2 (whichDate (_rsReportOpts rspec)) -- | The valuation function to use for the chosen report options. --- This can call error in various situations. -periodDataValuation :: ReportOpts -> Journal -> PriceOracle -> PeriodData Day +periodDataValuation :: ReportOpts -> Journal -> PriceOracle -> DayPartition -> PeriodData BalanceData -> PeriodData BalanceData -periodDataValuation ropts j priceoracle periodEnds = - opPeriodData valueBalanceData balanceDataPeriodEnds +periodDataValuation ropts j priceoracle colspans = + opPeriodData valueBalanceData (dayPartitionToPeriodData colspans) where valueBalanceData :: Day -> BalanceData -> BalanceData valueBalanceData d = mapBalanceData (valueMixedAmount d) @@ -311,10 +310,6 @@ periodDataValuation ropts j priceoracle periodEnds = valueMixedAmount :: Day -> MixedAmount -> MixedAmount valueMixedAmount = mixedAmountApplyValuationAfterSumFromOptsWith ropts j priceoracle - -- The end date of a period is one before the beginning of the next period - balanceDataPeriodEnds :: PeriodData Day - balanceDataPeriodEnds = dbg5 "balanceDataPeriodEnds" $ addDays (-1) <$> periodEnds - -- | Mark which nodes of an 'Account' are boring, and so should be omitted from reports. markAccountBoring :: ReportSpec -> Account BalanceData -> Account BalanceData markAccountBoring ReportSpec{_rsQuery=query,_rsReportOpts=ropts} @@ -367,7 +362,7 @@ markAccountBoring ReportSpec{_rsQuery=query,_rsReportOpts=ropts} -- | Build a report row. -- -- Calculate the column totals. These are always the sum of column amounts. -generateMultiBalanceReport :: ReportOpts -> Maybe (PeriodData Day) -> Account BalanceData -> MultiBalanceReport +generateMultiBalanceReport :: ReportOpts -> Maybe DayPartition -> Account BalanceData -> MultiBalanceReport generateMultiBalanceReport ropts colspans = reportPercent ropts . generatePeriodicReport makeMultiBalanceReportRow bdincludingsubs id ropts colspans @@ -377,9 +372,9 @@ generateMultiBalanceReport ropts colspans = generatePeriodicReport :: Show c => (forall a. ReportOpts -> (BalanceData -> MixedAmount) -> a -> Account b -> PeriodicReportRow a c) -> (b -> MixedAmount) -> (c -> MixedAmount) - -> ReportOpts -> Maybe (PeriodData Day) -> Account b -> PeriodicReport DisplayName c + -> ReportOpts -> Maybe DayPartition -> Account b -> PeriodicReport DisplayName c generatePeriodicReport makeRow treeAmt flatAmt ropts colspans acct = - PeriodicReport (maybePeriodDataToDateSpans colspans) (buildAndSort acct) totalsrow + PeriodicReport (maybeDayPartitionToDateSpans colspans) (buildAndSort acct) totalsrow where -- Build report rows and sort them buildAndSort = dbg5 "generatePeriodicReport buildAndSort" . case accountlistmode_ ropts of diff --git a/hledger-lib/Hledger/Reports/PostingsReport.hs b/hledger-lib/Hledger/Reports/PostingsReport.hs index d43de059852..129a9c1fbaa 100644 --- a/hledger-lib/Hledger/Reports/PostingsReport.hs +++ b/hledger-lib/Hledger/Reports/PostingsReport.hs @@ -209,12 +209,12 @@ mkpostingsReportItem showdate showdesc wd mperiod p b = -- | Convert a list of postings into summary postings, one per interval, -- aggregated to the specified depth if any. -- Each summary posting will have a non-Nothing interval end date. -summarisePostingsByInterval :: WhichDate -> Maybe Int -> Bool -> Maybe (PeriodData Day) -> [Posting] -> [SummaryPosting] +summarisePostingsByInterval :: WhichDate -> Maybe Int -> Bool -> Maybe DayPartition -> [Posting] -> [SummaryPosting] summarisePostingsByInterval wd mdepth showempty colspans = concatMap (\(s,ps) -> summarisePostingsInDateSpan s wd mdepth showempty ps) -- Group postings into their columns. We try to be efficient, since -- there can possibly be a very large number of intervals (cf #1683) - . groupByDateSpan showempty (postingDateOrDate2 wd) (maybePeriodDataToDateSpans colspans) + . groupByDateSpan showempty (postingDateOrDate2 wd) (maybeDayPartitionToDateSpans colspans) -- | Given a date span (representing a report interval) and a list of -- postings within it, aggregate the postings into one summary posting per diff --git a/hledger-lib/Hledger/Reports/ReportOptions.hs b/hledger-lib/Hledger/Reports/ReportOptions.hs index 0391000b737..5040f129616 100644 --- a/hledger-lib/Hledger/Reports/ReportOptions.hs +++ b/hledger-lib/Hledger/Reports/ReportOptions.hs @@ -71,7 +71,7 @@ where import Prelude hiding (Applicative(..)) import Control.Applicative (Applicative(..), Const(..), (<|>)) -import Control.Monad ((<=<), guard, join) +import Control.Monad (guard, join) import Data.Char (toLower) import Data.Either (fromRight) import Data.Either.Extra (eitherToMaybe) @@ -82,7 +82,7 @@ import Data.Maybe (fromMaybe, isJust, isNothing) import Data.Text qualified as T import Data.Time.Calendar (Day, addDays) import Data.Default (Default(..)) -import Safe (headMay, lastDef, lastMay, maximumMay, readMay) +import Safe (lastDef, lastMay, maximumMay, readMay) import Hledger.Data 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 -- (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. - postingperiodend = addDays (-1) . fromMaybe err . mPeriodEnd . postingDateOrDate2 (whichDate ropts) + postingperiodend = postingPeriodEnd . postingDateOrDate2 (whichDate ropts) where - mPeriodEnd = case interval_ ropts of - NoInterval -> const . spanEnd . fst $ reportSpan j rspec - _ -> spanEnd <=< latestSpanContaining (historical : spans) + postingPeriodEnd d = fromMaybe err $ case interval_ ropts of + NoInterval -> fmap (snd . dayPartitionSpans) . snd $ reportSpan j rspec + _ -> 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 = maybePeriodDataToDateSpans . snd $ reportSpanBothDates j rspec 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 -- amounts. Used in MultiBalanceReport to value historical and similar reports. @@ -778,18 +779,18 @@ sortKeysDescription = "date, desc, account, amount, absamount" -- 'description' -- (or non-future market price date, when doing an end value report) is used. -- If none of these things are present, the null date span is returned. -- The report sub-periods caused by a report interval, if any, are also returned. -reportSpan :: Journal -> ReportSpec -> (DateSpan, Maybe (PeriodData Day)) +reportSpan :: Journal -> ReportSpec -> (DateSpan, Maybe DayPartition) reportSpan = reportSpanHelper False -- Note: In end value reports, the report end date and valuation date are the same. -- If valuation date ever needs to be different, journalApplyValuationFromOptsWith is the place. -- | Like reportSpan, but considers both primary and secondary dates, not just one or the other. -reportSpanBothDates :: Journal -> ReportSpec -> (DateSpan, Maybe (PeriodData Day)) +reportSpanBothDates :: Journal -> ReportSpec -> (DateSpan, Maybe DayPartition) reportSpanBothDates = reportSpanHelper True -reportSpanHelper :: Bool -> Journal -> ReportSpec -> (DateSpan, Maybe (PeriodData Day)) +reportSpanHelper :: Bool -> Journal -> ReportSpec -> (DateSpan, Maybe DayPartition) reportSpanHelper bothdates j ReportSpec{_rsQuery=query, _rsReportOpts=ropts, _rsDay=today} = - (enlargedreportspan, dateSpansToPeriodData $ if not (null intervalspans) then intervalspans else [enlargedreportspan]) + (enlargedreportspan, intervalspans) where -- The date span specified by -b/-e/-p options and query args if any. 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. -- This can be the null span if there were no intervals. enlargedreportspan = dbg3 "enlargedreportspan" $ - DateSpan (fmap Exact . spanStart =<< headMay intervalspans) - (fmap Exact . spanEnd =<< lastMay intervalspans) + maybe (DateSpan Nothing Nothing) (mkSpan . dayPartitionSpans) intervalspans + where mkSpan (s, e) = DateSpan (Just $ Exact s) (Just . Exact $ addDays 1 e) reportStartDate :: Journal -> ReportSpec -> Maybe Day reportStartDate j = spanStart . fst . reportSpan j diff --git a/hledger-lib/Hledger/Utils.hs b/hledger-lib/Hledger/Utils.hs index 00fa81a2378..002bf49c2b1 100644 --- a/hledger-lib/Hledger/Utils.hs +++ b/hledger-lib/Hledger/Utils.hs @@ -25,6 +25,8 @@ module Hledger.Utils ( splitAtElement, sumStrict, all1, + takeUntilFails, + takeUntilFailsNE, -- * Trees treeLeaves, @@ -73,6 +75,7 @@ where import Data.Char (toLower) import Data.List (intersperse) import Data.List.Extra (chunksOf, foldl1', uncons, unsnoc) +import qualified Data.List.NonEmpty as NE #if !MIN_VERSION_base(4,20,0) import Data.List (foldl') #endif @@ -181,6 +184,16 @@ all1 :: (a -> Bool) -> [a] -> Bool all1 _ [] = False 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 -- | Get the leaves of this tree as a list. diff --git a/hledger-lib/hledger-lib.cabal b/hledger-lib/hledger-lib.cabal index 0102b88b62e..bd22bbfde5a 100644 --- a/hledger-lib/hledger-lib.cabal +++ b/hledger-lib/hledger-lib.cabal @@ -61,6 +61,7 @@ library Hledger.Data.Balancing Hledger.Data.Currency Hledger.Data.Dates + Hledger.Data.DayPartition Hledger.Data.Errors Hledger.Data.Journal Hledger.Data.JournalChecks diff --git a/hledger/Hledger/Cli/Commands/Activity.hs b/hledger/Hledger/Cli/Commands/Activity.hs index fb64be373ed..a19bd3ac9b9 100644 --- a/hledger/Hledger/Cli/Commands/Activity.hs +++ b/hledger/Hledger/Cli/Commands/Activity.hs @@ -39,8 +39,8 @@ showHistogram rspec@ReportSpec{_rsQuery=q} j = _ -> rspec spanps = case mspans of Nothing -> [] - Just x -> map (\spn -> (spn, filter (postingInRange spn) ps)) . snd $ periodDataToList x - postingInRange (b, e) p = postingDate p >= b && postingDate p < e + Just x -> map (\spn -> (spn, filter (postingInRange spn) ps)) $ dayPartitionToList x + postingInRange (b, e) p = postingDate p >= b && postingDate p <= e -- same as Register -- should count transactions, not postings ? -- ps = sortBy (comparing postingDate) $ filterempties $ filter matchapats $ filterdepth $ journalPostings j diff --git a/hledger/Hledger/Cli/Commands/Roi.hs b/hledger/Hledger/Cli/Commands/Roi.hs index a1d2ff8e192..3c97d523063 100644 --- a/hledger/Hledger/Cli/Commands/Roi.hs +++ b/hledger/Hledger/Cli/Commands/Roi.hs @@ -97,7 +97,7 @@ roi CliOpts{rawopts_=rawopts, reportspec_=rspec@ReportSpec{_rsReportOpts=ReportO let (fullPeriodDateSpan, mspans) = reportSpan filteredj rspec let err = error' "Undefined start or end of the period - will be unable to compute the rates of return" - spans = maybe err (snd . periodDataToList) mspans + spans = maybe err (map (second (addDays 1)) . dayPartitionToList) mspans fullPeriod = case fullPeriodDateSpan of DateSpan (Just b) (Just e) -> (fromEFDay b, fromEFDay e) _ -> err diff --git a/hledger/Hledger/Cli/Commands/Stats.hs b/hledger/Hledger/Cli/Commands/Stats.hs index 2798865d0e4..d834df7fdaf 100644 --- a/hledger/Hledger/Cli/Commands/Stats.hs +++ b/hledger/Hledger/Cli/Commands/Stats.hs @@ -57,7 +57,7 @@ stats opts@CliOpts{rawopts_=rawopts, reportspec_=rspec, progstarttime_} j = do l = ledgerFromJournal q j intervalspans = snd $ reportSpanBothDates j rspec ismultiperiod = length intervalspans > 1 - (ls, txncounts) = unzip . map (showLedgerStats verbose l today) $ maybePeriodDataToDateSpans intervalspans + (ls, txncounts) = unzip . map (showLedgerStats verbose l today) $ maybeDayPartitionToDateSpans intervalspans numtxns = sum txncounts txt = (if ismultiperiod then id else TL.init) $ TB.toLazyText $ unlinesB ls writeOutputLazyText opts txt