From 8954944ee678d15e206134d33e980d272e535137 Mon Sep 17 00:00:00 2001 From: Mykola Orliuk Date: Fri, 13 Jan 2017 22:41:16 +0200 Subject: [PATCH] Apply ModifierTransaction's from journal during hledger-rewrite. (#477) * rewrite: rewrite every posting Also start using ModifierTransaction * rewrite: use journal parser for postings * rewrite: use ModifierTransactions from Journal See simonmichael/hledger#99 --- bin/hledger-rewrite.hs | 75 +++++++++++++++++++++--------------------- tests/bin/rewrite.test | 73 ++++++++++++++++++++++++++++++++++++++-- 2 files changed, 108 insertions(+), 40 deletions(-) diff --git a/bin/hledger-rewrite.hs b/bin/hledger-rewrite.hs index 325a9b506..9d40685dc 100755 --- a/bin/hledger-rewrite.hs +++ b/bin/hledger-rewrite.hs @@ -5,6 +5,7 @@ --package megaparsec --package text -} +{-# LANGUAGE OverloadedStrings, LambdaCase #-} {- hledger-rewrite [PATTERNS] --add-posting "ACCT AMTEXPR" ... @@ -27,11 +28,11 @@ Related: https://github.com/simonmichael/hledger/issues/99 TODO: - should allow regex matching and interpolating matched name in replacement - should apply all matching rules to a transaction, not just one -- should apply the rule for each matched posting within a transaction, if there's more than one - should be possible to use this on unbalanced entries, eg while editing one -} +import Data.Monoid import qualified Data.Text as T -- hledger lib, cli and cmdargs utils import Hledger.Cli @@ -57,55 +58,53 @@ cmdmode = (defCommandMode ["hledger-rewrite"]) { } } -type PostingExpr = (AccountName, AmountExpr) +postingp' :: T.Text -> IO Posting +postingp' t = runErroringJournalParser (postingp Nothing <* eof) t' >>= \case + Left err -> fail err + Right p -> return p + where t' = " " <> t <> "\n" -- inject space and newline for proper parsing -data AmountExpr = AmountLiteral String | AmountMultiplier Quantity deriving (Show) +modifierTransactionFromOpts :: RawOpts -> IO ModifierTransaction +modifierTransactionFromOpts opts = do + postings <- mapM (postingp' . stripquotes . T.pack) $ listofstringopt "add-posting" opts + return + ModifierTransaction { mtvalueexpr = T.empty, mtpostings = postings } -addPostingExprsFromOpts :: RawOpts -> [PostingExpr] -addPostingExprsFromOpts = map (either parseerror id . runParser (postingexprp <* eof) "") . map (stripquotes . T.pack) . listofstringopt "add-posting" +post' :: AccountName -> Amount -> Posting +post' acct amt = (accountNameWithoutPostingType acct `post` amt) { ptype = accountNamePostingType acct } -postingexprp = do - a <- accountnamep - spacenonewline >> some spacenonewline - aex <- amountexprp - many spacenonewline - return (a,aex) +-- mtvaluequery :: ModifierTransaction -> Day -> Query +mtvaluequery mod = fst . flip parseQuery (mtvalueexpr mod) -amountexprp = - choice [ - AmountMultiplier <$> (do char '*' - many spacenonewline - (q,_,_,_) <- numberp - return q) - ,AmountLiteral <$> many anyChar - ] +postingScale :: Posting -> Maybe Quantity +postingScale p = + case amounts $ pamount p of + [a] | acommodity a == "*" -> Just $ aquantity a + _ -> Nothing -amountExprRenderer :: Query -> AmountExpr -> (Transaction -> MixedAmount) -amountExprRenderer q aex = - case aex of - AmountLiteral s -> const (mamountp' s) - AmountMultiplier n -> (`divideMixedAmount` (1 / n)) . (`firstAmountMatching` q) - where - firstAmountMatching :: Transaction -> Query -> MixedAmount - firstAmountMatching t q = pamount $ head $ filter (q `matchesPosting`) $ tpostings t +runModifierPosting :: Posting -> (Posting -> Posting) +runModifierPosting p' = + case postingScale p' of + Nothing -> \p -> p' { ptransaction = ptransaction p } + Just n -> \p -> p' { pamount = pamount p `divideMixedAmount` (1/n), ptransaction = ptransaction p } -rewriteTransaction :: Transaction -> [(AccountName, Transaction -> MixedAmount)] -> Transaction -rewriteTransaction t addps = t{tpostings=tpostings t ++ map (uncurry (generatePosting t)) addps} - where - generatePosting :: Transaction -> AccountName -> (Transaction -> MixedAmount) -> Posting - generatePosting t acct amtfn = nullposting{paccount = accountNameWithoutPostingType acct - ,ptype = accountNamePostingType acct - ,pamount = amtfn t - ,ptransaction = Just t - } +runModifierTransaction :: Query -> ModifierTransaction -> (Transaction -> Transaction) +runModifierTransaction q mod = modifier where + q' = simplifyQuery $ And [q, mtvaluequery mod (error "query cannot depend on current time")] + mods = map runModifierPosting $ mtpostings mod + generatePostings ps = [mod p | p <- ps, q' `matchesPosting` p, mod <- mods] + modifier t@Transaction{ tpostings = ps } = t { tpostings = ps ++ generatePostings ps } main = do opts@CliOpts{rawopts_=rawopts,reportopts_=ropts} <- getCliOpts cmdmode d <- getCurrentDay let q = queryFromOpts d ropts - addps = [(a, amountExprRenderer q aex) | (a, aex) <- addPostingExprsFromOpts rawopts] + mod <- modifierTransactionFromOpts rawopts withJournalDo opts $ \opts j@Journal{jtxns=ts} -> do + -- create re-writer + let mods = jmodifiertxns j ++ [mod] + modifier = foldr (.) id $ map (runModifierTransaction q) mods -- rewrite matched transactions - let j' = j{jtxns=map (\t -> if q `matchesTransaction` t then rewriteTransaction t addps else t) ts} + let j' = j{jtxns=map modifier ts} -- run the print command, showing all transactions print' opts{reportopts_=ropts{query_=""}} j' diff --git a/tests/bin/rewrite.test b/tests/bin/rewrite.test index 2f7ba3d27..6adbf3833 100644 --- a/tests/bin/rewrite.test +++ b/tests/bin/rewrite.test @@ -1,10 +1,11 @@ # Tests for rewrite addon # Add proportional income tax (from documentation) -runghc ../../bin/hledger-rewrite.hs -f- ^income --add-posting '(liabilities:tax) *.33' +runghc ../../bin/hledger-rewrite.hs -f- ^income --add-posting '(liabilities:tax) *.33 ; income tax' <<< 2016/1/1 paycheck income:remuneration $-100 + income:donations $-15 assets:bank 2016/1/1 withdraw @@ -13,8 +14,10 @@ runghc ../../bin/hledger-rewrite.hs -f- ^income --add-posting '(liabilities:tax) >>> 2016/01/01 paycheck income:remuneration $-100 + income:donations $-15 assets:bank - (liabilities:tax) $-33 + (liabilities:tax) $-33 ; income tax + (liabilities:tax) $-5 ; income tax 2016/01/01 withdraw assets:cash $20 @@ -76,3 +79,69 @@ runghc ../../bin/hledger-rewrite.hs -f- assets:bank and 'amt:<0' --add-posting ' >>>2 >>>=0 + +# Rewrite rule within journal +runghc ../../bin/hledger-rewrite.hs -f- date:2017/1 --add-posting 'Here comes Santa $0' +<<< += ^expenses:housing + (budget:housing) *-1 += ^expenses:grocery or ^expenses:food + (budget:food) *-1 + +2016/12/31 + expenses:housing $600 + assets:cash + +2017/1/1 + expenses:food $20 + expenses:leisure $15 + expenses:grocery $30 + assets:cash + +2017/1/2 + assets:cash $200.00 + assets:bank + +2017/2/1 + assets:cash $100.00 + assets:bank + += ^expenses not:housing not:grocery not:food + (budget:misc) *-1 + += ^assets:bank$ date:2017/1 amt:<0 + assets:bank *0.008 + expenses:fee *-0.008 ; cash withdraw fee +>>> +2016/12/31 + expenses:housing $600.00 + assets:cash + +2017/01/01 + expenses:food $20.00 + expenses:leisure $15.00 + expenses:grocery $30.00 + assets:cash + Here comes Santa 0 + Here comes Santa 0 + Here comes Santa 0 + Here comes Santa 0 + (budget:misc) $-15.00 + (budget:food) $-20.00 + (budget:food) $-30.00 + +2017/01/02 + assets:cash $200.00 + assets:bank + Here comes Santa 0 + Here comes Santa 0 + assets:bank $-1.60 + expenses:fee $1.60 ; cash withdraw fee + (budget:misc) $-1.60 + +2017/02/01 + assets:cash $100.00 + assets:bank + +>>>2 +>>>=0