{-# 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.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 -> [TransactionModifier] -> [Transaction]
                   -> Either String [Transaction]
modifyTransactions :: (TagName -> Maybe AccountType)
-> (TagName -> [Tag])
-> Map TagName AmountStyle
-> Day
-> [TransactionModifier]
-> [Transaction]
-> Either String [Transaction]
modifyTransactions TagName -> Maybe AccountType
atypes TagName -> [Tag]
atags Map TagName AmountStyle
styles Day
d [TransactionModifier]
tmods [Transaction]
ts = do
  [Transaction -> Transaction]
fs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((TagName -> Maybe AccountType)
-> (TagName -> [Tag])
-> Map TagName AmountStyle
-> Day
-> TransactionModifier
-> Either String (Transaction -> Transaction)
transactionModifierToFunction TagName -> Maybe AccountType
atypes TagName -> [Tag]
atags Map TagName 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' = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall b c a. (b -> c) -> (a -> b) -> a -> c
(.)) forall a. a -> a
id [Transaction -> Transaction]
fs Transaction
t  -- apply each function in turn
        t'' :: Transaction
t'' = if Transaction
t' forall a. Eq a => a -> a -> Bool
== Transaction
t  -- and add some tags if it was changed
              then Transaction
t'
              else Transaction
t'{tcomment :: TagName
tcomment=Transaction -> TagName
tcomment Transaction
t' TagName -> Tag -> TagName
`commentAddTag` (TagName
"modified",TagName
""), ttags :: [Tag]
ttags=(TagName
"modified",TagName
"") forall a. a -> [a] -> [a]
: Transaction -> [Tag]
ttags Transaction
t'}
  forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ 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
-- >>> 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 -> TransactionModifier
                              -> Either String (Transaction -> Transaction)
transactionModifierToFunction :: (TagName -> Maybe AccountType)
-> (TagName -> [Tag])
-> Map TagName AmountStyle
-> Day
-> TransactionModifier
-> Either String (Transaction -> Transaction)
transactionModifierToFunction TagName -> Maybe AccountType
atypes TagName -> [Tag]
atags Map TagName AmountStyle
styles Day
refdate TransactionModifier{TagName
tmquerytxt :: TransactionModifier -> TagName
tmquerytxt :: TagName
tmquerytxt, [TMPostingRule]
tmpostingrules :: TransactionModifier -> [TMPostingRule]
tmpostingrules :: [TMPostingRule]
tmpostingrules} = do
  Query
q <- Query -> Query
simplifyQuery forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst 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 = forall a b. (a -> b) -> [a] -> [b]
map (\TMPostingRule
tmpr -> Posting -> Posting
addAccountTags forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map TagName AmountStyle
-> Query -> TagName -> TMPostingRule -> Posting -> Posting
tmPostingRuleToFunction 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 forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (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 [])
  forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ \t :: Transaction
t@(Transaction -> [Posting]
tpostings -> [Posting]
ps) -> Transaction -> Transaction
txnTieKnot Transaction
t{tpostings :: [Posting]
tpostings=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 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 TagName AmountStyle
-> Query -> TagName -> TMPostingRule -> Posting -> Posting
tmPostingRuleToFunction Map TagName AmountStyle
styles Query
query TagName
querytxt TMPostingRule
tmpr =
  \Posting
p -> Map TagName AmountStyle -> Posting -> Posting
postingApplyCommodityStyles Map TagName AmountStyle
styles forall b c a. (b -> c) -> (a -> b) -> a -> c
. Posting -> Posting
renderPostingCommentDates forall a b. (a -> b) -> a -> b
$ Posting
pr
      { pdate :: Maybe Day
pdate    = Posting -> Maybe Day
pdate  Posting
pr 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 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 -> Tag -> TagName
`commentAddTag` (TagName
"generated-posting",TagName
qry)
      , ptags :: [Tag]
ptags    = (TagName
"generated-posting", TagName
qry) forall a. a -> [a] -> [a]
:
                   (TagName
"_generated-posting",TagName
qry) forall a. a -> [a] -> [a]
:
                   Posting -> [Tag]
ptags Posting
pr
      }
  where
    pr :: Posting
pr = TMPostingRule -> Posting
tmprPosting TMPostingRule
tmpr
    qry :: TagName
qry = TagName
"= " forall a. Semigroup a => a -> a -> a
<> TagName
querytxt
    symq :: Query
symq = (Query -> Bool) -> Query -> Query
filterQuery (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 -> forall a b. a -> b -> a
const 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 = forall a. Show a => String -> a -> a
dbg6 String
"pramount" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. MixedAmount -> [Amount]
amountsRaw forall a b. (a -> b) -> a -> b
$ Posting -> MixedAmount
pamount Posting
pr
            matchedamount :: MixedAmount
matchedamount = forall a. Show a => String -> a -> a
dbg6 String
"matchedamount" forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Amount -> Bool) -> MixedAmount -> MixedAmount
filterMixedAmount (Query
symq Query -> Amount -> Bool
`matchesAmount`) 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 = forall a. Show a => String -> a -> a
dbg6 String
"multipliedamount" 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Posting -> MixedAmount
pamount forall a b. (a -> b) -> a -> b
$ TMPostingRule -> Posting
tmprPosting TMPostingRule
tmpr of
    [Amount
a] | TMPostingRule -> Bool
tmprIsMultiplier TMPostingRule
tmpr -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Amount -> Quantity
aquantity Amount
a
    [Amount]
_                           -> 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 forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes [Day -> TagName
showDate forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Posting -> Maybe Day
pdate Posting
p, (TagName
"=" forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> TagName
showDate 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