{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module Hledger.Data.TransactionModifier (
modifyTransactions
)
where
import Control.Applicative ((<|>), liftA2)
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)
import Hledger.Utils (dbg6, wrap)
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
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
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 :: 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
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 (Query -> Text -> TMPostingRule -> TMPostingRule -> TMPostingRule
tmPostingRuleToFunction Query
q Text
tmquerytxt) [TMPostingRule]
tmpostingrules
generatePostings :: t TMPostingRule -> [TMPostingRule]
generatePostings t TMPostingRule
ps = (TMPostingRule -> [TMPostingRule])
-> t TMPostingRule -> [TMPostingRule]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\TMPostingRule
p -> TMPostingRule
p TMPostingRule -> [TMPostingRule] -> [TMPostingRule]
forall a. a -> [a] -> [a]
: ((TMPostingRule -> TMPostingRule) -> TMPostingRule)
-> [TMPostingRule -> TMPostingRule] -> [TMPostingRule]
forall a b. (a -> b) -> [a] -> [b]
map ((TMPostingRule -> TMPostingRule) -> TMPostingRule -> TMPostingRule
forall a b. (a -> b) -> a -> b
$TMPostingRule
p) (if Query
q Query -> TMPostingRule -> Bool
`matchesPosting` TMPostingRule
p then [TMPostingRule -> TMPostingRule]
fs else [])) t TMPostingRule
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 -> [TMPostingRule]
tpostings -> [TMPostingRule]
ps) -> Transaction -> Transaction
txnTieKnot Transaction
t{tpostings :: [TMPostingRule]
tpostings=[TMPostingRule] -> [TMPostingRule]
forall (t :: * -> *).
Foldable t =>
t TMPostingRule -> [TMPostingRule]
generatePostings [TMPostingRule]
ps}
tmPostingRuleToFunction :: Query -> T.Text -> TMPostingRule -> (Posting -> Posting)
tmPostingRuleToFunction :: Query -> Text -> TMPostingRule -> TMPostingRule -> TMPostingRule
tmPostingRuleToFunction Query
query 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
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' :: 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 ->
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
$ 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) -> 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
$ TMPostingRule -> MixedAmount
pamount TMPostingRule
p
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 -> Text
acommodity Amount
pramount of
Text
"" -> MixedAmount
as
Text
c -> (Amount -> Amount) -> MixedAmount -> MixedAmount
mapMixedAmount (\Amount
a -> 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}) MixedAmount
as
postingRuleMultiplier :: TMPostingRule -> Maybe Quantity
postingRuleMultiplier :: TMPostingRule -> Maybe Quantity
postingRuleMultiplier TMPostingRule
p = case MixedAmount -> [Amount]
amountsRaw (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
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