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

Adjust start date of DateSpan for periodic forecasting with Days interval.

Browse Source
This commit is contained in:
Stephen Morgan 2018-05-07 16:59:30 +10:00 committed by Simon Michael
parent e1d9b0cfba
commit 129f6e6839
2 changed files with 26 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
hledger-lib/Hledger/Data/AutoTransaction.hs
View File

@ -233,11 +233,9 @@ renderPostingCommentDates p = p { pcomment = comment' }
-- --
-- >>> let reportperiod="daily from 2018/01/03" in runPeriodicTransaction (PeriodicTransaction reportperiod [post "a" (usd 1)]) (DateSpan (Just $ parsedate "2018-01-01") (Just $ parsedate "2018-01-03")) -- >>> let reportperiod="daily from 2018/01/03" in runPeriodicTransaction (PeriodicTransaction reportperiod [post "a" (usd 1)]) (DateSpan (Just $ parsedate "2018-01-01") (Just $ parsedate "2018-01-03"))
-- [] -- []
runPeriodicTransaction :: PeriodicTransaction -> (DateSpan -> [Transaction]) runPeriodicTransaction :: PeriodicTransaction -> DateSpan -> [Transaction]
runPeriodicTransaction pt = runPeriodicTransaction pt requestedspan =
\requestedspan -> [ t{tdate=d} | (DateSpan (Just d) _) <- ptinterval `splitSpan` fillspan ]
let fillspan = ptspan `spanIntersect` requestedspan
in [ t{tdate=d} | (DateSpan (Just d) _) <- ptinterval `splitSpan` fillspan ]
where where
descr = T.pack $ "Forecast transaction (" ++ T.unpack periodexpr ++ ")" descr = T.pack $ "Forecast transaction (" ++ T.unpack periodexpr ++ ")"
t = nulltransaction { tpostings = ptpostings pt, tdescription = descr } t = nulltransaction { tpostings = ptpostings pt, tdescription = descr }
@ -247,6 +245,7 @@ runPeriodicTransaction pt =
case parsePeriodExpr currentdateerr periodexpr of case parsePeriodExpr currentdateerr periodexpr of
Left e -> error' $ "Failed to parse " ++ show (T.unpack periodexpr) ++ ": " ++ showDateParseError e Left e -> error' $ "Failed to parse " ++ show (T.unpack periodexpr) ++ ": " ++ showDateParseError e
Right x -> checkPeriodTransactionStartDate periodexpr x Right x -> checkPeriodTransactionStartDate periodexpr x
fillspan = spanIntervalIntersect ptinterval ptspan requestedspan
checkPeriodTransactionStartDate :: T.Text -> (Interval, DateSpan) -> (Interval, DateSpan) checkPeriodTransactionStartDate :: T.Text -> (Interval, DateSpan) -> (Interval, DateSpan)
checkPeriodTransactionStartDate periodexpr (i,s) = checkPeriodTransactionStartDate periodexpr (i,s) =

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

@ -55,6 +55,7 @@ module Hledger.Data.Dates (
spansSpan, spansSpan,
spanIntersect, spanIntersect,
spansIntersect, spansIntersect,
spanIntervalIntersect,
spanDefaultsFrom, spanDefaultsFrom,
spanUnion, spanUnion,
spansUnion, spansUnion,
@ -260,6 +261,27 @@ spanIntersect (DateSpan b1 e1) (DateSpan b2 e2) = DateSpan b e
b = latest b1 b2 b = latest b1 b2
e = earliest e1 e2 e = earliest e1 e2
-- | Calculate the intersection of two DateSpans, adjusting the start date so
-- the interval is preserved.
--
-- >>> let intervalIntersect = spanIntervalIntersect (Days 3)
-- >>> mkdatespan "2018-01-01" "2018-01-03" `intervalIntersect` mkdatespan "2018-01-01" "2018-01-05"
-- DateSpan 2018/01/01-2018/01/02
-- >>> mkdatespan "2018-01-01" "2018-01-05" `intervalIntersect` mkdatespan "2018-01-02" "2018-01-05"
-- DateSpan 2018/01/04
-- >>> mkdatespan "2018-01-01" "2018-01-05" `intervalIntersect` mkdatespan "2018-01-03" "2018-01-05"
-- DateSpan 2018/01/04
-- >>> mkdatespan "2018-01-01" "2018-01-05" `intervalIntersect` mkdatespan "2018-01-04" "2018-01-05"
-- DateSpan 2018/01/04
-- >>> mkdatespan "2018-01-01" "2018-01-05" `intervalIntersect` mkdatespan "2017-12-01" "2018-01-05"
-- DateSpan 2018/01/01-2018/01/04
spanIntervalIntersect :: Interval -> DateSpan -> DateSpan -> DateSpan
spanIntervalIntersect (Days n) (DateSpan (Just b1) e1) sp2@(DateSpan (Just b2) _) =
DateSpan (Just b) e1 `spanIntersect` sp2
where
b = if b1 < b2 then addDays (diffDays b1 b2 `mod` toInteger n) b2 else b1
spanIntervalIntersect _ sp1 sp2 = sp1 `spanIntersect` sp2
-- | Fill any unspecified dates in the first span with the dates from -- | Fill any unspecified dates in the first span with the dates from
-- the second one. Sort of a one-way spanIntersect. -- the second one. Sort of a one-way spanIntersect.
spanDefaultsFrom (DateSpan a1 b1) (DateSpan a2 b2) = DateSpan a b spanDefaultsFrom (DateSpan a1 b1) (DateSpan a2 b2) = DateSpan a b