mirror of
https://github.com/simonmichael/hledger.git
synced 2024-11-09 21:22:26 +03:00
fix: types: Ensure auto postings can match against and be matched by type: queries.
This requires checking parent accounts for any new accounts introduced by auto postings which do not exist in the original journal. Also refactor journalFinalise to only call journalPostingsAddAccountTags once, and use fewer intermediate variables.
This commit is contained in:
Stephen Morgan
Simon Michael
parent
a16c88b1b1
commit
73925ae965
@ -21,6 +21,7 @@ module Hledger.Data.AccountName (
|
||||
,accountNameTreeFrom
|
||||
,accountSummarisedName
|
||||
,accountNameInferType
|
||||
,accountNameType
|
||||
,assetAccountRegex
|
||||
,cashAccountRegex
|
||||
,liabilityAccountRegex
|
||||
@ -48,8 +49,10 @@ module Hledger.Data.AccountName (
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Foldable (toList)
|
||||
import Control.Applicative ((<|>))
|
||||
import Data.Foldable (asum, toList)
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.Set as S
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
@ -113,6 +116,13 @@ accountNameInferType a
|
||||
| regexMatchText expenseAccountRegex a = Just Expense
|
||||
| otherwise = Nothing
|
||||
|
||||
-- Extract the 'AccountType' of an 'AccountName' by looking it up in the
|
||||
-- provided Map, traversing the parent accounts if necessary. If none of those
|
||||
-- work, try 'accountNameInferType'.
|
||||
accountNameType :: M.Map AccountName AccountType -> AccountName -> Maybe AccountType
|
||||
accountNameType atypes a = asum (map (`M.lookup` atypes) $ a : parentAccountNames a)
|
||||
<|> accountNameInferType a
|
||||
|
||||
accountNameLevel :: AccountName -> Int
|
||||
accountNameLevel "" = 0
|
||||
accountNameLevel a = T.length (T.filter (==acctsepchar) a) + 1
|
||||
|
||||
@ -2,6 +2,7 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE Rank2Types #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
{-|
|
||||
|
||||
@ -76,7 +77,11 @@ module Hledger.Data.Journal (
|
||||
journalPrevTransaction,
|
||||
journalPostings,
|
||||
journalTransactionsSimilarTo,
|
||||
journalAccountType,
|
||||
-- * Account types
|
||||
journalAccountType,
|
||||
journalAccountTypes,
|
||||
journalAddAccountTypes,
|
||||
journalPostingsAddAccountTags,
|
||||
-- journalPrices,
|
||||
-- * Standard account types
|
||||
journalBalanceSheetAccountQuery,
|
||||
@ -120,7 +125,7 @@ import qualified Data.Text as T
|
||||
import Safe (headMay, headDef, maximumMay, minimumMay)
|
||||
import Data.Time.Calendar (Day, addDays, fromGregorian)
|
||||
import Data.Time.Clock.POSIX (POSIXTime)
|
||||
import Data.Tree (Tree, flatten)
|
||||
import Data.Tree (Tree(..), flatten)
|
||||
import Text.Printf (printf)
|
||||
import Text.Megaparsec (ParsecT)
|
||||
import Text.Megaparsec.Custom (FinalParseError)
|
||||
@ -550,7 +555,43 @@ journalConversionAccount =
|
||||
-- Newer account type functionality.
|
||||
|
||||
journalAccountType :: Journal -> AccountName -> Maybe AccountType
|
||||
journalAccountType Journal{jaccounttypes} a = M.lookup a jaccounttypes
|
||||
journalAccountType Journal{jaccounttypes} = accountNameType jaccounttypes
|
||||
|
||||
-- | Add a map of all known account types to the journal.
|
||||
journalAddAccountTypes :: Journal -> Journal
|
||||
journalAddAccountTypes j = j{jaccounttypes = journalAccountTypes j}
|
||||
|
||||
-- | Build a map of all known account types, explicitly declared
|
||||
-- or inferred from the account's parent or name.
|
||||
journalAccountTypes :: Journal -> M.Map AccountName AccountType
|
||||
journalAccountTypes j = M.fromList [(a,acctType) | (a, Just (acctType,_)) <- flatten t']
|
||||
where
|
||||
t = accountNameTreeFrom $ journalAccountNames j :: Tree AccountName
|
||||
t' = settypes Nothing t :: Tree (AccountName, Maybe (AccountType, Bool))
|
||||
-- Map from the top of the account tree down to the leaves, propagating
|
||||
-- account types downward. Keep track of whether the account is declared
|
||||
-- (True), in which case the parent account should be preferred, or merely
|
||||
-- inferred (False), in which case the inferred type should be preferred.
|
||||
settypes :: Maybe (AccountType, Bool) -> Tree AccountName -> Tree (AccountName, Maybe (AccountType, Bool))
|
||||
settypes mparenttype (Node a subs) = Node (a, mtype) (map (settypes mtype) subs)
|
||||
where
|
||||
mtype = M.lookup a declaredtypes <|> minferred
|
||||
minferred = if maybe False snd mparenttype
|
||||
then mparenttype
|
||||
else (,False) <$> accountNameInferType a <|> mparenttype
|
||||
declaredtypes = (,True) <$> journalDeclaredAccountTypes j
|
||||
|
||||
-- | Build a map of the account types explicitly declared.
|
||||
journalDeclaredAccountTypes :: Journal -> M.Map AccountName AccountType
|
||||
journalDeclaredAccountTypes Journal{jdeclaredaccounttypes} =
|
||||
M.fromList $ concat [map (,t) as | (t,as) <- M.toList jdeclaredaccounttypes]
|
||||
|
||||
-- | To all postings in the journal, add any tags from their account
|
||||
-- (including those inherited from parent accounts).
|
||||
-- If the same tag exists on posting and account, the latter is ignored.
|
||||
journalPostingsAddAccountTags :: Journal -> Journal
|
||||
journalPostingsAddAccountTags j = journalMapPostings addtags j
|
||||
where addtags p = p `postingAddTags` (journalInheritedAccountTags j $ paccount p)
|
||||
|
||||
-- Various kinds of filtering on journals. We do it differently depending
|
||||
-- on the command.
|
||||
@ -560,12 +601,12 @@ journalAccountType Journal{jaccounttypes} a = M.lookup a jaccounttypes
|
||||
|
||||
-- | Keep only transactions matching the query expression.
|
||||
filterJournalTransactions :: Query -> Journal -> Journal
|
||||
filterJournalTransactions q j@Journal{jaccounttypes, jtxns} = j{jtxns=filter (matchesTransactionExtra q (Just jaccounttypes)) jtxns}
|
||||
filterJournalTransactions q j@Journal{jtxns} = j{jtxns=filter (matchesTransactionExtra (journalAccountType j) q) jtxns}
|
||||
|
||||
-- | Keep only postings matching the query expression.
|
||||
-- This can leave unbalanced transactions.
|
||||
filterJournalPostings :: Query -> Journal -> Journal
|
||||
filterJournalPostings q j@Journal{jtxns=ts} = j{jtxns=map (filterTransactionPostingsExtra (jaccounttypes j) q) ts}
|
||||
filterJournalPostings q j@Journal{jtxns=ts} = j{jtxns=map (filterTransactionPostingsExtra (journalAccountType j) q) ts}
|
||||
|
||||
-- | Keep only postings which do not match the query expression, but for which a related posting does.
|
||||
-- This can leave unbalanced transactions.
|
||||
@ -597,9 +638,9 @@ filterTransactionPostings :: Query -> Transaction -> Transaction
|
||||
filterTransactionPostings q t@Transaction{tpostings=ps} = t{tpostings=filter (q `matchesPosting`) ps}
|
||||
|
||||
-- Like filterTransactionPostings, but is given the map of account types so can also filter by account type.
|
||||
filterTransactionPostingsExtra :: M.Map AccountName AccountType -> Query -> Transaction -> Transaction
|
||||
filterTransactionPostingsExtra :: (AccountName -> Maybe AccountType) -> Query -> Transaction -> Transaction
|
||||
filterTransactionPostingsExtra atypes q t@Transaction{tpostings=ps} =
|
||||
t{tpostings=filter (\p -> matchesPostingExtra q (M.lookup (paccount p) atypes) p) ps}
|
||||
t{tpostings=filter (matchesPostingExtra atypes q) ps}
|
||||
|
||||
filterTransactionRelatedPostings :: Query -> Transaction -> Transaction
|
||||
filterTransactionRelatedPostings q t@Transaction{tpostings=ps} =
|
||||
@ -783,7 +824,7 @@ journalUntieTransactions t@Transaction{tpostings=ps} = t{tpostings=map (\p -> p{
|
||||
-- relative dates in transaction modifier queries.
|
||||
journalModifyTransactions :: Day -> Journal -> Either String Journal
|
||||
journalModifyTransactions d j =
|
||||
case modifyTransactions (journalCommodityStyles j) d (jtxnmodifiers j) (jtxns j) of
|
||||
case modifyTransactions (journalAccountType j) (journalInheritedAccountTags j) (journalCommodityStyles j) d (jtxnmodifiers j) (jtxns j) of
|
||||
Right ts -> Right j{jtxns=ts}
|
||||
Left err -> Left err
|
||||
|
||||
|
||||
@ -18,12 +18,12 @@ 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.Dates
|
||||
import Hledger.Data.Transaction (txnTieKnot)
|
||||
import Hledger.Query (Query, filterQuery, matchesAmount, matchesPosting,
|
||||
import Hledger.Query (Query, filterQuery, matchesAmount, matchesPostingExtra,
|
||||
parseQuery, queryIsAmt, queryIsSym, simplifyQuery)
|
||||
import Hledger.Data.Posting (commentJoin, commentAddTag, postingApplyCommodityStyles)
|
||||
import Hledger.Data.Posting (commentJoin, commentAddTag, postingAddTags, postingApplyCommodityStyles)
|
||||
import Hledger.Utils (dbg6, wrap)
|
||||
|
||||
-- $setup
|
||||
@ -36,9 +36,13 @@ import Hledger.Utils (dbg6, wrap)
|
||||
-- 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 styles d tmods ts = do
|
||||
fs <- mapM (transactionModifierToFunction styles d) tmods -- convert modifiers to functions, or return a parse error
|
||||
modifyTransactions :: (AccountName -> Maybe AccountType)
|
||||
-> (AccountName -> [Tag])
|
||||
-> M.Map CommoditySymbol AmountStyle
|
||||
-> Day -> [TransactionModifier] -> [Transaction]
|
||||
-> Either String [Transaction]
|
||||
modifyTransactions atypes atags styles d tmods ts = do
|
||||
fs <- mapM (transactionModifierToFunction atypes atags styles d) tmods -- convert modifiers to functions, or return a parse error
|
||||
let
|
||||
modifytxn t = t''
|
||||
where
|
||||
@ -62,7 +66,7 @@ modifyTransactions styles d tmods ts = do
|
||||
-- >>> 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 = 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
|
||||
@ -78,13 +82,18 @@ modifyTransactions styles d tmods ts = do
|
||||
-- pong $3.00 ; generated-posting: = ping
|
||||
-- <BLANKLINE>
|
||||
--
|
||||
transactionModifierToFunction :: M.Map CommoditySymbol AmountStyle -> Day -> TransactionModifier -> Either String (Transaction -> Transaction)
|
||||
transactionModifierToFunction styles refdate TransactionModifier{tmquerytxt, tmpostingrules} = do
|
||||
transactionModifierToFunction :: (AccountName -> Maybe AccountType)
|
||||
-> (AccountName -> [Tag])
|
||||
-> M.Map CommoditySymbol AmountStyle
|
||||
-> Day -> TransactionModifier
|
||||
-> Either String (Transaction -> Transaction)
|
||||
transactionModifierToFunction atypes atags styles refdate TransactionModifier{tmquerytxt, tmpostingrules} = do
|
||||
q <- simplifyQuery . fst <$> parseQuery refdate tmquerytxt
|
||||
let
|
||||
fs = map (tmPostingRuleToFunction styles q tmquerytxt) tmpostingrules
|
||||
generatePostings = concatMap (\p -> p : map ($ p) (if q `matchesPosting` p then fs else []))
|
||||
Right $ \t@(tpostings -> ps) -> txnTieKnot t{tpostings=generatePostings ps}
|
||||
fs = map (\tmpr -> addAccountTags . tmPostingRuleToFunction styles q tmquerytxt tmpr) tmpostingrules
|
||||
addAccountTags p = p `postingAddTags` atags (paccount p)
|
||||
generatePostings p = p : map ($ p) (if matchesPostingExtra atypes q p then fs else [])
|
||||
Right $ \t@(tpostings -> ps) -> txnTieKnot t{tpostings=concatMap generatePostings 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").
|
||||
|
||||
@ -71,8 +71,6 @@ import Control.Applicative ((<|>), many, optional)
|
||||
import Data.Default (Default(..))
|
||||
import Data.Either (fromLeft, partitionEithers)
|
||||
import Data.List (partition, intercalate)
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe (fromMaybe, isJust, mapMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
@ -673,13 +671,13 @@ matchesAccount _ _ = True
|
||||
-- - If the account's tags are provided, any tag: terms must match
|
||||
-- at least one of them (and any negated tag: terms must match none).
|
||||
--
|
||||
matchesAccountExtra :: Query -> Maybe AccountType -> [Tag] -> AccountName -> Bool
|
||||
matchesAccountExtra (Not q ) mtype mtags a = not $ matchesAccountExtra q mtype mtags a
|
||||
matchesAccountExtra (Or qs) mtype mtags a = any (\q -> matchesAccountExtra q mtype mtags a) qs
|
||||
matchesAccountExtra (And qs) mtype mtags a = all (\q -> matchesAccountExtra q mtype mtags a) qs
|
||||
matchesAccountExtra (Tag npat vpat) _ mtags _ = matchesTags npat vpat mtags
|
||||
matchesAccountExtra (Type ts) matype _ _ = elem matype $ map Just ts
|
||||
matchesAccountExtra q _ _ a = matchesAccount q a
|
||||
matchesAccountExtra :: (AccountName -> Maybe AccountType) -> (AccountName -> [Tag]) -> Query -> AccountName -> Bool
|
||||
matchesAccountExtra atypes atags (Not q ) a = not $ matchesAccountExtra atypes atags q a
|
||||
matchesAccountExtra atypes atags (Or qs) a = any (\q -> matchesAccountExtra atypes atags q a) qs
|
||||
matchesAccountExtra atypes atags (And qs) a = all (\q -> matchesAccountExtra atypes atags q a) qs
|
||||
matchesAccountExtra _ atags (Tag npat vpat) a = matchesTags npat vpat $ atags a
|
||||
matchesAccountExtra atypes _ (Type ts) a = maybe False (`elem` ts) $ atypes a
|
||||
matchesAccountExtra _ _ q a = matchesAccount q a
|
||||
|
||||
-- | Does the match expression match this posting ?
|
||||
-- When matching account name, and the posting has been transformed
|
||||
@ -709,12 +707,12 @@ matchesPosting (Type _) _ = False
|
||||
-- | Like matchesPosting, but if the posting's account's type is provided,
|
||||
-- any type: terms in the query must match it (and any negated type: terms
|
||||
-- must not match it).
|
||||
matchesPostingExtra :: Query -> Maybe AccountType -> Posting -> Bool
|
||||
matchesPostingExtra (Not q ) mtype a = not $ matchesPostingExtra q mtype a
|
||||
matchesPostingExtra (Or qs) mtype a = any (\q -> matchesPostingExtra q mtype a) qs
|
||||
matchesPostingExtra (And qs) mtype a = all (\q -> matchesPostingExtra q mtype a) qs
|
||||
matchesPostingExtra (Type ts) (Just atype) _ = atype `elem` ts
|
||||
matchesPostingExtra q _ p = matchesPosting q p
|
||||
matchesPostingExtra :: (AccountName -> Maybe AccountType) -> Query -> Posting -> Bool
|
||||
matchesPostingExtra atype (Not q ) p = not $ matchesPostingExtra atype q p
|
||||
matchesPostingExtra atype (Or qs) p = any (\q -> matchesPostingExtra atype q p) qs
|
||||
matchesPostingExtra atype (And qs) p = all (\q -> matchesPostingExtra atype q p) qs
|
||||
matchesPostingExtra atype (Type ts) p = maybe False (`elem` ts) . atype $ paccount p
|
||||
matchesPostingExtra _ q p = matchesPosting q p
|
||||
|
||||
-- | Does the match expression match this transaction ?
|
||||
matchesTransaction :: Query -> Transaction -> Bool
|
||||
@ -742,14 +740,12 @@ matchesTransaction (Type _) _ = False
|
||||
-- | Like matchesTransaction, but if the journal's account types are provided,
|
||||
-- any type: terms in the query must match at least one posting's account type
|
||||
-- (and any negated type: terms must match none).
|
||||
matchesTransactionExtra :: Query -> (Maybe (Map AccountName AccountType)) -> Transaction -> Bool
|
||||
matchesTransactionExtra (Not q) mtypes t = not $ matchesTransactionExtra q mtypes t
|
||||
matchesTransactionExtra (Or qs) mtypes t = any (\q -> matchesTransactionExtra q mtypes t) qs
|
||||
matchesTransactionExtra (And qs) mtypes t = all (\q -> matchesTransactionExtra q mtypes t) qs
|
||||
matchesTransactionExtra q@(Type _) (Just atypes) t =
|
||||
any (\p -> matchesPostingExtra q (postingAccountType p) p) $ tpostings t
|
||||
where postingAccountType p = M.lookup (paccount p) atypes
|
||||
matchesTransactionExtra q _ t = matchesTransaction q t
|
||||
matchesTransactionExtra :: (AccountName -> Maybe AccountType) -> Query -> Transaction -> Bool
|
||||
matchesTransactionExtra atype (Not q) t = not $ matchesTransactionExtra atype q t
|
||||
matchesTransactionExtra atype (Or qs) t = any (\q -> matchesTransactionExtra atype q t) qs
|
||||
matchesTransactionExtra atype (And qs) t = all (\q -> matchesTransactionExtra atype q t) qs
|
||||
matchesTransactionExtra atype q@(Type _) t = any (matchesPostingExtra atype q) $ tpostings t
|
||||
matchesTransactionExtra _ q t = matchesTransaction q t
|
||||
|
||||
-- | Does the query match this transaction description ?
|
||||
-- Tests desc: terms, any other terms are ignored.
|
||||
@ -887,8 +883,8 @@ tests_Query = testGroup "Query" [
|
||||
|
||||
,testCase "matchesAccountExtra" $ do
|
||||
let tagq = Tag (toRegexCI' "type") Nothing
|
||||
assertBool "" $ not $ matchesAccountExtra tagq Nothing [] "a"
|
||||
assertBool "" $ matchesAccountExtra tagq Nothing [("type","")] "a"
|
||||
assertBool "" $ not $ matchesAccountExtra (const Nothing) (const []) tagq "a"
|
||||
assertBool "" $ matchesAccountExtra (const Nothing) (const [("type","")]) tagq "a"
|
||||
|
||||
,testGroup "matchesPosting" [
|
||||
testCase "positive match on cleared posting status" $
|
||||
|
||||
@ -152,7 +152,6 @@ import Hledger.Reports.ReportOptions (ReportOpts(..), queryFromFlags, rawOptsToR
|
||||
import Hledger.Utils
|
||||
import Text.Printf (printf)
|
||||
import Hledger.Read.InputOptions
|
||||
import Data.Tree
|
||||
|
||||
--- ** doctest setup
|
||||
-- $setup
|
||||
@ -321,19 +320,17 @@ journalFinalise :: InputOpts -> FilePath -> Text -> ParsedJournal -> ExceptT Str
|
||||
journalFinalise iopts@InputOpts{auto_,infer_equity_,balancingopts_,strict_,_ioDay} f txt pj = do
|
||||
t <- liftIO getPOSIXTime
|
||||
liftEither $ do
|
||||
let pj2 = pj
|
||||
& journalSetLastReadTime t -- save the last read time
|
||||
& journalAddFile (f, txt) -- save the main file's info
|
||||
& journalReverse -- convert all lists to the order they were parsed
|
||||
& journalAddAccountTypes -- build a map of all known account types
|
||||
pj3 <- pj2{jglobalcommoditystyles=fromMaybe mempty $ commodity_styles_ balancingopts_}
|
||||
j <- pj{jglobalcommoditystyles=fromMaybe mempty $ commodity_styles_ balancingopts_}
|
||||
& journalSetLastReadTime t -- save the last read time
|
||||
& journalAddFile (f, txt) -- save the main file's info
|
||||
& journalReverse -- convert all lists to the order they were parsed
|
||||
& journalAddAccountTypes -- build a map of all known account types
|
||||
& journalApplyCommodityStyles -- Infer and apply commodity styles - should be done early
|
||||
j <- pj3
|
||||
& journalPostingsAddAccountTags -- Add account tags to postings' tags
|
||||
& journalAddForecast (forecastPeriod iopts pj3) -- Add forecast transactions if enabled
|
||||
& journalPostingsAddAccountTags -- Add account tags again to affect forecast transactions -- PERF: just to the new transactions ?
|
||||
& (if auto_ && not (null $ jtxnmodifiers pj3) then journalAddAutoPostings _ioDay balancingopts_ else pure) -- Add auto postings if enabled
|
||||
>>= Right . journalPostingsAddAccountTags -- Add account tags again to affect auto postings -- PERF: just to the new postings ?
|
||||
<&> journalAddForecast (forecastPeriod iopts pj) -- Add forecast transactions if enabled
|
||||
<&> journalPostingsAddAccountTags -- Add account tags to postings, so they can be matched by auto postings.
|
||||
>>= (if auto_ && not (null $ jtxnmodifiers pj)
|
||||
then journalAddAutoPostings _ioDay balancingopts_ -- Add auto postings if enabled, and account tags if needed
|
||||
else pure)
|
||||
>>= journalBalanceTransactions balancingopts_ -- Balance all transactions and maybe check balance assertions.
|
||||
<&> (if infer_equity_ then journalAddInferredEquityPostings else id) -- Add inferred equity postings, after balancing transactions and generating auto postings
|
||||
<&> journalInferMarketPricesFromTransactions -- infer market prices from commodity-exchanging transactions
|
||||
@ -342,42 +339,6 @@ journalFinalise iopts@InputOpts{auto_,infer_equity_,balancingopts_,strict_,_ioDa
|
||||
journalCheckCommoditiesDeclared j -- and using declared commodities
|
||||
return j
|
||||
|
||||
-- | Add a map of all known account types to the journal.
|
||||
journalAddAccountTypes :: Journal -> Journal
|
||||
journalAddAccountTypes j = j{jaccounttypes = journalAccountTypes j}
|
||||
|
||||
-- | Build a map of all known account types, explicitly declared
|
||||
-- or inferred from the account's parent or name.
|
||||
journalAccountTypes :: Journal -> M.Map AccountName AccountType
|
||||
journalAccountTypes j = M.fromList [(a,acctType) | (a, Just (acctType,_)) <- flatten t']
|
||||
where
|
||||
t = accountNameTreeFrom $ journalAccountNames j :: Tree AccountName
|
||||
t' = settypes Nothing t :: Tree (AccountName, Maybe (AccountType, Bool))
|
||||
-- Map from the top of the account tree down to the leaves, propagating
|
||||
-- account types downward. Keep track of whether the account is declared
|
||||
-- (True), in which case the parent account should be preferred, or merely
|
||||
-- inferred (False), in which case the inferred type should be preferred.
|
||||
settypes :: Maybe (AccountType, Bool) -> Tree AccountName -> Tree (AccountName, Maybe (AccountType, Bool))
|
||||
settypes mparenttype (Node a subs) = Node (a, mtype) (map (settypes mtype) subs)
|
||||
where
|
||||
mtype = M.lookup a declaredtypes <|> minferred
|
||||
minferred = if maybe False snd mparenttype
|
||||
then mparenttype
|
||||
else (,False) <$> accountNameInferType a <|> mparenttype
|
||||
declaredtypes = (,True) <$> journalDeclaredAccountTypes j
|
||||
|
||||
-- | Build a map of the account types explicitly declared.
|
||||
journalDeclaredAccountTypes :: Journal -> M.Map AccountName AccountType
|
||||
journalDeclaredAccountTypes Journal{jdeclaredaccounttypes} =
|
||||
M.fromList $ concat [map (,t) as | (t,as) <- M.toList jdeclaredaccounttypes]
|
||||
|
||||
-- | To all postings in the journal, add any tags from their account
|
||||
-- (including those inherited from parent accounts).
|
||||
-- If the same tag exists on posting and account, the latter is ignored.
|
||||
journalPostingsAddAccountTags :: Journal -> Journal
|
||||
journalPostingsAddAccountTags j = journalMapPostings addtags j
|
||||
where addtags p = p `postingAddTags` (journalInheritedAccountTags j $ paccount p)
|
||||
|
||||
-- | Apply any auto posting rules to generate extra postings on this journal's transactions.
|
||||
journalAddAutoPostings :: Day -> BalancingOpts -> Journal -> Either String Journal
|
||||
journalAddAutoPostings d bopts =
|
||||
|
||||
@ -171,9 +171,9 @@ compoundBalanceReportWith rspec' j priceoracle subreportspecs = cbr
|
||||
ropts = cbcsubreportoptions $ _rsReportOpts rspec
|
||||
rspecsub = rspec{_rsReportOpts=ropts, _rsQuery=And [q, _rsQuery rspec]}
|
||||
-- Starting balances and column postings specific to this subreport.
|
||||
startbals' = startingBalances rspecsub j priceoracle $
|
||||
filter (\p -> matchesPostingExtra q (journalAccountType j (paccount p)) p) startps
|
||||
colps' = map (second $ filter (\p -> matchesPostingExtra q (journalAccountType j (paccount p)) p)) colps
|
||||
startbals' = startingBalances rspecsub j priceoracle $
|
||||
filter (matchesPostingExtra (journalAccountType j) q) startps
|
||||
colps' = map (second $ filter (matchesPostingExtra (journalAccountType j) q)) colps
|
||||
|
||||
-- Sum the subreport totals by column. Handle these cases:
|
||||
-- - no subreports
|
||||
@ -287,9 +287,7 @@ acctChanges ReportSpec{_rsQuery=query,_rsReportOpts=ReportOpts{accountlistmode_,
|
||||
declaredacctps =
|
||||
[nullposting{paccount=a}
|
||||
| a <- journalLeafAccountNamesDeclared j
|
||||
, let mtype = journalAccountType j a
|
||||
, let atags = M.findWithDefault [] a $ jdeclaredaccounttags j
|
||||
, matchesAccountExtra accttypetagsq mtype atags a
|
||||
, matchesAccountExtra (journalAccountType j) (journalAccountTags j) accttypetagsq a
|
||||
]
|
||||
where
|
||||
accttypetagsq = dbg3 "accttypetagsq" $
|
||||
|
||||
@ -60,7 +60,7 @@ accounts CliOpts{rawopts_=rawopts, reportspec_=ReportSpec{_rsQuery=query,_rsRepo
|
||||
depth = dbg1 "depth" $ queryDepth $ filterQuery queryIsDepth query
|
||||
matcheddeclaredaccts =
|
||||
dbg1 "matcheddeclaredaccts" $
|
||||
filter (\a -> matchesAccountExtra nodepthq (journalAccountType j a) (journalInheritedAccountTags j a) a)
|
||||
filter (matchesAccountExtra (journalAccountType j) (journalInheritedAccountTags j) nodepthq)
|
||||
$ map fst $ jdeclaredaccounts j
|
||||
matchedusedaccts = dbg5 "matchedusedaccts" $ map paccount $ journalPostings $ filterJournalPostings nodepthq j
|
||||
accts = dbg5 "accts to show" $ -- no need to nub/sort, accountTree will
|
||||
|
||||
@ -41,7 +41,7 @@ rewrite opts@CliOpts{rawopts_=rawopts,reportspec_=rspec} j@Journal{jtxns=ts} = d
|
||||
-- rewrite matched transactions
|
||||
let today = _rsDay rspec
|
||||
let modifiers = transactionModifierFromOpts opts : jtxnmodifiers j
|
||||
let j' = j{jtxns=either error' id $ modifyTransactions mempty today modifiers ts} -- PARTIAL:
|
||||
let j' = j{jtxns=either error' id $ modifyTransactions (journalAccountType j) (journalInheritedAccountTags j) mempty today modifiers ts} -- PARTIAL:
|
||||
-- run the print command, showing all transactions, or show diffs
|
||||
printOrDiff rawopts opts{reportspec_=rspec{_rsQuery=Any}} j j'
|
||||
|
||||
|
||||
@ -95,3 +95,28 @@ $ hledger -f- accounts type:v
|
||||
equity:conversion
|
||||
equity:trading
|
||||
equity:trade
|
||||
|
||||
# 13. type: can be used in and can match auto postings
|
||||
<
|
||||
account assets ; type:a
|
||||
|
||||
= type:a
|
||||
(assets:b) 1
|
||||
|
||||
2022-02-02 Test
|
||||
(assets) 2
|
||||
|
||||
$ hledger -f- reg --auto type:a
|
||||
2022-02-02 Test (assets) 2 2
|
||||
(assets:b) 1 3
|
||||
|
||||
# 14. type: can be used in and can match auto postings with no known parents
|
||||
<
|
||||
= type:a
|
||||
(expenses:b) 1
|
||||
|
||||
2022-02-02 Test
|
||||
(assets) 2
|
||||
|
||||
$ hledger -f- reg --auto type:x
|
||||
2022-02-02 Test (expenses:b) 1 1
|
||||
|
||||
Loading…
Reference in New Issue
Block a user