    {-# 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 Hledger.Data.Types
    import Hledger.Data.Amount
    import Hledger.Data.Dates
    import Hledger.Data.Transaction (txnTieKnot)
    import Hledger.Query (Query, filterQuery, matchesAmount, matchesPostingExtra,
                          parseQuery, queryIsAmt, queryIsSym, simplifyQuery)
    import Hledger.Data.Posting (commentJoin, commentAddTag, postingAddTags, postingApplyCommodityStyles)
    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''
          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
            t'' :: Transaction
    t'' = if Transaction
    t' Transaction -> Transaction -> Bool
    forall a. Eq a => a -> a -> Bool
    == Transaction
    t
                  then Transaction
    t'
                  else Transaction
    t'{tcomment :: TagName
    tcomment=Transaction -> TagName
    tcomment Transaction
    t' TagName -> (TagName -> TagName) -> TagName
    forall a b. a -> (a -> b) -> b
    & (if Bool
    verbosetags then (TagName -> Tag -> TagName
    `commentAddTag` (TagName
    "modified",TagName
    "")) else TagName -> TagName
    forall a. a -> a
    id)
                         ,ttags :: [Tag]
    ttags=Transaction -> [Tag]
    ttags Transaction
    t' [Tag] -> ([Tag] -> [Tag]) -> [Tag]
    forall a b. a -> (a -> b) -> b
    & ((TagName
    "_modified",TagName
    "") Tag -> [Tag] -> [Tag]
    forall a. a -> [a] -> [a]
    :) [Tag] -> ([Tag] -> [Tag]) -> [Tag]
    forall a b. a -> (a -> b) -> b
    & (if Bool
    verbosetags then ((TagName
    "modified",TagName
    "") Tag -> [Tag] -> [Tag]
    forall a. a -> [a] -> [a]
    :) else [Tag] -> [Tag]
    forall a. a -> a
    id)
                         }

      [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 :: [Posting]
    tpostings=(Posting -> [Posting]) -> [Posting] -> [Posting]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap Posting -> [Posting]
    generatePostings [Posting]
    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
    postingApplyCommodityStyles 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 :: Maybe Day
    pdate    = Posting -> Maybe Day
    pdate  Posting
    pr Maybe Day -> Maybe Day -> Maybe Day
    forall a. Maybe a -> Maybe a -> Maybe a
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
    <|> Posting -> Maybe Day
    pdate  Posting
    p
          , pdate2 :: Maybe Day
    pdate2   = Posting -> Maybe Day
    pdate2 Posting
    pr Maybe Day -> Maybe Day -> Maybe Day
    forall a. Maybe a -> Maybe a -> Maybe a
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
    <|> Posting -> Maybe Day
    pdate2 Posting
    p
          , pamount :: MixedAmount
    pamount  = Posting -> MixedAmount
    amount' Posting
    p
          , pcomment :: TagName
    pcomment = Posting -> TagName
    pcomment Posting
    pr TagName -> (TagName -> TagName) -> TagName
    forall a b. a -> (a -> b) -> b
    & (if Bool
    verbosetags then (TagName -> Tag -> TagName
    `commentAddTag` (TagName
    "generated-posting",TagName
    qry)) else TagName -> TagName
    forall a. a -> a
    id)
          , ptags :: [Tag]
    ptags    = Posting -> [Tag]
    ptags Posting
    pr
                       [Tag] -> ([Tag] -> [Tag]) -> [Tag]
    forall a b. a -> (a -> b) -> b
    & ((TagName
    "_generated-posting",TagName
    qry) Tag -> [Tag] -> [Tag]
    forall a. a -> [a] -> [a]
    :)
                       [Tag] -> ([Tag] -> [Tag]) -> [Tag]
    forall a b. a -> (a -> b) -> b
    & (if Bool
    verbosetags then ((TagName
    "generated-posting", TagName
    qry) Tag -> [Tag] -> [Tag]
    forall a. a -> [a] -> [a]
    :) else [Tag] -> [Tag]
    forall a. a -> a
    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
    forall a. HasCallStack => [a] -> a
    head ([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` mixedAmountTotalPriceToUnitPrice 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 :: TagName
    acommodity = TagName
    c, astyle :: AmountStyle
    astyle = Amount -> AmountStyle
    astyle Amount
    pramount, aprice :: Maybe AmountPrice
    aprice = Amount -> Maybe AmountPrice
    aprice Amount
    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 :: TagName
    pcomment = TagName
    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