fix: forecast: Generate forecast transactions at journal finalisation,
rather than as a postprocessing step. (#1638) This allows us to have a uniform procedure for balancing transactions, whether they are normal transactions or forecast transactions, including dealing with balance assignments, balance assertions, and auto postings.
This commit is contained in:
Stephen Morgan
Simon Michael
parent
c404800fbf
commit
918c243fa9
@ -20,6 +20,7 @@ module Hledger.Query (
|
||||
-- * parsing
|
||||
parseQuery,
|
||||
parseQueryList,
|
||||
parseQueryTerm,
|
||||
simplifyQuery,
|
||||
filterQuery,
|
||||
-- * accessors
|
||||
|
||||
@ -49,6 +49,8 @@ module Hledger.Read.Common (
|
||||
journalCheckAccountsDeclared,
|
||||
journalCheckCommoditiesDeclared,
|
||||
journalCheckPayeesDeclared,
|
||||
journalAddForecast,
|
||||
journalAddAutoPostings,
|
||||
setYear,
|
||||
getYear,
|
||||
setDefaultCommodityAndStyle,
|
||||
@ -135,7 +137,9 @@ import Data.Bifunctor (bimap, second)
|
||||
import Data.Char (digitToInt, isDigit, isSpace)
|
||||
import Data.Decimal (DecimalRaw (Decimal), Decimal)
|
||||
import Data.Default (Default(..))
|
||||
import Data.Either (lefts, rights)
|
||||
import Data.Function ((&))
|
||||
import Data.Functor ((<&>))
|
||||
import Data.Functor.Identity (Identity)
|
||||
import "base-compat-batteries" Data.List.Compat
|
||||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
@ -144,7 +148,7 @@ import qualified Data.Map as M
|
||||
import qualified Data.Semigroup as Sem
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Calendar (Day, fromGregorianValid, toGregorian)
|
||||
import Data.Time.Calendar (Day, addDays, fromGregorianValid, toGregorian)
|
||||
import Data.Time.LocalTime (LocalTime(..), TimeOfDay(..))
|
||||
import Data.Word (Word8)
|
||||
import System.Time (getClockTime)
|
||||
@ -156,6 +160,8 @@ import Text.Megaparsec.Custom
|
||||
finalErrorBundlePretty, parseErrorAt, parseErrorAtRegion)
|
||||
|
||||
import Hledger.Data
|
||||
import Hledger.Query (Query(..), filterQuery, parseQueryTerm, queryEndDate, queryIsDate, simplifyQuery)
|
||||
import Hledger.Reports.ReportOptions (ReportOpts(..), queryFromFlags, rawOptsToReportOpts)
|
||||
import Hledger.Utils
|
||||
import Text.Printf (printf)
|
||||
|
||||
@ -228,6 +234,8 @@ definputopts = InputOpts
|
||||
, strict_ = False
|
||||
}
|
||||
|
||||
-- | Parse an InputOpts from a RawOpts and the current date.
|
||||
-- This will fail with a usage error if the forecast period expression cannot be parsed.
|
||||
rawOptsToInputOpts :: RawOpts -> IO InputOpts
|
||||
rawOptsToInputOpts rawopts = do
|
||||
d <- getCurrentDay
|
||||
@ -250,16 +258,25 @@ rawOptsToInputOpts rawopts = do
|
||||
}
|
||||
where noinferprice = boolopt "strict" rawopts || stringopt "args" rawopts == "balancednoautoconversion"
|
||||
|
||||
-- | get period expression from --forecast option
|
||||
-- | Get period expression from --forecast option.
|
||||
-- This will fail with a usage error if the forecast period expression cannot be parsed.
|
||||
forecastPeriodFromRawOpts :: Day -> RawOpts -> Maybe DateSpan
|
||||
forecastPeriodFromRawOpts d opts =
|
||||
case maybestringopt "forecast" opts
|
||||
of
|
||||
forecastPeriodFromRawOpts d rawopts = case maybestringopt "forecast" rawopts of
|
||||
Nothing -> Nothing
|
||||
Just "" -> Just nulldatespan
|
||||
Just str ->
|
||||
either (\e -> usageError $ "could not parse forecast period : "++customErrorBundlePretty e) (Just . snd) $
|
||||
parsePeriodExpr d $ stripquotes $ T.pack str
|
||||
Just "" -> Just forecastspanDefault
|
||||
Just str -> either (\e -> usageError $ "could not parse forecast period : "++customErrorBundlePretty e)
|
||||
(\(_,requestedspan) -> Just $ requestedspan `spanDefaultsFrom` forecastspanDefault) $
|
||||
parsePeriodExpr d $ stripquotes $ T.pack str
|
||||
where
|
||||
-- "They end on or before the specified report end date, or 180 days from today if unspecified."
|
||||
mspecifiedend = dbg2 "specifieddates" $ queryEndDate False datequery
|
||||
forecastendDefault = dbg2 "forecastendDefault" $ addDays 180 d
|
||||
forecastspanDefault = DateSpan Nothing $ mspecifiedend <|> Just forecastendDefault
|
||||
-- Do we really need to do all this work just to get the requested end date? This is duplicating
|
||||
-- much of reportOptsToSpec.
|
||||
ropts = rawOptsToReportOpts d rawopts
|
||||
argsquery = lefts . rights . map (parseQueryTerm d) $ querystring_ ropts
|
||||
datequery = simplifyQuery . filterQuery queryIsDate . And $ queryFromFlags ropts : argsquery
|
||||
|
||||
--- ** parsing utilities
|
||||
|
||||
@ -338,6 +355,8 @@ parseAndFinaliseJournal' parser iopts f txt = do
|
||||
--
|
||||
-- - save misc info and reverse transactions into their original parse order,
|
||||
--
|
||||
-- - add forecast transactions,
|
||||
--
|
||||
-- - evaluate balance assignments and balance each transaction,
|
||||
--
|
||||
-- - apply transaction modifiers (auto postings) if enabled,
|
||||
@ -347,41 +366,64 @@ parseAndFinaliseJournal' parser iopts f txt = do
|
||||
-- - infer transaction-implied market prices from transaction prices
|
||||
--
|
||||
journalFinalise :: InputOpts -> FilePath -> Text -> ParsedJournal -> ExceptT String IO Journal
|
||||
journalFinalise InputOpts{auto_,balancingopts_,strict_} f txt pj' = do
|
||||
t <- liftIO getClockTime
|
||||
d <- liftIO getCurrentDay
|
||||
liftEither $ do
|
||||
journalFinalise InputOpts{forecast_,auto_,balancingopts_,strict_} f txt pj = do
|
||||
t <- liftIO getClockTime
|
||||
d <- liftIO getCurrentDay
|
||||
-- Infer and apply canonical styles for each commodity (or throw an error).
|
||||
-- This affects transaction balancing/assertions/assignments, so needs to be done early.
|
||||
pj <- journalApplyCommodityStyles $
|
||||
pj'{jglobalcommoditystyles=fromMaybe M.empty $ commodity_styles_ balancingopts_} -- save any global commodity styles
|
||||
& journalAddFile (f, txt) -- save the main file's info
|
||||
& journalSetLastReadTime t -- save the last read time
|
||||
& journalReverse -- convert all lists to the order they were parsed
|
||||
liftEither $ checkAddAndBalance d <=< journalApplyCommodityStyles $
|
||||
pj{jglobalcommoditystyles=fromMaybe mempty $ commodity_styles_ balancingopts_} -- save any global commodity styles
|
||||
& journalAddFile (f, txt) -- save the main file's info
|
||||
& journalSetLastReadTime t -- save the last read time
|
||||
& journalReverse -- convert all lists to the order they were parsed
|
||||
where
|
||||
checkAddAndBalance d j = do
|
||||
when strict_ $ do
|
||||
-- If in strict mode, check all postings are to declared accounts
|
||||
journalCheckAccountsDeclared j
|
||||
-- and using declared commodities
|
||||
journalCheckCommoditiesDeclared j
|
||||
|
||||
when strict_ $ do
|
||||
-- If in strict mode, check all postings are to declared accounts
|
||||
journalCheckAccountsDeclared pj
|
||||
-- and using declared commodities
|
||||
journalCheckCommoditiesDeclared pj
|
||||
|
||||
-- infer market prices from commodity-exchanging transactions
|
||||
journalInferMarketPricesFromTransactions <$>
|
||||
if not auto_ || null (jtxnmodifiers pj)
|
||||
then
|
||||
-- Auto postings are not active.
|
||||
-- Balance all transactions and maybe check balance assertions.
|
||||
journalBalanceTransactions balancingopts_ pj
|
||||
else
|
||||
-- Auto postings are active.
|
||||
-- Balance all transactions without checking balance assertions,
|
||||
journalBalanceTransactions balancingopts_{ignore_assertions_=True} pj
|
||||
-- then add the auto postings
|
||||
-- (Note adding auto postings after balancing means #893b fails;
|
||||
-- adding them before balancing probably means #893a, #928, #938 fail.)
|
||||
>>= journalModifyTransactions d
|
||||
-- then check balance assertions.
|
||||
-- Add forecast transactions if enabled
|
||||
journalAddForecast d forecast_ j
|
||||
-- Add auto postings if enabled
|
||||
& (if auto_ && not (null $ jtxnmodifiers j) then journalAddAutoPostings d balancingopts_ else pure)
|
||||
-- Balance all transactions and maybe check balance assertions.
|
||||
>>= journalBalanceTransactions balancingopts_
|
||||
-- infer market prices from commodity-exchanging transactions
|
||||
<&> journalInferMarketPricesFromTransactions
|
||||
|
||||
journalAddAutoPostings :: Day -> BalancingOpts -> Journal -> Either String Journal
|
||||
journalAddAutoPostings d bopts =
|
||||
-- Balance all transactions without checking balance assertions,
|
||||
journalBalanceTransactions bopts{ignore_assertions_=True}
|
||||
-- then add the auto postings
|
||||
-- (Note adding auto postings after balancing means #893b fails;
|
||||
-- adding them before balancing probably means #893a, #928, #938 fail.)
|
||||
>=> journalModifyTransactions d
|
||||
|
||||
-- | Generate periodic transactions from all periodic transaction rules in the journal.
|
||||
-- These transactions are added to the in-memory Journal (but not the on-disk file).
|
||||
--
|
||||
-- The start & end date for generated periodic transactions are determined in
|
||||
-- a somewhat complicated way; see the hledger manual -> Periodic transactions.
|
||||
journalAddForecast :: Day -> Maybe DateSpan -> Journal -> Journal
|
||||
journalAddForecast _ Nothing j = j
|
||||
journalAddForecast d (Just requestedspan) j = j{jtxns = jtxns j ++ forecasttxns}
|
||||
where
|
||||
forecasttxns =
|
||||
map (txnTieKnot . transactionTransformPostings (postingApplyCommodityStyles $ journalCommodityStyles j))
|
||||
. filter (spanContainsDate forecastspan . tdate)
|
||||
. concatMap (`runPeriodicTransaction` forecastspan)
|
||||
$ jperiodictxns j
|
||||
|
||||
-- "They can start no earlier than: the day following the latest normal transaction in the journal (or today if there are none)."
|
||||
mjournalend = dbg2 "journalEndDate" $ journalEndDate False j -- ignore secondary dates
|
||||
forecastbeginDefault = dbg2 "forecastbeginDefault" $ mjournalend <|> Just d
|
||||
|
||||
-- "They end on or before the specified report end date, or 180 days from today if unspecified."
|
||||
forecastspan = dbg2 "forecastspan" $ dbg2 "forecastspan flag" requestedspan
|
||||
`spanDefaultsFrom` DateSpan forecastbeginDefault (Just $ addDays 180 d)
|
||||
|
||||
-- | Check that all the journal's transactions have payees declared with
|
||||
-- payee directives, returning an error message otherwise.
|
||||
|
||||
@ -195,20 +195,24 @@ defreportopts = ReportOpts
|
||||
, transpose_ = False
|
||||
}
|
||||
|
||||
rawOptsToReportOpts :: RawOpts -> IO ReportOpts
|
||||
rawOptsToReportOpts rawopts = do
|
||||
d <- getCurrentDay
|
||||
-- | Generate a ReportOpts from raw command-line input, given a day.
|
||||
-- This will fail with a usage error if it is passed
|
||||
-- - an invalid --format argument,
|
||||
-- - an invalid --value argument,
|
||||
-- - if --valuechange is called with a valuation type other than -V/--value=end.
|
||||
rawOptsToReportOpts :: Day -> RawOpts -> ReportOpts
|
||||
rawOptsToReportOpts d rawopts =
|
||||
|
||||
let formatstring = T.pack <$> maybestringopt "format" rawopts
|
||||
querystring = map T.pack $ listofstringopt "args" rawopts -- doesn't handle an arg like "" right
|
||||
(costing, valuation) = valuationTypeFromRawOpts rawopts
|
||||
|
||||
format <- case parseStringFormat <$> formatstring of
|
||||
Nothing -> return defaultBalanceLineFormat
|
||||
Just (Right x) -> return x
|
||||
Just (Left err) -> fail $ "could not parse format option: " ++ err
|
||||
format = case parseStringFormat <$> formatstring of
|
||||
Nothing -> defaultBalanceLineFormat
|
||||
Just (Right x) -> x
|
||||
Just (Left err) -> usageError $ "could not parse format option: " ++ err
|
||||
|
||||
return defreportopts
|
||||
in defreportopts
|
||||
{period_ = periodFromRawOpts d rawopts
|
||||
,interval_ = intervalFromRawOpts rawopts
|
||||
,statuses_ = statusesFromRawOpts rawopts
|
||||
@ -291,7 +295,7 @@ updateReportSpecWith = overWithReport reportOpts
|
||||
rawOptsToReportSpec :: RawOpts -> IO ReportSpec
|
||||
rawOptsToReportSpec rawopts = do
|
||||
d <- getCurrentDay
|
||||
ropts <- rawOptsToReportOpts rawopts
|
||||
let ropts = rawOptsToReportOpts d rawopts
|
||||
either fail return $ reportOptsToSpec d ropts
|
||||
|
||||
accountlistmodeopt :: RawOpts -> AccountListMode
|
||||
@ -443,6 +447,9 @@ reportOptsToggleStatus s ropts@ReportOpts{statuses_=ss}
|
||||
-- specified by -B/--cost, -V, -X/--exchange, or --value flags. It is
|
||||
-- allowed to combine -B/--cost with any other valuation type. If
|
||||
-- there's more than one valuation type, the rightmost flag wins.
|
||||
-- This will fail with a usage error if an invalid argument is passed
|
||||
-- to --value, or if --valuechange is called with a valuation type
|
||||
-- other than -V/--value=end.
|
||||
valuationTypeFromRawOpts :: RawOpts -> (Costing, Maybe ValuationType)
|
||||
valuationTypeFromRawOpts rawopts = (costing, valuation)
|
||||
where
|
||||
|
||||
@ -4,6 +4,7 @@ module Hledger.Web.Test (
|
||||
hledgerWebTest
|
||||
) where
|
||||
|
||||
import Control.Monad.Except (runExceptT)
|
||||
import qualified Data.Text as T
|
||||
import Test.Hspec (hspec)
|
||||
import Yesod.Default.Config
|
||||
@ -80,13 +81,17 @@ hledgerWebTest = do
|
||||
-- yit "can add transactions" $ do
|
||||
|
||||
let
|
||||
copts = defcliopts{reportspec_=defreportspec, file_=[""]} -- non-empty, see file_ note above
|
||||
-- Have forecasting on for testing
|
||||
iopts = definputopts{forecast_=Just nulldatespan}
|
||||
copts = defcliopts{inputopts_=iopts, file_=[""]} -- non-empty, see file_ note above
|
||||
wopts = defwebopts{cliopts_=copts}
|
||||
j <- fmap (either error id . journalTransform copts) $ readJournal' (T.pack $ unlines -- PARTIAL: readJournal' should not fail
|
||||
pj <- readJournal' (T.pack $ unlines -- PARTIAL: readJournal' should not fail
|
||||
["~ monthly"
|
||||
," assets 10"
|
||||
," income"
|
||||
])
|
||||
-- Have to give a non-null filename "fake" so forecast transactions get index 0
|
||||
j <- fmap (either error id) . runExceptT $ journalFinalise iopts "fake" "" pj -- PARTIAL: journalFinalise should not fail
|
||||
runHspecTestsWith conf wopts j $ do
|
||||
ydescribe "hledger-web --forecast" $ do
|
||||
|
||||
@ -95,4 +100,3 @@ hledgerWebTest = do
|
||||
statusIs 200
|
||||
bodyContains "id=\"transaction-0-1\"" -- 0 indicates a fileless (forecasted) txn
|
||||
bodyContains "id=\"transaction-0-2\"" -- etc.
|
||||
|
||||
|
||||
@ -15,7 +15,6 @@ module Hledger.Cli.Utils
|
||||
writeOutput,
|
||||
writeOutputLazyText,
|
||||
journalTransform,
|
||||
journalAddForecast,
|
||||
journalReload,
|
||||
journalReloadIfChanged,
|
||||
journalFileIsNewer,
|
||||
@ -38,7 +37,7 @@ import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as T
|
||||
import qualified Data.Text.Lazy as TL
|
||||
import qualified Data.Text.Lazy.IO as TL
|
||||
import Data.Time (UTCTime, Day, addDays)
|
||||
import Data.Time (UTCTime, Day)
|
||||
import Safe (readMay, headMay)
|
||||
import System.Console.CmdArgs
|
||||
import System.Directory (getModificationTime, getDirectoryContents, copyFile, doesFileExist)
|
||||
@ -75,7 +74,7 @@ withJournalDo opts cmd = do
|
||||
-- to let the add command work.
|
||||
journalpaths <- journalFilePathFromOpts opts
|
||||
files <- readJournalFiles (inputopts_ opts) journalpaths
|
||||
let transformed = journalTransform opts =<< files
|
||||
let transformed = journalTransform opts <$> files
|
||||
either error' cmd transformed -- PARTIAL:
|
||||
|
||||
-- | Apply some extra post-parse transformations to the journal, if
|
||||
@ -88,13 +87,12 @@ withJournalDo opts cmd = do
|
||||
--
|
||||
-- This will return an error message if the query in any auto posting rule fails
|
||||
-- to parse, or the generated transactions are not balanced.
|
||||
journalTransform :: CliOpts -> Journal -> Either String Journal
|
||||
journalTransform :: CliOpts -> Journal -> Journal
|
||||
journalTransform opts =
|
||||
fmap (anonymiseByOpts opts)
|
||||
anonymiseByOpts opts
|
||||
-- - converting amounts to market value (--value)
|
||||
-- . journalApplyValue ropts
|
||||
. fmap (pivotByOpts opts)
|
||||
. journalAddForecast opts
|
||||
. pivotByOpts opts
|
||||
|
||||
-- | Apply the pivot transformation on a journal, if option is present.
|
||||
pivotByOpts :: CliOpts -> Journal -> Journal
|
||||
@ -110,48 +108,6 @@ anonymiseByOpts opts =
|
||||
then anon
|
||||
else id
|
||||
|
||||
-- | Generate periodic transactions from all periodic transaction rules in the journal.
|
||||
-- These transactions are added to the in-memory Journal (but not the on-disk file).
|
||||
--
|
||||
-- When --auto is active, auto posting rules will be applied to the
|
||||
-- generated transactions. If the query in any auto posting rule fails
|
||||
-- to parse, or the generated transactions are not balanced, this function will
|
||||
-- return an error message.
|
||||
--
|
||||
-- The start & end date for generated periodic transactions are determined in
|
||||
-- a somewhat complicated way; see the hledger manual -> Periodic transactions.
|
||||
--
|
||||
journalAddForecast :: CliOpts -> Journal -> Either String Journal
|
||||
journalAddForecast CliOpts{inputopts_=iopts, reportspec_=rspec} j =
|
||||
case forecast_ iopts of
|
||||
Nothing -> return j
|
||||
Just _ -> do
|
||||
forecasttxns <- addAutoTxns =<< mapM (balanceTransaction (balancingopts_ iopts))
|
||||
[ txnTieKnot $ transactionTransformPostings (postingApplyCommodityStyles styles) t
|
||||
| pt <- jperiodictxns j
|
||||
, t <- runPeriodicTransaction pt forecastspan
|
||||
, spanContainsDate forecastspan (tdate t)
|
||||
]
|
||||
journalBalanceTransactions (balancingopts_ iopts) j{ jtxns = concat [jtxns j, forecasttxns] }
|
||||
where
|
||||
today = _rsDay rspec
|
||||
styles = journalCommodityStyles j
|
||||
|
||||
-- "They can start no earlier than: the day following the latest normal transaction in the journal (or today if there are none)."
|
||||
mjournalend = dbg2 "journalEndDate" $ journalEndDate False j -- ignore secondary dates
|
||||
forecastbeginDefault = dbg2 "forecastbeginDefault" $ fromMaybe today mjournalend
|
||||
|
||||
-- "They end on or before the specified report end date, or 180 days from today if unspecified."
|
||||
mspecifiedend = dbg2 "specifieddates" $ addDays 1 <$> reportPeriodLastDay rspec
|
||||
forecastendDefault = dbg2 "forecastendDefault" $ fromMaybe (addDays 180 today) mspecifiedend
|
||||
|
||||
forecastspan = dbg2 "forecastspan" $
|
||||
spanDefaultsFrom
|
||||
(fromMaybe nulldatespan $ dbg2 "forecastspan flag" $ forecast_ iopts)
|
||||
(DateSpan (Just forecastbeginDefault) (Just forecastendDefault))
|
||||
|
||||
addAutoTxns = if auto_ iopts then modifyTransactions styles today (jtxnmodifiers j) else return
|
||||
|
||||
-- | Write some output to stdout or to a file selected by --output-file.
|
||||
-- If the file exists it will be overwritten.
|
||||
writeOutput :: CliOpts -> String -> IO ()
|
||||
@ -199,7 +155,7 @@ journalReload :: CliOpts -> IO (Either String Journal)
|
||||
journalReload opts = do
|
||||
journalpaths <- dbg6 "reloading files" <$> journalFilePathFromOpts opts
|
||||
files <- readJournalFiles (inputopts_ opts) journalpaths
|
||||
return $ journalTransform opts =<< files
|
||||
return $ journalTransform opts <$> files
|
||||
|
||||
-- | Has the specified file changed since the journal was last read ?
|
||||
-- Typically this is one of the journal's journalFilePaths. These are
|
||||
|
||||
@ -235,3 +235,36 @@ hledger -f - reg -b 2021-01-01 -e 2021-01-05 --forecast
|
||||
2021-01-04 (a) 1 1003
|
||||
>>>2
|
||||
>>>=0
|
||||
|
||||
# 12. Forecast transactions work with balance assignments
|
||||
hledger -f - print -x --forecast -e 2021-11
|
||||
<<<
|
||||
2021-09-01 Normal Balance Assertion Works
|
||||
Checking = -60
|
||||
Costs
|
||||
|
||||
~ 2021-10-01 explicit forecasted assertion
|
||||
Checking = -100
|
||||
Costs 40
|
||||
|
||||
~ 2021-10-02 auto-deduced forecasted assertion
|
||||
Checking = -120
|
||||
Costs
|
||||
|
||||
>>>
|
||||
2021-09-01 Normal Balance Assertion Works
|
||||
Checking -60 = -60
|
||||
Costs 60
|
||||
|
||||
2021-10-01 explicit forecasted assertion
|
||||
; generated-transaction: ~ 2021-10-01
|
||||
Checking -40 = -100
|
||||
Costs 40
|
||||
|
||||
2021-10-02 auto-deduced forecasted assertion
|
||||
; generated-transaction: ~ 2021-10-02
|
||||
Checking -20 = -120
|
||||
Costs 20
|
||||
|
||||
>>>2
|
||||
>>>=0
|
||||
|
||||
Loading…
Reference in New Issue
Block a user