{-# 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 Control.Applicative ((<|>), liftA2)
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.Dates
import Hledger.Data.Amount
import Hledger.Data.Transaction (txnTieKnot)
import Hledger.Query (Query, filterQuery, matchesAmount, matchesPosting,
                      parseQuery, queryIsAmt, queryIsSym, simplifyQuery)
import Hledger.Data.Posting (commentJoin, commentAddTag, 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 :: M.Map CommoditySymbol AmountStyle -> Day -> [TransactionModifier] -> [Transaction] -> Either String [Transaction]
modifyTransactions :: Map CommoditySymbol AmountStyle
-> Day
-> [TransactionModifier]
-> [Transaction]
-> Either String [Transaction]
modifyTransactions Map CommoditySymbol AmountStyle
styles Day
d [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)
mapM (Map CommoditySymbol AmountStyle
-> Day
-> TransactionModifier
-> Either String (Transaction -> Transaction)
transactionModifierToFunction Map CommoditySymbol AmountStyle
styles Day
d) [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 (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  -- and add some tags if it was changed
              then Transaction
t'
              else Transaction
t'{tcomment :: CommoditySymbol
tcomment=Transaction -> CommoditySymbol
tcomment Transaction
t' CommoditySymbol -> Tag -> CommoditySymbol
`commentAddTag` (CommoditySymbol
"modified",CommoditySymbol
""), ttags :: [Tag]
ttags=(CommoditySymbol
"modified",CommoditySymbol
"") Tag -> [Tag] -> [Tag]
forall a. a -> [a] -> [a]
: Transaction -> [Tag]
ttags Transaction
t'}
  [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 mempty nulldate
-- >>> 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` amount{aquantity=3}){tmprIsMultiplier=True}]
-- 0000-01-01
--     ping           $1.00
--     pong           $3.00  ; generated-posting: = ping
-- <BLANKLINE>
--
transactionModifierToFunction :: M.Map CommoditySymbol AmountStyle -> Day -> TransactionModifier -> Either String (Transaction -> Transaction)
transactionModifierToFunction :: Map CommoditySymbol AmountStyle
-> Day
-> TransactionModifier
-> Either String (Transaction -> Transaction)
transactionModifierToFunction Map CommoditySymbol AmountStyle
styles Day
refdate TransactionModifier{CommoditySymbol
tmquerytxt :: TransactionModifier -> CommoditySymbol
tmquerytxt :: CommoditySymbol
tmquerytxt, [TMPostingRule]
tmpostingrules :: TransactionModifier -> [TMPostingRule]
tmpostingrules :: [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 -> CommoditySymbol -> Either String (Query, [QueryOpt])
parseQuery Day
refdate CommoditySymbol
tmquerytxt
  let
    fs :: [Posting -> Posting]
fs = (TMPostingRule -> Posting -> Posting)
-> [TMPostingRule] -> [Posting -> Posting]
forall a b. (a -> b) -> [a] -> [b]
map (Map CommoditySymbol AmountStyle
-> Query -> CommoditySymbol -> TMPostingRule -> Posting -> Posting
tmPostingRuleToFunction Map CommoditySymbol AmountStyle
styles Query
q CommoditySymbol
tmquerytxt) [TMPostingRule]
tmpostingrules
    generatePostings :: t Posting -> [Posting]
generatePostings t Posting
ps = (Posting -> [Posting]) -> t Posting -> [Posting]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\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 Query
q Query -> Posting -> Bool
`matchesPosting` Posting
p then [Posting -> Posting]
fs else [])) t Posting
ps
  (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]
forall (t :: * -> *). Foldable t => t 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 two tags added: a normal generated-posting: tag which also appears in the comment,
-- and a hidden _generated-posting: tag which does not.
-- The TransactionModifier's query text is also provided, and saved
-- as the tags' value.
tmPostingRuleToFunction :: M.Map CommoditySymbol AmountStyle -> Query -> T.Text -> TMPostingRule -> (Posting -> Posting)
tmPostingRuleToFunction :: Map CommoditySymbol AmountStyle
-> Query -> CommoditySymbol -> TMPostingRule -> Posting -> Posting
tmPostingRuleToFunction Map CommoditySymbol AmountStyle
styles Query
query CommoditySymbol
querytxt TMPostingRule
tmpr =
  \Posting
p -> Map CommoditySymbol AmountStyle -> Posting -> Posting
postingApplyCommodityStyles Map CommoditySymbol 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 (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 (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 :: CommoditySymbol
pcomment = Posting -> CommoditySymbol
pcomment Posting
pr CommoditySymbol -> Tag -> CommoditySymbol
`commentAddTag` (CommoditySymbol
"generated-posting",CommoditySymbol
qry)
      , ptags :: [Tag]
ptags    = (CommoditySymbol
"generated-posting", CommoditySymbol
qry) Tag -> [Tag] -> [Tag]
forall a. a -> [a] -> [a]
:
                   (CommoditySymbol
"_generated-posting",CommoditySymbol
qry) Tag -> [Tag] -> [Tag]
forall a. a -> [a] -> [a]
:
                   Posting -> [Tag]
ptags Posting
pr
      }
  where
    pr :: Posting
pr = TMPostingRule -> Posting
tmprPosting TMPostingRule
tmpr
    qry :: CommoditySymbol
qry = CommoditySymbol
"= " CommoditySymbol -> CommoditySymbol -> CommoditySymbol
forall a. Semigroup a => a -> a -> a
<> CommoditySymbol
querytxt
    symq :: Query
symq = (Query -> Bool) -> Query -> Query
filterQuery ((Bool -> Bool -> Bool)
-> (Query -> Bool) -> (Query -> Bool) -> Query -> Bool
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. [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 -> CommoditySymbol
acommodity Amount
pramount of
              CommoditySymbol
"" -> 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.
              CommoditySymbol
c  -> (Amount -> Amount) -> MixedAmount -> MixedAmount
mapMixedAmount (\Amount
a -> Amount
a{acommodity :: CommoditySymbol
acommodity = CommoditySymbol
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 :: CommoditySymbol
pcomment = CommoditySymbol
comment' }
    where
        dates :: CommoditySymbol
dates = [CommoditySymbol] -> CommoditySymbol
T.concat ([CommoditySymbol] -> CommoditySymbol)
-> [CommoditySymbol] -> CommoditySymbol
forall a b. (a -> b) -> a -> b
$ [Maybe CommoditySymbol] -> [CommoditySymbol]
forall a. [Maybe a] -> [a]
catMaybes [Day -> CommoditySymbol
showDate (Day -> CommoditySymbol) -> Maybe Day -> Maybe CommoditySymbol
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Posting -> Maybe Day
pdate Posting
p, (CommoditySymbol
"=" CommoditySymbol -> CommoditySymbol -> CommoditySymbol
forall a. Semigroup a => a -> a -> a
<>) (CommoditySymbol -> CommoditySymbol)
-> (Day -> CommoditySymbol) -> Day -> CommoditySymbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> CommoditySymbol
showDate (Day -> CommoditySymbol) -> Maybe Day -> Maybe CommoditySymbol
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Posting -> Maybe Day
pdate2 Posting
p]
        comment' :: CommoditySymbol
comment'
            | CommoditySymbol -> Bool
T.null CommoditySymbol
dates = Posting -> CommoditySymbol
pcomment Posting
p
            | Bool
otherwise    = (CommoditySymbol
-> CommoditySymbol -> CommoditySymbol -> CommoditySymbol
wrap CommoditySymbol
"[" CommoditySymbol
"]" CommoditySymbol
dates) CommoditySymbol -> CommoditySymbol -> CommoditySymbol
`commentJoin` Posting -> CommoditySymbol
pcomment Posting
p