{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
{-|

A 'TransactionModifier' is a rule that modifies certain 'Transaction's,
typically adding automated postings to them.

-}
module Hledger.Data.TransactionModifier (
   modifyTransactions
)
where

import Prelude hiding (Applicative(..))
import Control.Applicative (Applicative(..), (<|>))
import Data.Function ((&))
import qualified Data.Map as M
import Data.Maybe (catMaybes)
import qualified Data.Text as T
import Data.Time.Calendar (Day)
import Safe (headDef)
import Hledger.Data.Types
import Hledger.Data.Amount
import Hledger.Data.Dates
import Hledger.Data.Transaction (txnTieKnot, transactionAddHiddenAndMaybeVisibleTag)
import Hledger.Query (Query, filterQuery, matchesAmount, matchesPostingExtra,
                      parseQuery, queryIsAmt, queryIsSym, simplifyQuery)
import Hledger.Data.Posting (commentJoin, commentAddTag, postingAddTags, modifiedTransactionTagName)
import Hledger.Utils (dbg6, wrap)

-- $setup
-- >>> :set -XOverloadedStrings
-- >>> import Hledger.Data.Posting
-- >>> import Hledger.Data.Transaction
-- >>> import Hledger.Data.Journal

-- | Apply all the given transaction modifiers, in turn, to each transaction.
-- Or if any of them fails to be parsed, return the first error. A reference
-- date is provided to help interpret relative dates in transaction modifier
-- queries.
modifyTransactions :: (AccountName -> Maybe AccountType)
                   -> (AccountName -> [Tag])
                   -> M.Map CommoditySymbol AmountStyle
                   -> Day -> Bool -> [TransactionModifier] -> [Transaction]
                   -> Either String [Transaction]
modifyTransactions :: (TagName -> Maybe AccountType)
-> (TagName -> [Tag])
-> Map TagName AmountStyle
-> Day
-> Bool
-> [TransactionModifier]
-> [Transaction]
-> Either String [Transaction]
modifyTransactions TagName -> Maybe AccountType
atypes TagName -> [Tag]
atags Map TagName AmountStyle
styles Day
d Bool
verbosetags [TransactionModifier]
tmods [Transaction]
ts = do
  [Transaction -> Transaction]
fs <- (TransactionModifier -> Either String (Transaction -> Transaction))
-> [TransactionModifier]
-> Either String [Transaction -> Transaction]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((TagName -> Maybe AccountType)
-> (TagName -> [Tag])
-> Map TagName AmountStyle
-> Day
-> Bool
-> TransactionModifier
-> Either String (Transaction -> Transaction)
transactionModifierToFunction TagName -> Maybe AccountType
atypes TagName -> [Tag]
atags Map TagName AmountStyle
styles Day
d Bool
verbosetags) [TransactionModifier]
tmods  -- convert modifiers to functions, or return a parse error
  let
    modifytxn :: Transaction -> Transaction
modifytxn Transaction
t =
      Transaction
t' Transaction -> (Transaction -> Transaction) -> Transaction
forall a b. a -> (a -> b) -> b
& if Transaction
t'Transaction -> Transaction -> Bool
forall a. Eq a => a -> a -> Bool
/=Transaction
t then Bool -> Tag -> Transaction -> Transaction
transactionAddHiddenAndMaybeVisibleTag Bool
verbosetags (TagName
modifiedTransactionTagName,TagName
"") else Transaction -> Transaction
forall a. a -> a
id
      where
        t' :: Transaction
t' = ((Transaction -> Transaction)
 -> (Transaction -> Transaction) -> Transaction -> Transaction)
-> (Transaction -> Transaction)
-> [Transaction -> Transaction]
-> Transaction
-> Transaction
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (((Transaction -> Transaction)
 -> (Transaction -> Transaction) -> Transaction -> Transaction)
-> (Transaction -> Transaction)
-> (Transaction -> Transaction)
-> Transaction
-> Transaction
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Transaction -> Transaction)
-> (Transaction -> Transaction) -> Transaction -> Transaction
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.)) Transaction -> Transaction
forall a. a -> a
id [Transaction -> Transaction]
fs Transaction
t  -- apply each function in turn

  [Transaction] -> Either String [Transaction]
forall a b. b -> Either a b
Right ([Transaction] -> Either String [Transaction])
-> [Transaction] -> Either String [Transaction]
forall a b. (a -> b) -> a -> b
$ (Transaction -> Transaction) -> [Transaction] -> [Transaction]
forall a b. (a -> b) -> [a] -> [b]
map Transaction -> Transaction
modifytxn [Transaction]
ts

-- | Converts a 'TransactionModifier' to a 'Transaction'-transforming function
-- which applies the modification(s) specified by the TransactionModifier.
-- Or, returns the error message there is a problem parsing the TransactionModifier's query.
-- A reference date is provided to help interpret relative dates in the query.
--
-- The postings of the transformed transaction will reference it in the usual
-- way (ie, 'txnTieKnot' is called).
--
-- Currently the only kind of modification possible is adding automated
-- postings when certain other postings are present.
--
-- >>> import qualified Data.Text.IO as T
-- >>> t = nulltransaction{tpostings=["ping" `post` usd 1]}
-- >>> tmpost acc amt = TMPostingRule (acc `post` amt) False
-- >>> test = either putStr (T.putStr.showTransaction) . fmap ($ t) . transactionModifierToFunction (const Nothing) (const []) mempty nulldate True
-- >>> test $ TransactionModifier "" ["pong" `tmpost` usd 2]
-- 0000-01-01
--     ping           $1.00
--     pong           $2.00  ; generated-posting: =
-- <BLANKLINE>
-- >>> test $ TransactionModifier "miss" ["pong" `tmpost` usd 2]
-- 0000-01-01
--     ping           $1.00
-- <BLANKLINE>
-- >>> test $ TransactionModifier "ping" [("pong" `tmpost` nullamt{aquantity=3}){tmprIsMultiplier=True}]
-- 0000-01-01
--     ping           $1.00
--     pong           $3.00  ; generated-posting: = ping
-- <BLANKLINE>
--
transactionModifierToFunction :: (AccountName -> Maybe AccountType)
                              -> (AccountName -> [Tag])
                              -> M.Map CommoditySymbol AmountStyle
                              -> Day -> Bool -> TransactionModifier
                              -> Either String (Transaction -> Transaction)
transactionModifierToFunction :: (TagName -> Maybe AccountType)
-> (TagName -> [Tag])
-> Map TagName AmountStyle
-> Day
-> Bool
-> TransactionModifier
-> Either String (Transaction -> Transaction)
transactionModifierToFunction TagName -> Maybe AccountType
atypes TagName -> [Tag]
atags Map TagName AmountStyle
styles Day
refdate Bool
verbosetags TransactionModifier{TagName
tmquerytxt :: TagName
tmquerytxt :: TransactionModifier -> TagName
tmquerytxt, [TMPostingRule]
tmpostingrules :: [TMPostingRule]
tmpostingrules :: TransactionModifier -> [TMPostingRule]
tmpostingrules} = do
  Query
q <- Query -> Query
simplifyQuery (Query -> Query)
-> ((Query, [QueryOpt]) -> Query) -> (Query, [QueryOpt]) -> Query
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Query, [QueryOpt]) -> Query
forall a b. (a, b) -> a
fst ((Query, [QueryOpt]) -> Query)
-> Either String (Query, [QueryOpt]) -> Either String Query
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Day -> TagName -> Either String (Query, [QueryOpt])
parseQuery Day
refdate TagName
tmquerytxt
  let
    fs :: [Posting -> Posting]
fs = (TMPostingRule -> Posting -> Posting)
-> [TMPostingRule] -> [Posting -> Posting]
forall a b. (a -> b) -> [a] -> [b]
map (\TMPostingRule
tmpr -> Posting -> Posting
addAccountTags (Posting -> Posting) -> (Posting -> Posting) -> Posting -> Posting
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool
-> Map TagName AmountStyle
-> Query
-> TagName
-> TMPostingRule
-> Posting
-> Posting
tmPostingRuleToFunction Bool
verbosetags Map TagName AmountStyle
styles Query
q TagName
tmquerytxt TMPostingRule
tmpr) [TMPostingRule]
tmpostingrules
    addAccountTags :: Posting -> Posting
addAccountTags Posting
p = Posting
p Posting -> [Tag] -> Posting
`postingAddTags` TagName -> [Tag]
atags (Posting -> TagName
paccount Posting
p)
    generatePostings :: Posting -> [Posting]
generatePostings Posting
p = Posting
p Posting -> [Posting] -> [Posting]
forall a. a -> [a] -> [a]
: ((Posting -> Posting) -> Posting)
-> [Posting -> Posting] -> [Posting]
forall a b. (a -> b) -> [a] -> [b]
map ((Posting -> Posting) -> Posting -> Posting
forall a b. (a -> b) -> a -> b
$ Posting
p) (if (TagName -> Maybe AccountType) -> Query -> Posting -> Bool
matchesPostingExtra TagName -> Maybe AccountType
atypes Query
q Posting
p then [Posting -> Posting]
fs else [])
  (Transaction -> Transaction)
-> Either String (Transaction -> Transaction)
forall a b. b -> Either a b
Right ((Transaction -> Transaction)
 -> Either String (Transaction -> Transaction))
-> (Transaction -> Transaction)
-> Either String (Transaction -> Transaction)
forall a b. (a -> b) -> a -> b
$ \t :: Transaction
t@(Transaction -> [Posting]
tpostings -> [Posting]
ps) -> Transaction -> Transaction
txnTieKnot Transaction
t{tpostings=concatMap generatePostings ps}

-- | Converts a 'TransactionModifier''s posting rule to a 'Posting'-generating function,
-- which will be used to make a new posting based on the old one (an "automated posting").
-- The new posting's amount can optionally be the old posting's amount multiplied by a constant.
-- If the old posting had a total-priced amount, the new posting's multiplied amount will be unit-priced.
-- The new posting will have a hidden _generated-posting: tag added,
-- and with a true first argument, also a visible generated-posting: tag.
-- The provided TransactionModifier's query text is saved as the tags' value.
tmPostingRuleToFunction :: Bool -> M.Map CommoditySymbol AmountStyle -> Query -> T.Text -> TMPostingRule -> (Posting -> Posting)
tmPostingRuleToFunction :: Bool
-> Map TagName AmountStyle
-> Query
-> TagName
-> TMPostingRule
-> Posting
-> Posting
tmPostingRuleToFunction Bool
verbosetags Map TagName AmountStyle
styles Query
query TagName
querytxt TMPostingRule
tmpr =
  \Posting
p -> Map TagName AmountStyle -> Posting -> Posting
forall a. HasAmounts a => Map TagName AmountStyle -> a -> a
styleAmounts Map TagName AmountStyle
styles (Posting -> Posting) -> (Posting -> Posting) -> Posting -> Posting
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Posting -> Posting
renderPostingCommentDates (Posting -> Posting) -> Posting -> Posting
forall a b. (a -> b) -> a -> b
$ Posting
pr
      { pdate    = pdate  pr <|> pdate  p
      , pdate2   = pdate2 pr <|> pdate2 p
      , pamount  = amount' p
      , pcomment = pcomment pr & (if verbosetags then (`commentAddTag` ("generated-posting",qry)) else id)
      , ptags    = ptags pr
                   & (("_generated-posting",qry) :)
                   & (if verbosetags then (("generated-posting", qry) :) else id)
      }
  where
    pr :: Posting
pr = TMPostingRule -> Posting
tmprPosting TMPostingRule
tmpr
    qry :: TagName
qry = TagName
"= " TagName -> TagName -> TagName
forall a. Semigroup a => a -> a -> a
<> TagName
querytxt
    symq :: Query
symq = (Query -> Bool) -> Query -> Query
filterQuery ((Bool -> Bool -> Bool)
-> (Query -> Bool) -> (Query -> Bool) -> Query -> Bool
forall a b c.
(a -> b -> c) -> (Query -> a) -> (Query -> b) -> Query -> c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Bool -> Bool -> Bool
(||) Query -> Bool
queryIsSym Query -> Bool
queryIsAmt) Query
query
    amount' :: Posting -> MixedAmount
amount' = case TMPostingRule -> Maybe Quantity
postingRuleMultiplier TMPostingRule
tmpr of
        Maybe Quantity
Nothing -> MixedAmount -> Posting -> MixedAmount
forall a b. a -> b -> a
const (MixedAmount -> Posting -> MixedAmount)
-> MixedAmount -> Posting -> MixedAmount
forall a b. (a -> b) -> a -> b
$ Posting -> MixedAmount
pamount Posting
pr
        Just Quantity
n  -> \Posting
p ->
          -- Multiply the old posting's amount by the posting rule's multiplier.
          let
            pramount :: Amount
pramount = String -> Amount -> Amount
forall a. Show a => String -> a -> a
dbg6 String
"pramount" (Amount -> Amount)
-> (MixedAmount -> Amount) -> MixedAmount -> Amount
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Amount -> [Amount] -> Amount
forall a. a -> [a] -> a
headDef Amount
nullamt ([Amount] -> Amount)
-> (MixedAmount -> [Amount]) -> MixedAmount -> Amount
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MixedAmount -> [Amount]
amountsRaw (MixedAmount -> Amount) -> MixedAmount -> Amount
forall a b. (a -> b) -> a -> b
$ Posting -> MixedAmount
pamount Posting
pr
            matchedamount :: MixedAmount
matchedamount = String -> MixedAmount -> MixedAmount
forall a. Show a => String -> a -> a
dbg6 String
"matchedamount" (MixedAmount -> MixedAmount)
-> (MixedAmount -> MixedAmount) -> MixedAmount -> MixedAmount
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Amount -> Bool) -> MixedAmount -> MixedAmount
filterMixedAmount (Query
symq Query -> Amount -> Bool
`matchesAmount`) (MixedAmount -> MixedAmount) -> MixedAmount -> MixedAmount
forall a b. (a -> b) -> a -> b
$ Posting -> MixedAmount
pamount Posting
p
            -- Handle a matched amount with a total price carefully so as to keep the transaction balanced (#928).
            -- Approach 1: convert to a unit price and increase the display precision slightly
            -- Mixed as = dbg6 "multipliedamount" $ n `multiplyMixedAmount` mixedAmountTotalCostToUnitCost matchedamount
            -- Approach 2: multiply the total price (keeping it positive) as well as the quantity
            as :: MixedAmount
as = String -> MixedAmount -> MixedAmount
forall a. Show a => String -> a -> a
dbg6 String
"multipliedamount" (MixedAmount -> MixedAmount) -> MixedAmount -> MixedAmount
forall a b. (a -> b) -> a -> b
$ Quantity -> MixedAmount -> MixedAmount
multiplyMixedAmount Quantity
n MixedAmount
matchedamount
          in
            case Amount -> TagName
acommodity Amount
pramount of
              TagName
"" -> MixedAmount
as
              -- TODO multipliers with commodity symbols are not yet a documented feature.
              -- For now: in addition to multiplying the quantity, it also replaces the
              -- matched amount's commodity, display style, and price with those of the posting rule.
              TagName
c  -> (Amount -> Amount) -> MixedAmount -> MixedAmount
mapMixedAmount (\Amount
a -> Amount
a{acommodity = c, astyle = astyle pramount, acost = acost pramount}) MixedAmount
as

postingRuleMultiplier :: TMPostingRule -> Maybe Quantity
postingRuleMultiplier :: TMPostingRule -> Maybe Quantity
postingRuleMultiplier TMPostingRule
tmpr = case MixedAmount -> [Amount]
amountsRaw (MixedAmount -> [Amount])
-> (Posting -> MixedAmount) -> Posting -> [Amount]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Posting -> MixedAmount
pamount (Posting -> [Amount]) -> Posting -> [Amount]
forall a b. (a -> b) -> a -> b
$ TMPostingRule -> Posting
tmprPosting TMPostingRule
tmpr of
    [Amount
a] | TMPostingRule -> Bool
tmprIsMultiplier TMPostingRule
tmpr -> Quantity -> Maybe Quantity
forall a. a -> Maybe a
Just (Quantity -> Maybe Quantity) -> Quantity -> Maybe Quantity
forall a b. (a -> b) -> a -> b
$ Amount -> Quantity
aquantity Amount
a
    [Amount]
_                           -> Maybe Quantity
forall a. Maybe a
Nothing

renderPostingCommentDates :: Posting -> Posting
renderPostingCommentDates :: Posting -> Posting
renderPostingCommentDates Posting
p = Posting
p { pcomment = comment' }
    where
        dates :: TagName
dates = [TagName] -> TagName
T.concat ([TagName] -> TagName) -> [TagName] -> TagName
forall a b. (a -> b) -> a -> b
$ [Maybe TagName] -> [TagName]
forall a. [Maybe a] -> [a]
catMaybes [Day -> TagName
showDate (Day -> TagName) -> Maybe Day -> Maybe TagName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Posting -> Maybe Day
pdate Posting
p, (TagName
"=" TagName -> TagName -> TagName
forall a. Semigroup a => a -> a -> a
<>) (TagName -> TagName) -> (Day -> TagName) -> Day -> TagName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> TagName
showDate (Day -> TagName) -> Maybe Day -> Maybe TagName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Posting -> Maybe Day
pdate2 Posting
p]
        comment' :: TagName
comment'
            | TagName -> Bool
T.null TagName
dates = Posting -> TagName
pcomment Posting
p
            | Bool
otherwise    = (TagName -> TagName -> TagName -> TagName
wrap TagName
"[" TagName
"]" TagName
dates) TagName -> TagName -> TagName
`commentJoin` Posting -> TagName
pcomment Posting
p