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

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 ((<|>))
import Data.Maybe
#if !(MIN_VERSION_base(4,11,0))
import Data.Monoid ((<>))
#endif
import qualified Data.Text as T
import Data.Time.Calendar
import Hledger.Data.Types
import Hledger.Data.Dates
import Hledger.Data.Amount
import Hledger.Data.Transaction
import Hledger.Query
import Hledger.Data.Posting (commentJoin, commentAddTag)
import Hledger.Utils

-- $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 :: Day -> [TransactionModifier] -> [Transaction] -> Either String [Transaction]
modifyTransactions :: Day
-> [TransactionModifier]
-> [Transaction]
-> Either String [Transaction]
modifyTransactions 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 (Day
-> TransactionModifier
-> Either String (Transaction -> Transaction)
transactionModifierToFunction 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 :: Text
tcomment=Transaction -> Text
tcomment Transaction
t' Text -> Tag -> Text
`commentAddTag` (Text
"modified",Text
""), ttags :: [Tag]
ttags=(Text
"modified",Text
"") 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.
--
-- >>> t = nulltransaction{tpostings=["ping" `post` usd 1]}
-- >>> import qualified Data.Text.IO as T
-- >>> test = either putStr (T.putStr.showTransaction) . fmap ($ t) . transactionModifierToFunction nulldate
-- >>> test $ TransactionModifier "" ["pong" `post` usd 2]
-- 0000-01-01
--     ping           $1.00
--     pong           $2.00  ; generated-posting: =
-- <BLANKLINE>
-- >>> test $ TransactionModifier "miss" ["pong" `post` usd 2]
-- 0000-01-01
--     ping           $1.00
-- <BLANKLINE>
-- >>> test $ TransactionModifier "ping" ["pong" `post` amount{aismultiplier=True, aquantity=3}]
-- 0000-01-01
--     ping           $1.00
--     pong           $3.00  ; generated-posting: = ping
-- <BLANKLINE>
--
transactionModifierToFunction :: Day -> TransactionModifier -> Either String (Transaction -> Transaction)
transactionModifierToFunction :: Day
-> TransactionModifier
-> Either String (Transaction -> Transaction)
transactionModifierToFunction Day
refdate TransactionModifier{Text
tmquerytxt :: TransactionModifier -> Text
tmquerytxt :: Text
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 -> Text -> Either String (Query, [QueryOpt])
parseQuery Day
refdate Text
tmquerytxt
  let
    fs :: [TMPostingRule -> TMPostingRule]
fs = (TMPostingRule -> TMPostingRule -> TMPostingRule)
-> [TMPostingRule] -> [TMPostingRule -> TMPostingRule]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> TMPostingRule -> TMPostingRule -> TMPostingRule
tmPostingRuleToFunction Text
tmquerytxt) [TMPostingRule]
tmpostingrules
    generatePostings :: [TMPostingRule] -> [TMPostingRule]
generatePostings [TMPostingRule]
ps = [TMPostingRule
p' | TMPostingRule
p <- [TMPostingRule]
ps
                              , TMPostingRule
p' <- if Query
q Query -> TMPostingRule -> Bool
`matchesPosting` TMPostingRule
p then TMPostingRule
pTMPostingRule -> [TMPostingRule] -> [TMPostingRule]
forall a. a -> [a] -> [a]
:[TMPostingRule -> TMPostingRule
f TMPostingRule
p | TMPostingRule -> TMPostingRule
f <- [TMPostingRule -> TMPostingRule]
fs] else [TMPostingRule
p]]
  (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 -> [TMPostingRule]
tpostings -> [TMPostingRule]
ps) -> Transaction -> Transaction
txnTieKnot Transaction
t{tpostings :: [TMPostingRule]
tpostings=[TMPostingRule] -> [TMPostingRule]
generatePostings [TMPostingRule]
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 :: T.Text -> TMPostingRule -> (Posting -> Posting)
tmPostingRuleToFunction :: Text -> TMPostingRule -> TMPostingRule -> TMPostingRule
tmPostingRuleToFunction Text
querytxt TMPostingRule
pr =
  \TMPostingRule
p -> TMPostingRule -> TMPostingRule
renderPostingCommentDates (TMPostingRule -> TMPostingRule) -> TMPostingRule -> TMPostingRule
forall a b. (a -> b) -> a -> b
$ TMPostingRule
pr
      { pdate :: Maybe Day
pdate    = TMPostingRule -> Maybe Day
pdate  TMPostingRule
pr Maybe Day -> Maybe Day -> Maybe Day
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> TMPostingRule -> Maybe Day
pdate  TMPostingRule
p
      , pdate2 :: Maybe Day
pdate2   = TMPostingRule -> Maybe Day
pdate2 TMPostingRule
pr Maybe Day -> Maybe Day -> Maybe Day
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> TMPostingRule -> Maybe Day
pdate2 TMPostingRule
p
      , pamount :: MixedAmount
pamount  = TMPostingRule -> MixedAmount
amount' TMPostingRule
p
      , pcomment :: Text
pcomment = TMPostingRule -> Text
pcomment TMPostingRule
pr Text -> Tag -> Text
`commentAddTag` (Text
"generated-posting",Text
qry)
      , ptags :: [Tag]
ptags    = (Text
"generated-posting", Text
qry) Tag -> [Tag] -> [Tag]
forall a. a -> [a] -> [a]
:
                   (Text
"_generated-posting",Text
qry) Tag -> [Tag] -> [Tag]
forall a. a -> [a] -> [a]
:
                   TMPostingRule -> [Tag]
ptags TMPostingRule
pr
      }
  where
    qry :: Text
qry = Text
"= " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
querytxt
    amount' :: TMPostingRule -> MixedAmount
amount' = case TMPostingRule -> Maybe Quantity
postingRuleMultiplier TMPostingRule
pr of
        Maybe Quantity
Nothing -> MixedAmount -> TMPostingRule -> MixedAmount
forall a b. a -> b -> a
const (MixedAmount -> TMPostingRule -> MixedAmount)
-> MixedAmount -> TMPostingRule -> MixedAmount
forall a b. (a -> b) -> a -> b
$ TMPostingRule -> MixedAmount
pamount TMPostingRule
pr
        Just Quantity
n  -> \TMPostingRule
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) -> Amount -> Amount
forall a b. (a -> b) -> a -> b
$ [Amount] -> Amount
forall a. [a] -> a
head ([Amount] -> Amount) -> [Amount] -> Amount
forall a b. (a -> b) -> a -> b
$ MixedAmount -> [Amount]
amounts (MixedAmount -> [Amount]) -> MixedAmount -> [Amount]
forall a b. (a -> b) -> a -> b
$ TMPostingRule -> MixedAmount
pamount TMPostingRule
pr
            matchedamount :: MixedAmount
matchedamount = String -> MixedAmount -> MixedAmount
forall a. Show a => String -> a -> a
dbg6 String
"matchedamount" (MixedAmount -> MixedAmount) -> MixedAmount -> MixedAmount
forall a b. (a -> b) -> a -> b
$ TMPostingRule -> MixedAmount
pamount TMPostingRule
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
            Mixed [Amount]
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
n Quantity -> MixedAmount -> MixedAmount
`multiplyMixedAmount` MixedAmount
matchedamount
          in
            case Amount -> Text
acommodity Amount
pramount of
              Text
"" -> [Amount] -> MixedAmount
Mixed [Amount]
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.
              Text
c  -> [Amount] -> MixedAmount
Mixed [Amount
a{acommodity :: Text
acommodity = Text
c, astyle :: AmountStyle
astyle = Amount -> AmountStyle
astyle Amount
pramount, aprice :: Maybe AmountPrice
aprice = Amount -> Maybe AmountPrice
aprice Amount
pramount} | Amount
a <- [Amount]
as]

postingRuleMultiplier :: TMPostingRule -> Maybe Quantity
postingRuleMultiplier :: TMPostingRule -> Maybe Quantity
postingRuleMultiplier TMPostingRule
p =
    case MixedAmount -> [Amount]
amounts (MixedAmount -> [Amount]) -> MixedAmount -> [Amount]
forall a b. (a -> b) -> a -> b
$ TMPostingRule -> MixedAmount
pamount TMPostingRule
p of
        [Amount
a] | Amount -> Bool
aismultiplier Amount
a -> 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 :: TMPostingRule -> TMPostingRule
renderPostingCommentDates TMPostingRule
p = TMPostingRule
p { pcomment :: Text
pcomment = Text
comment' }
    where
        dates :: Text
dates = [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Maybe Text] -> [Text]
forall a. [Maybe a] -> [a]
catMaybes [Day -> Text
showDate (Day -> Text) -> Maybe Day -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMPostingRule -> Maybe Day
pdate TMPostingRule
p, (Text
"=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (Day -> Text) -> Day -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> Text
showDate (Day -> Text) -> Maybe Day -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMPostingRule -> Maybe Day
pdate2 TMPostingRule
p]
        comment' :: Text
comment'
            | Text -> Bool
T.null Text
dates = TMPostingRule -> Text
pcomment TMPostingRule
p
            | Bool
otherwise    = (Text -> Text -> Text -> Text
wrap Text
"[" Text
"]" Text
dates) Text -> Text -> Text
`commentJoin` TMPostingRule -> Text
pcomment TMPostingRule
p