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

ref: Clean up splitSpan, to make the logic clearer and more extensible.

Browse Source 
Previously the helper functions splitspan and splitspan' would calculate
each span from the start point of the previous span. This meant we had
to be very careful not to lose any relevant information (e.g. what day
of the week it was) about the original start date. We now calculate each
span from the original start date, so there's no risk of losing
information. This simplifies many of the calculations.
This commit is contained in:
Stephen Morgan 2022-01-04 15:38:21 +01:00 committed by Simon Michael
parent ea51a87bd0
commit e33de3585b
1 changed files with 39 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -67,6 +67,7 @@ module Hledger.Data.Dates (
latestSpanContaining, latestSpanContaining,
smartdate, smartdate,
splitSpan, splitSpan,
spansFromBoundaries,
groupByDateSpan, groupByDateSpan,
fixSmartDate, fixSmartDate,
fixSmartDateStr, fixSmartDateStr,
@ -207,51 +208,47 @@ spansSpan spans = DateSpan (spanStart =<< headMay spans) (spanEnd =<< lastMay sp
-- --
splitSpan :: Interval -> DateSpan -> [DateSpan] splitSpan :: Interval -> DateSpan -> [DateSpan]
splitSpan _ (DateSpan Nothing Nothing) = [DateSpan Nothing Nothing] splitSpan _ (DateSpan Nothing Nothing) = [DateSpan Nothing Nothing]
splitSpan _ s | isEmptySpan s = [] splitSpan _ ds | isEmptySpan ds = []
splitSpan NoInterval s = [s] splitSpan _ ds@(DateSpan (Just s) (Just e)) | s == e = [ds]
splitSpan (Days n) s = splitspan startofday (applyN n nextday) s splitSpan NoInterval ds = [ds]
splitSpan (Weeks n) s = splitspan startofweek (applyN n nextweek) s splitSpan (Days n) ds = splitspan startofday addDays n ds
splitSpan (Months n) s = splitspan startofmonth (applyN n nextmonth) s splitSpan (Weeks n) ds = splitspan startofweek addDays (7*n) ds
splitSpan (Quarters n) s = splitspan startofquarter (applyN n nextquarter) s splitSpan (Months n) ds = splitspan startofmonth addGregorianMonthsClip n ds
splitSpan (Years n) s = splitspan startofyear (applyN n nextyear) s splitSpan (Quarters n) ds = splitspan startofquarter addGregorianMonthsClip (3*n) ds
splitSpan (DayOfMonth n) s = splitspan (nthdayofmonthcontaining n) (nthdayofmonth n . nextmonth) s splitSpan (Years n) ds = splitspan startofyear addGregorianYearsClip n ds
splitSpan (WeekdayOfMonth n wd) s = splitspan (nthweekdayofmonthcontaining n wd) (advancetonthweekday n wd . nextmonth) s splitSpan (DayOfMonth n) ds = splitspan (nthdayofmonthcontaining n) addGregorianMonthsClip 1 ds
splitSpan (DaysOfWeek []) s = [s] -- shouldn't happen in parser but for completeness splitSpan (DayOfYear m n) ds = splitspan (nthdayofyearcontaining m n) addGregorianYearsClip 1 ds
splitSpan (DaysOfWeek days@(n:_)) ds splitSpan (WeekdayOfMonth n wd) ds = splitspan (nthweekdayofmonthcontaining n wd) advancemonths 1 ds
| DateSpan Nothing (Just e) <- ds = split (DateSpan (Just $ start e) (Just $ nextday $ start e))
| DateSpan (Just s) Nothing <- ds = split (DateSpan (Just $ start s) (Just $ nextday $ start s))
| DateSpan (Just s) (Just e) <- ds =
if s == e then [ds] else split (DateSpan (Just $ start s) (Just e))
where where
start = nthdayofweekcontaining n advancemonths 0 = id
advancemonths w = advancetonthweekday n wd . startofmonth . addGregorianMonthsClip w
wheel = (\x -> zipWith (-) (tail x) x) . concat . zipWith fmap (fmap (+) [0,7..]) . repeat $ days splitSpan (DaysOfWeek []) ds = [ds]
splitSpan (DaysOfWeek days@(n:_)) ds = spansFromBoundaries e bdrys
split = splitspan' (repeat startofday) (fmap (`applyN` nextday) wheel) where
(s, e) = dateSpanSplitLimits (nthdayofweekcontaining n) nextday ds
splitSpan (DayOfYear m n) s = splitspan (nthdayofyearcontaining m n) (applyN (n-1) nextday . applyN (m-1) nextmonth . nextyear) s bdrys = concatMap (flip map starts . addDays) [0,7..]
-- splitSpan (WeekOfYear n) s = splitspan startofweek (applyN n nextweek) s -- The first representative of each weekday
-- splitSpan (MonthOfYear n) s = splitspan startofmonth (applyN n nextmonth) s starts = map (\d -> addDays (toInteger $ d - n) $ nthdayofweekcontaining n s) days
-- splitSpan (QuarterOfYear n) s = splitspan startofquarter (applyN n nextquarter) s
-- Split the given span using the provided helper functions: -- Split the given span using the provided helper functions:
-- start is applied to the span's start date to get the first sub-span's start date -- start is applied to the span's start date to get the first sub-span's start date
-- next is applied to a sub-span's start date to get the next sub-span's start date -- addInterval is applied to an integer n (multiplying it by mult) and the span's start date to get the nth sub-span's start date
splitspan :: (Day -> Day) -> (Day -> Day) -> DateSpan -> [DateSpan] splitspan :: (Day -> Day) -> (Integer -> Day -> Day) -> Int -> DateSpan -> [DateSpan]
splitspan _ _ (DateSpan Nothing Nothing) = [] splitspan start addInterval mult ds = spansFromBoundaries e bdrys
splitspan start next (DateSpan Nothing (Just e)) = splitspan start next (DateSpan (Just $ start e) (Just $ next $ start e)) where
splitspan start next (DateSpan (Just s) Nothing) = splitspan start next (DateSpan (Just $ start s) (Just $ next $ start s)) (s, e) = dateSpanSplitLimits start (addInterval $ toInteger mult) ds
splitspan start next span@(DateSpan (Just s) (Just e)) bdrys = mapM (addInterval . toInteger) [0,mult..] $ start s
| s == e = [span]
| otherwise = splitspan' (repeat start) (repeat next) span
splitspan' :: [Day -> Day] -> [Day -> Day] -> DateSpan -> [DateSpan] -- | Fill in missing endpoints for calculating 'splitSpan'.
splitspan' (start:ss) (next:ns) (DateSpan (Just s) (Just e)) dateSpanSplitLimits :: (Day -> Day) -> (Day -> Day) -> DateSpan -> (Day, Day)
| s >= e = [] dateSpanSplitLimits start _ (DateSpan (Just s) (Just e)) = (start s, e)
| otherwise = DateSpan (Just subs) (Just sube) : splitspan' ss ns (DateSpan (Just sube) (Just e)) dateSpanSplitLimits start next (DateSpan (Just s) Nothing) = (start s, next $ start s)
where subs = start s dateSpanSplitLimits start next (DateSpan Nothing (Just e)) = (start e, next $ start e)
sube = next subs dateSpanSplitLimits _ _ (DateSpan Nothing Nothing) = error "dateSpanSplitLimits: Should not be nulldatespan" -- PARTIAL: This case should have been handled in splitSpan
splitspan' _ _ _ = error' "won't happen, avoids warnings" -- PARTIAL:
-- | Construct a list of 'DateSpan's from a list of boundaries, which fit within a given range.
spansFromBoundaries :: Day -> [Day] -> [DateSpan]
spansFromBoundaries e bdrys = zipWith (DateSpan `on` Just) (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
@ -1069,8 +1066,8 @@ tests_Dates = testGroup "Dates"
] ]
, testCase "match dayOfWeek" $ do , testCase "match dayOfWeek" $ do
let dayofweek n s = splitspan (nthdayofweekcontaining n) (applyN (n-1) nextday . nextweek) s let dayofweek n s = splitspan (nthdayofweekcontaining n) (\w -> (if w == 0 then id else applyN (n-1) nextday . applyN (fromInteger w) nextweek)) 1 s
match ds day = dayofweek day ds == splitSpan (DaysOfWeek [day]) ds @?= True match ds day = splitSpan (DaysOfWeek [day]) ds @?= dayofweek day ds
ys2021 = fromGregorian 2021 01 01 ys2021 = fromGregorian 2021 01 01
ye2021 = fromGregorian 2021 12 31 ye2021 = fromGregorian 2021 12 31
ys2022 = fromGregorian 2022 01 01 ys2022 = fromGregorian 2022 01 01