cli: introduce --dynamic-tags for rewrite/prints

Author: ony

hledger-lib/Hledger/Data/PeriodicTransaction.hs

@@ -215,7 +215,6 @@ runPeriodicTransaction PeriodicTransaction{..} requestedspan =
           ,tdescription = ptdescription
           ,tcomment     = ptcomment <> "\n"  -- force all further comments on new lines
           ,ttags        = ("_generated-transaction",period) :
-                          ("generated-transaction" ,period) :
                           pttags
           ,tpostings    = ptpostings
           }

hledger-lib/Hledger/Data/TransactionModifier.hs

@@ -43,7 +43,7 @@ modifyTransactions tmods = map applymods
         t' = foldr (flip (.) . transactionModifierToFunction) id tmods t
         taggedt'
           -- PERF: compares txns to see if any modifier had an effect, inefficient ?
-          | t' /= t   = t'{ttags    = ("modified","") : ttags t'}
+          | t' /= t   = t'{ttags    = ("_modified","") : ttags t'}
           | otherwise = t'
 
 -- | Converts a 'TransactionModifier' to a 'Transaction'-transforming function,
@@ -104,8 +104,7 @@ tmPostingRuleToFunction querytxt pr =
       { pdate    = pdate  pr <|> pdate  p
       , pdate2   = pdate2 pr <|> pdate2 p
       , pamount  = amount' p
-      , ptags    = ("generated-posting", qry) :
-                   ("_generated-posting",qry) :
+      , ptags    = ("_generated-posting",qry) :
                    ptags pr
       }
   where

hledger/Hledger/Cli/Commands/Print.hs

@@ -4,17 +4,21 @@ A ledger-compatible @print@ command.
 
 -}
 
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings, LambdaCase, ViewPatterns #-}
 {-# LANGUAGE TemplateHaskell #-}
 
 module Hledger.Cli.Commands.Print (
   printmode
+ ,txnflags
  ,print'
  -- ,entriesReportAsText
- ,originalTransaction
+ ,modPostings
+ ,prepareTxnFromOpts
 )
 where
 
+import Data.Maybe (catMaybes)
+import Data.List (nub)
 import Data.Text (Text)
 import qualified Data.Text as T
 import System.Console.CmdArgs.Explicit
@@ -32,15 +36,27 @@ printmode = hledgerCommandMode
   ([let arg = "STR" in
    flagReq  ["match","m"] (\s opts -> Right $ setopt "match" s opts) arg
     ("show the transaction whose description is most similar to "++arg++", and is most recent")
-  ,flagNone ["explicit","x"] (setboolopt "explicit")
-    "show all amounts explicitly"
   ,flagNone ["new"] (setboolopt "new")
     "show only newer-dated transactions added in each file since last run"
-  ] ++ outputflags)
+  ] ++ txnflags ++ outputflags)
   [generalflagsgroup1]
   hiddenflags
   ([], Just $ argsFlag "[QUERY]")
 
+-- | Common flags between all commands that print parsable transactions
+txnflags =
+    [ flagNone ["explicit","x"] (setboolopt "explicit")
+      "show all amounts explicitly"
+    , flagNone ["dynamic-tags"] (setboolopt "dynamic-tags")
+      "include dynamic tags as normal ones"
+    ]
+
+enrichDynamicTags :: ([Tag] -> [Tag])
+enrichDynamicTags tags = nub $ tags ++ catMaybes (map enrichedMay tags) where
+    enrichedMay = \case
+      ((T.stripPrefix "_" -> Just tag), value) -> Just (tag, value)
+      _ -> Nothing
+
 -- | Print journal transactions in standard format.
 print' :: CliOpts -> Journal -> IO ()
 print' opts j = do
@@ -60,21 +76,33 @@ printEntries opts@CliOpts{reportopts_=ropts} j = do
   writeOutput opts $ render $ entriesReport ropts' q j
 
 entriesReportAsText :: CliOpts -> EntriesReport -> String
-entriesReportAsText opts = concatMap (showTransaction . syncTxn . gettxn)
+entriesReportAsText opts = concatMap (showTransaction . syncTxn . prepareTxnFromOpts opts)
+
+-- | Create transaction update
+prepareTxnFromOpts :: CliOpts -> Transaction -> Transaction
+prepareTxnFromOpts opts =
+      (if boolopt "dynamic-tags" (rawopts_ opts) then modTags enrichDynamicTags else id).
+      (if useexplicittxn then id                                   -- use fully inferred amounts & txn prices
+                         else modPostings originalPostingAmounts)  -- use original as-written amounts/txn prices
   where
-    gettxn | useexplicittxn = id                   -- use fully inferred amounts & txn prices
-           | otherwise      = originalTransaction  -- use original as-written amounts/txn prices
     -- Original vs inferred transactions/postings were causing problems here, disabling -B (#551).
     -- Use the explicit one if -B or -x are active.
     -- This passes tests; does it also mean -B sometimes shows missing amounts unnecessarily ?
     useexplicittxn = boolopt "explicit" (rawopts_ opts) || (valuationTypeIsCost $ reportopts_ opts)
 
--- Replace this transaction's postings with the original postings if any, but keep the
--- current possibly rewritten account names.
-originalTransaction t = t { tpostings = map originalPostingPreservingAccount $ tpostings t }
+-- | Update postings of transaction
+-- Note that you still need to call 'txnTieKnot'
+modPostings mod t = t { tpostings = map mod $ tpostings t }
+
+-- | Update tags of transaction and postings
+-- Note that you still need to call 'txnTieKnot'
+modTags :: ([Tag] -> [Tag]) -> Transaction -> Transaction
+modTags f t = t { ttags = f $ ttags t, tpostings = map modPosting $ tpostings t } where
+  modPosting p = p { ptags = f $ ptags p }
 
--- Get the original posting if any, but keep the current possibly rewritten account name.
-originalPostingPreservingAccount p = (originalPosting p) { paccount = paccount p }
+-- Get the original amounts preserving everything else
+originalPostingAmounts p = p { pamount = pamount p0, pbalanceassertion = pbalanceassertion p0 }
+    where p0 = originalPosting p
 
 -- XXX
 -- tests_showTransactions = [

hledger/Hledger/Cli/Commands/Printunique.hs

@@ -13,13 +13,13 @@ import Hledger.Cli.Commands.Print
 
 printuniquemode = hledgerCommandMode
   $(embedFileRelative "Hledger/Cli/Commands/Printunique.txt")
-  []
+  txnflags
   [generalflagsgroup1]
   hiddenflags
   ([], Nothing)
 
 printunique opts j@Journal{jtxns=ts} = do
-  print' opts j{jtxns=uniquify ts}
+  print' opts j{jtxns=prepareTxnFromOpts opts <$> uniquify ts}
   where
     uniquify = nubBy (\t1 t2 -> thingToCompare t1 == thingToCompare t2) . sortOn thingToCompare
     thingToCompare = tdescription

hledger/Hledger/Cli/Commands/Rewrite.hs

@@ -25,11 +25,10 @@ import qualified Data.Algorithm.Diff as D
 
 rewritemode = hledgerCommandMode
   $(embedFileRelative "Hledger/Cli/Commands/Rewrite.txt")
-  [flagReq ["add-posting"] (\s opts -> Right $ setopt "add-posting" s opts) "'ACCT  AMTEXPR'"
+  ([flagReq ["add-posting"] (\s opts -> Right $ setopt "add-posting" s opts) "'ACCT  AMTEXPR'"
            "add a posting to ACCT, which may be parenthesised. AMTEXPR is either a literal amount, or *N which means the transaction's first matched amount multiplied by N (a decimal number). Two spaces separate ACCT and AMTEXPR."
   ,flagNone ["diff"] (setboolopt "diff") "generate diff suitable as an input for patch tool"
-  ,flagNone ["trace"] (setboolopt "trace") "inject special tags for generated postings/transactions for debug/trace prupose"
-  ]
+  ] ++ txnflags)
   [generalflagsgroup1]
   hiddenflags
   ([], Just $ argsFlag "[QUERY] --add-posting \"ACCT  AMTEXPR\" ...")
@@ -41,20 +40,10 @@ rewritemode = hledgerCommandMode
 rewrite opts@CliOpts{rawopts_=rawopts,reportopts_=ropts} j@Journal{jtxns=ts} = do
   -- rewrite matched transactions
   let modifiers = transactionModifierFromOpts opts : jtxnmodifiers j
-  let j' = j{jtxns=traceModFromOpts opts <$> modifyTransactions modifiers ts}
+  let j' = j{jtxns=prepareTxnFromOpts opts <$> modifyTransactions modifiers ts}
   -- run the print command, showing all transactions, or show diffs
   printOrDiff rawopts opts{reportopts_=ropts{query_=""}} j j'
 
-traceModFromOpts :: CliOpts -> Transaction -> Transaction
-traceModFromOpts CliOpts{rawopts_=rawopts} =
-  if boolopt "trace" rawopts then id else stripTxn
-
-stripTxn :: Transaction -> Transaction
-stripTxn t = t { ttags = stripTags $ ttags t, tpostings = map stripPosting $ tpostings t } where
-  stripPosting p = p { ptags = stripTags $ ptags p }
-  stripTags = filter ((`notElem` ["generated-posting", "generated-transaction", "modified"]) . fst)
-
-
 -- | Build a 'TransactionModifier' from any query arguments and --add-posting flags
 -- provided on the command line, or throw a parse error.
 transactionModifierFromOpts :: CliOpts -> TransactionModifier
@@ -78,6 +67,10 @@ diffOutput j j' = do
     let changed = [(originalTransaction t, originalTransaction t') | (t, t') <- zip (jtxns j) (jtxns j'), t /= t']
     putStr $ renderPatch $ map (uncurry $ diffTxn j) changed
 
+-- | Replace this transaction's postings with the original postings if any
+-- It is used for building correct diff
+originalTransaction = modPostings originalPosting
+
 type Chunk = (GenericSourcePos, [DiffLine String])
 
 -- XXX doctests, update needed:

tests/forecast.test

@@ -51,7 +51,6 @@ hledger print -b 2016-11 -e 2017-02 -f - --forecast
     assets:cash
 
 2017/01/01 * marked cleared, and with a description
-    ; generated-transaction: ~ monthly from 2016/1
     income                    $-1000
     expenses:food                $20
     expenses:leisure             $15
@@ -118,7 +117,6 @@ Y 2000
 
 >>>
 2000/02/01 forecast
-    ; generated-transaction: ~ 2/1
 
 >>>2
 >>>=0
@@ -135,7 +133,6 @@ Y 2000
 
 >>>
 2000/01/15 forecast
-    ; generated-transaction: ~ 15
 
 >>>2
 >>>=0
@@ -152,7 +149,35 @@ Y 2000
 
 >>>
 2000/02/01 forecast
-    ; generated-transaction: ~ next month
+
+>>>2
+>>>=0
+
+# 8. print forecasted transactions with dynamic tags
+hledger print -b 2016-11 -e 2017-02 -f - --forecast --dynamic-tags
+<<<
+2016/12/31
+    expenses:housing  $600
+    assets:cash
+
+~ monthly from 2016/1  * marked cleared, and with a description
+    income  $-1000
+    expenses:food     $20
+    expenses:leisure  $15
+    expenses:grocery  $30
+    assets:cash
+>>>
+2016/12/31
+    expenses:housing            $600
+    assets:cash
+
+2017/01/01 * marked cleared, and with a description
+    ; generated-transaction: ~ monthly from 2016/1
+    income                    $-1000
+    expenses:food                $20
+    expenses:leisure             $15
+    expenses:grocery             $30
+    assets:cash
 
 >>>2
 >>>=0