dev!: lib: Refactor splitSpan to return Maybe DayPartition.
This eliminates all error calls from the chain calculating report periods.
This commit is contained in:
Stephen Morgan
Simon Michael
parent
b9caa4d948
commit
4e9fa1615c
@ -66,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
|
||||
|
||||
@ -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]
|
||||
|
||||
]
|
||||
|
||||
@ -11,16 +11,21 @@ module Hledger.Data.DayPartition
|
||||
|
||||
, dayPartitionToNonEmpty
|
||||
, dayPartitionToList
|
||||
, dayPartitionToPeriodData
|
||||
, dayPartitionSpans
|
||||
, dayPartitionToDateSpans
|
||||
, dayPartitionToPeriodData
|
||||
, maybeDayPartitionToDateSpans
|
||||
, dateSpansToDayPartition
|
||||
|
||||
, 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)
|
||||
import Data.Time (Day(..), addDays, addGregorianMonthsClip, addGregorianYearsClip, fromGregorian)
|
||||
|
||||
import Hledger.Data.Dates
|
||||
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.
|
||||
boundariesToDayPartition :: NonEmpty Day -> DayPartition
|
||||
boundariesToDayPartition xs =
|
||||
DayPartition $ periodDataFromList (addDays (-1) b) $ zip (b:bs) (map (addDays (-1)) bs)
|
||||
where (b:|bs) = NE.nub $ NE.sort xs
|
||||
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.
|
||||
@ -93,6 +99,12 @@ dayPartitionToNonEmpty (DayPartition xs) = NE.fromList . snd $ periodDataToList
|
||||
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
|
||||
@ -111,21 +123,153 @@ dayPartitionToDateSpans = map toDateSpan . dayPartitionToList
|
||||
maybeDayPartitionToDateSpans :: Maybe DayPartition -> [DateSpan]
|
||||
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.
|
||||
-- It will be eliminated later.
|
||||
-- PARTIAL:
|
||||
dateSpansToDayPartition :: [DateSpan] -> Maybe DayPartition
|
||||
-- Handle the cases of partitions which would arise from journals with no transactions
|
||||
dateSpansToDayPartition [] = Nothing
|
||||
dateSpansToDayPartition [DateSpan Nothing Nothing] = Nothing
|
||||
dateSpansToDayPartition [DateSpan Nothing (Just _)] = Nothing
|
||||
dateSpansToDayPartition [DateSpan (Just _) Nothing] = Nothing
|
||||
-- Handle properly defined reports
|
||||
dateSpansToDayPartition (x:xs) = Just . DayPartition $
|
||||
periodDataFromList (addDays (-1) . fst $ boundaries x) (map boundaries (x:xs))
|
||||
-- ==== 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
|
||||
boundaries spn = makeJust (spanStart spn, addDays (-1) <$> spanEnd spn)
|
||||
makeJust (Just a, Just b) = (a, b)
|
||||
makeJust ab = error' $ "dateSpansToDayPartition: expected all spans to have start and end dates, but one has " ++ show ab
|
||||
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 (<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]
|
||||
|
||||
]
|
||||
|
||||
@ -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])]
|
||||
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
|
||||
]
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 = maybeDayPartitionToDateSpans . 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.
|
||||
@ -789,7 +790,7 @@ reportSpanBothDates = reportSpanHelper True
|
||||
|
||||
reportSpanHelper :: Bool -> Journal -> ReportSpec -> (DateSpan, Maybe DayPartition)
|
||||
reportSpanHelper bothdates j ReportSpec{_rsQuery=query, _rsReportOpts=ropts, _rsDay=today} =
|
||||
(enlargedreportspan, dateSpansToDayPartition $ 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
|
||||
|
||||
@ -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.
|
||||
|
||||
Loading…
Reference in New Issue
Block a user