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.

hledger-lib/Hledger/Query.hs

@@ -20,6 +20,7 @@ module Hledger.Query (
   -- * parsing
   parseQuery,
   parseQueryList,
+  parseQueryTerm,
   simplifyQuery,
   filterQuery,
   -- * accessors

hledger-lib/Hledger/Read/Common.hs

@@ -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 =
+forecastPeriodFromRawOpts d rawopts = case maybestringopt "forecast" rawopts of
-  case maybestringopt "forecast" opts
-  of
     Nothing -> Nothing
-    Just "" -> Just nulldatespan
+    Just "" -> Just forecastspanDefault
-    Just str ->
+    Just str -> either (\e -> usageError $ "could not parse forecast period : "++customErrorBundlePretty e)
-      either (\e -> usageError $ "could not parse forecast period : "++customErrorBundlePretty e) (Just . snd) $ 
+                       (\(_,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
+journalFinalise InputOpts{forecast_,auto_,balancingopts_,strict_} f txt pj = do
     t <- liftIO getClockTime
     d <- liftIO getCurrentDay
-  liftEither $ do
     -- 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 $
+    liftEither $ checkAddAndBalance d <=< journalApplyCommodityStyles $
-              pj'{jglobalcommoditystyles=fromMaybe M.empty $ commodity_styles_ balancingopts_}  -- save any global commodity styles
+        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 pj
+          journalCheckAccountsDeclared j
           -- and using declared commodities
-      journalCheckCommoditiesDeclared pj
+          journalCheckCommoditiesDeclared j
 
-    -- infer market prices from commodity-exchanging transactions
+        -- Add forecast transactions if enabled
-    journalInferMarketPricesFromTransactions <$>
+        journalAddForecast d forecast_ j
-      if not auto_ || null (jtxnmodifiers pj)
+        -- Add auto postings if enabled
-        then
+          & (if auto_ && not (null $ jtxnmodifiers j) then journalAddAutoPostings d balancingopts_ else pure)
-          -- Auto postings are not active.
         -- Balance all transactions and maybe check balance assertions.
-          journalBalanceTransactions balancingopts_ pj
+          >>= journalBalanceTransactions balancingopts_
-        else
+        -- infer market prices from commodity-exchanging transactions
-          -- Auto postings are active.
+          <&> journalInferMarketPricesFromTransactions
+
+journalAddAutoPostings :: Day -> BalancingOpts -> Journal -> Either String Journal
+journalAddAutoPostings d bopts =
     -- Balance all transactions without checking balance assertions,
-          journalBalanceTransactions balancingopts_{ignore_assertions_=True} pj
+    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
+    >=> journalModifyTransactions d
-          -- then check balance assertions.
+
-          >>= journalBalanceTransactions balancingopts_
+-- | 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.

hledger-lib/Hledger/Reports/ReportOptions.hs

@@ -195,20 +195,24 @@ defreportopts = ReportOpts
     , transpose_       = False
     }
 
-rawOptsToReportOpts :: RawOpts -> IO ReportOpts
+-- | Generate a ReportOpts from raw command-line input, given a day.
-rawOptsToReportOpts rawopts = do
+-- This will fail with a usage error if it is passed
-    d <- getCurrentDay
+-- - 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
+        format = case parseStringFormat <$> formatstring of
-        Nothing         -> return defaultBalanceLineFormat
+            Nothing         -> defaultBalanceLineFormat
-        Just (Right x)  -> return x
+            Just (Right x)  -> x
-        Just (Left err) -> fail $ "could not parse format option: " ++ err
+            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

hledger-web/Hledger/Web/Test.hs

@@ -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.
-

hledger/Hledger/Cli/Utils.hs

@@ -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)
+  . pivotByOpts opts
-  . journalAddForecast 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

hledger/test/forecast.test

@@ -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