diff --git a/hledger-lib/Hledger/Data/Journal.hs b/hledger-lib/Hledger/Data/Journal.hs index eb1375fa3..76bb7ff4f 100644 --- a/hledger-lib/Hledger/Data/Journal.hs +++ b/hledger-lib/Hledger/Data/Journal.hs @@ -48,6 +48,8 @@ module Hledger.Data.Journal ( journalAccountNamesDeclaredOrUsed, journalAccountNamesDeclaredOrImplied, journalAccountNames, + journalAccountTags, + journalInheritedAccountTags, -- journalAmountAndPriceCommodities, -- journalAmountStyles, -- overJournalAmounts, @@ -103,7 +105,7 @@ import Control.Monad.State.Strict (StateT) import Data.Char (toUpper, isDigit) import Data.Default (Default(..)) import Data.Foldable (toList) -import Data.List ((\\), find, foldl', sortBy) +import Data.List ((\\), find, foldl', sortBy, union) import Data.List.Extra (nubSort) import qualified Data.Map.Strict as M import Data.Maybe (catMaybes, fromMaybe, mapMaybe, maybeToList) @@ -196,6 +198,7 @@ instance Semigroup Journal where ,jincludefilestack = jincludefilestack j2 ,jdeclaredpayees = jdeclaredpayees j1 <> jdeclaredpayees j2 ,jdeclaredaccounts = jdeclaredaccounts j1 <> jdeclaredaccounts j2 + ,jdeclaredaccounttags = jdeclaredaccounttags j1 <> jdeclaredaccounttags j2 ,jdeclaredaccounttypes = jdeclaredaccounttypes j1 <> jdeclaredaccounttypes j2 ,jglobalcommoditystyles = jglobalcommoditystyles j1 <> jglobalcommoditystyles j2 ,jcommodities = jcommodities j1 <> jcommodities j2 @@ -225,6 +228,7 @@ nulljournal = Journal { ,jincludefilestack = [] ,jdeclaredpayees = [] ,jdeclaredaccounts = [] + ,jdeclaredaccounttags = M.empty ,jdeclaredaccounttypes = M.empty ,jglobalcommoditystyles = M.empty ,jcommodities = M.empty @@ -340,6 +344,18 @@ journalAccountNames = journalAccountNamesDeclaredOrImplied journalAccountNameTree :: Journal -> Tree AccountName journalAccountNameTree = accountNameTreeFrom . journalAccountNamesDeclaredOrImplied +-- | Which tags have been declared for this account, if any ? +journalAccountTags :: Journal -> AccountName -> [Tag] +journalAccountTags Journal{jdeclaredaccounttags} a = M.findWithDefault [] a jdeclaredaccounttags + +-- | Which tags are in effect for this account, including tags inherited from parent accounts ? +journalInheritedAccountTags :: Journal -> AccountName -> [Tag] +journalInheritedAccountTags j a = + foldl' (\ts a -> ts `union` journalAccountTags j a) [] as + where + as = a : parentAccountNames a +-- PERF: cache in journal ? + -- | Find up to N most similar and most recent transactions matching -- the given transaction description and query. Transactions are -- listed with their description's similarity score (see diff --git a/hledger-lib/Hledger/Data/Posting.hs b/hledger-lib/Hledger/Data/Posting.hs index 47553be22..8c6630b5f 100644 --- a/hledger-lib/Hledger/Data/Posting.hs +++ b/hledger-lib/Hledger/Data/Posting.hs @@ -39,6 +39,7 @@ module Hledger.Data.Posting ( postingStripPrices, postingApplyAliases, postingApplyCommodityStyles, + postingAddTags, -- * date operations postingDate, postingDate2, @@ -82,7 +83,7 @@ import Data.Foldable (asum) import qualified Data.Map as M import Data.Maybe (fromMaybe, isJust) import Data.MemoUgly (memo) -import Data.List (foldl', sort) +import Data.List (foldl', sort, union) import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T @@ -445,6 +446,10 @@ postingApplyCommodityStyles styles p = p{pamount=styleMixedAmount styles $ pamou where fixbalanceassertion ba = ba{baamount=styleAmountExceptPrecision styles $ baamount ba} +-- | Add tags to a posting, discarding any for which the posting already has a value. +postingAddTags :: Posting -> [Tag] -> Posting +postingAddTags p@Posting{ptags} tags = p{ptags=ptags `union` tags} + -- | Rewrite an account name using all matching aliases from the given list, in sequence. -- Each alias sees the result of applying the previous aliases. -- Or, return any error arising from a bad regular expression in the aliases. diff --git a/hledger-lib/Hledger/Data/Types.hs b/hledger-lib/Hledger/Data/Types.hs index 0a81effc8..5fc92a6f1 100644 --- a/hledger-lib/Hledger/Data/Types.hs +++ b/hledger-lib/Hledger/Data/Types.hs @@ -362,7 +362,8 @@ data Posting = Posting { pamount :: MixedAmount, pcomment :: Text, -- ^ this posting's comment lines, as a single non-indented multi-line string ptype :: PostingType, - ptags :: [Tag], -- ^ tag names and values, extracted from the comment + ptags :: [Tag], -- ^ tag names and values, extracted from the posting comment + -- and (after finalisation) the posting account's directive if any pbalanceassertion :: Maybe BalanceAssertion, -- ^ an expected balance in the account after this posting, -- in a single commodity, excluding subaccounts. ptransaction :: Maybe Transaction, -- ^ this posting's parent transaction (co-recursive types). @@ -512,6 +513,7 @@ data Journal = Journal { -- principal data ,jdeclaredpayees :: [(Payee,PayeeDeclarationInfo)] -- ^ Payees declared by payee directives, in parse order (after journal finalisation) ,jdeclaredaccounts :: [(AccountName,AccountDeclarationInfo)] -- ^ Accounts declared by account directives, in parse order (after journal finalisation) + ,jdeclaredaccounttags :: M.Map AccountName [Tag] -- ^ Accounts which have tags declared in their directives, and those tags. (Does not include parents' tags.) ,jdeclaredaccounttypes :: M.Map AccountType [AccountName] -- ^ Accounts whose type has been declared in account directives (usually 5 top-level accounts) ,jglobalcommoditystyles :: M.Map CommoditySymbol AmountStyle -- ^ per-commodity display styles declared globally, eg by command line option or import command ,jcommodities :: M.Map CommoditySymbol Commodity -- ^ commodities and formats declared by commodity directives diff --git a/hledger-lib/Hledger/Query.hs b/hledger-lib/Hledger/Query.hs index 662a6cfc2..8391011cb 100644 --- a/hledger-lib/Hledger/Query.hs +++ b/hledger-lib/Hledger/Query.hs @@ -36,6 +36,7 @@ module Hledger.Query ( queryIsSym, queryIsReal, queryIsStatus, + queryIsTag, queryStartDate, queryEndDate, queryDateSpan, @@ -49,6 +50,7 @@ module Hledger.Query ( matchesPayeeWIP, matchesPosting, matchesAccount, + matchesTaggedAccount, matchesMixedAmount, matchesAmount, matchesCommodity, @@ -457,6 +459,10 @@ queryIsStatus :: Query -> Bool queryIsStatus (StatusQ _) = True queryIsStatus _ = False +queryIsTag :: Query -> Bool +queryIsTag (Tag _ _) = True +queryIsTag _ = False + -- | Does this query specify a start date and nothing else (that would -- filter postings prior to the date) ? -- When the flag is true, look for a starting secondary date instead. @@ -562,10 +568,8 @@ inAccountQuery (QueryOptInAcct a : _) = Just . Acct $ accountNameToAccountRe -- matching --- | Does the match expression match this account ? +-- | Does the query match this account name ? -- A matching in: clause is also considered a match. --- When matching by account name pattern, if there's a regular --- expression error, this function calls error. matchesAccount :: Query -> AccountName -> Bool matchesAccount (None) _ = False matchesAccount (Not m) a = not $ matchesAccount m a @@ -576,6 +580,18 @@ matchesAccount (Depth d) a = accountNameLevel a <= d matchesAccount (Tag _ _) _ = False matchesAccount _ _ = True +-- | Does the query match this account's name, and if the query includes +-- tag: terms, do those match at least one of the account's tags ? +matchesTaggedAccount :: Query -> (AccountName,[Tag]) -> Bool +matchesTaggedAccount (None) _ = False +matchesTaggedAccount (Not m) (a,ts) = not $ matchesTaggedAccount m (a,ts) +matchesTaggedAccount (Or ms) (a,ts) = any (`matchesTaggedAccount` (a,ts)) ms +matchesTaggedAccount (And ms) (a,ts) = all (`matchesTaggedAccount` (a,ts)) ms +matchesTaggedAccount (Acct r) (a,_) = regexMatchText r a +matchesTaggedAccount (Depth d) (a,_) = accountNameLevel a <= d +matchesTaggedAccount (Tag namepat mvaluepat) (_,ts) = matchesTags namepat mvaluepat ts +matchesTaggedAccount _ _ = True + matchesMixedAmount :: Query -> MixedAmount -> Bool matchesMixedAmount q ma = case amountsRaw ma of [] -> q `matchesAmount` nullamt @@ -635,7 +651,7 @@ matchesPosting (Sym r) Posting{pamount=as} = any (matchesCommodity (Sym r) . aco matchesPosting (Tag n v) p = case (reString n, v) of ("payee", Just v) -> maybe False (regexMatchText v . transactionPayee) $ ptransaction p ("note", Just v) -> maybe False (regexMatchText v . transactionNote) $ ptransaction p - (_, v) -> matchesTags n v $ postingAllTags p + (_, mv) -> matchesTags n mv $ postingAllTags p -- | Does the match expression match this transaction ? matchesTransaction :: Query -> Transaction -> Bool @@ -801,6 +817,11 @@ tests_Query = testGroup "Query" [ assertBool "" $ Date2 nulldatespan `matchesAccount` "a" assertBool "" $ not $ Tag (toRegex' "a") Nothing `matchesAccount` "a" + ,testCase "matchesTaggedAccount" $ do + let tagq = Tag (toRegexCI' "type") Nothing + assertBool "" $ not $ tagq `matchesTaggedAccount` ("a", []) + assertBool "" $ tagq `matchesTaggedAccount` ("a", [("type","")]) + ,testGroup "matchesPosting" [ testCase "positive match on cleared posting status" $ assertBool "" $ (StatusQ Cleared) `matchesPosting` nullposting{pstatus=Cleared} diff --git a/hledger-lib/Hledger/Read/Common.hs b/hledger-lib/Hledger/Read/Common.hs index c4e45c289..1782bdf60 100644 --- a/hledger-lib/Hledger/Read/Common.hs +++ b/hledger-lib/Hledger/Read/Common.hs @@ -19,7 +19,6 @@ Some of these might belong in Hledger.Read.JournalReader or Hledger.Read. {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NoMonoLocalBinds #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -49,6 +48,7 @@ module Hledger.Read.Common ( getDefaultCommodityAndStyle, getDefaultAmountStyle, getAmountStyle, + addDeclaredAccountTags, addDeclaredAccountType, pushParentAccount, popParentAccount, @@ -129,7 +129,7 @@ import Data.Decimal (DecimalRaw (Decimal), Decimal) import Data.Either (lefts, rights) import Data.Function ((&)) import Data.Functor ((<&>), ($>)) -import Data.List (find, genericReplicate) +import Data.List (find, genericReplicate, union) import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (catMaybes, fromMaybe, isJust, listToMaybe) import qualified Data.Map as M @@ -213,7 +213,7 @@ rawOptsToInputOpts day rawopts = ,forecast_ = forecastPeriodFromRawOpts day rawopts ,reportspan_ = DateSpan (queryStartDate False datequery) (queryEndDate False datequery) ,auto_ = boolopt "auto" rawopts - ,infer_equity_ = boolopt "infer-equity" rawopts && not (conversionop_ ropts == Just ToCost) + ,infer_equity_ = boolopt "infer-equity" rawopts && conversionop_ ropts /= Just ToCost ,balancingopts_ = defbalancingopts{ ignore_assertions_ = boolopt "ignore-assertions" rawopts , infer_transaction_prices_ = not noinferprice @@ -294,10 +294,16 @@ parseAndFinaliseJournal' parser iopts f txt = do -- -- - apply canonical commodity styles -- +-- - add tags from account directives to postings' tags +-- -- - add forecast transactions if enabled -- +-- - add tags from account directives to postings' tags (again to affect forecast transactions) +-- -- - add auto postings if enabled -- +-- - add tags from account directives to postings' tags (again to affect auto postings) +-- -- - evaluate balance assignments and balance each transaction -- -- - check balance assertions if enabled @@ -322,15 +328,22 @@ journalFinalise iopts@InputOpts{auto_,infer_equity_,balancingopts_,strict_} f tx & journalReverse -- convert all lists to the order they were parsed where checkAddAndBalance d j = do - -- Add forecast transactions if enabled - newj <- journalAddForecast (forecastPeriod iopts j) j - -- Add auto postings if enabled + newj <- j + -- Add account tags to postings' tags + & journalPostingsAddAccountTags + -- Add forecast transactions if enabled + & journalAddForecast (forecastPeriod iopts j) + -- Add account tags again to affect forecast transactions -- PERF: just to the new transactions ? + & journalPostingsAddAccountTags + -- Add auto postings if enabled & (if auto_ && not (null $ jtxnmodifiers j) then journalAddAutoPostings d balancingopts_ else pure) - -- Balance all transactions and maybe check balance assertions. + -- Add account tags again to affect auto postings -- PERF: just to the new postings ? + >>= Right . journalPostingsAddAccountTags + -- Balance all transactions and maybe check balance assertions. >>= journalBalanceTransactions balancingopts_ - -- Add inferred equity postings, after balancing transactions and generating auto postings + -- Add inferred equity postings, after balancing transactions and generating auto postings <&> (if infer_equity_ then journalAddInferredEquityPostings else id) - -- infer market prices from commodity-exchanging transactions + -- infer market prices from commodity-exchanging transactions <&> journalInferMarketPricesFromTransactions when strict_ $ do @@ -341,6 +354,14 @@ journalFinalise iopts@InputOpts{auto_,infer_equity_,balancingopts_,strict_} f tx return newj +-- | 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 = -- Balance all transactions without checking balance assertions, @@ -462,6 +483,10 @@ getAmountStyle commodity = do mdefaultStyle <- fmap snd <$> getDefaultCommodityAndStyle return $ listToMaybe $ catMaybes [mspecificStyle, mdefaultStyle] +addDeclaredAccountTags :: AccountName -> [Tag] -> JournalParser m () +addDeclaredAccountTags acct atags = + modify' (\j -> j{jdeclaredaccounttags = M.insertWith (flip union) acct atags (jdeclaredaccounttags j)}) + addDeclaredAccountType :: AccountName -> AccountType -> JournalParser m () addDeclaredAccountType acct atype = modify' (\j -> j{jdeclaredaccounttypes = M.insertWith (++) atype [acct] (jdeclaredaccounttypes j)}) @@ -1593,3 +1618,5 @@ tests_Common = testGroup "Common" [ ] ] + + diff --git a/hledger-lib/Hledger/Read/JournalReader.hs b/hledger-lib/Hledger/Read/JournalReader.hs index 72807cabb..42902c37c 100644 --- a/hledger-lib/Hledger/Read/JournalReader.hs +++ b/hledger-lib/Hledger/Read/JournalReader.hs @@ -73,7 +73,7 @@ where --- ** imports import qualified Control.Monad.Fail as Fail (fail) import qualified Control.Exception as C -import Control.Monad (forM_, when, void) +import Control.Monad (forM_, when, void, unless) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Except (ExceptT(..), runExceptT) import Control.Monad.State.Strict (evalStateT,get,modify',put) @@ -360,6 +360,7 @@ accountdirectivep = do -- update the journal addAccountDeclaration (acct, cmt, tags) + unless (null tags) $ addDeclaredAccountTags acct tags case metype of Nothing -> return () Just (Right t) -> addDeclaredAccountType acct t diff --git a/hledger-lib/Hledger/Reports/MultiBalanceReport.hs b/hledger-lib/Hledger/Reports/MultiBalanceReport.hs index fdccf1134..cef5b58f7 100644 --- a/hledger-lib/Hledger/Reports/MultiBalanceReport.hs +++ b/hledger-lib/Hledger/Reports/MultiBalanceReport.hs @@ -282,11 +282,16 @@ acctChanges ReportSpec{_rsQuery=query,_rsReportOpts=ReportOpts{accountlistmode_, -- and the declared accounts are really only needed for the former, -- but it's harmless to have them in the column changes as well. ps' = ps ++ if declared_ then declaredacctps else [] - where - declaredacctps = - [nullposting{paccount=n} | n <- journalLeafAccountNamesDeclared j - , acctq `matchesAccount` n] - where acctq = dbg3 "acctq" $ filterQueryOrNotQuery queryIsAcct query + where + declaredacctps = + [nullposting{paccount=a} + | a <- journalLeafAccountNamesDeclared j + , let atags = M.findWithDefault [] a $ jdeclaredaccounttags j + , acctandtagsq `matchesTaggedAccount` (a, atags) + ] + where + acctandtagsq = dbg3 "acctandtagsq" $ + filterQueryOrNotQuery (\q -> queryIsAcct q || queryIsTag q) query filterbydepth = case accountlistmode_ of ALTree -> filter ((depthq `matchesAccount`) . aname) -- a tree - just exclude deeper accounts diff --git a/hledger/Hledger/Cli/Commands/Accounts.hs b/hledger/Hledger/Cli/Commands/Accounts.hs index ac5dd65a8..123bdf6cb 100644 --- a/hledger/Hledger/Cli/Commands/Accounts.hs +++ b/hledger/Hledger/Cli/Commands/Accounts.hs @@ -55,7 +55,9 @@ accounts CliOpts{rawopts_=rawopts, reportspec_=ReportSpec{_rsQuery=query,_rsRepo -- just the acct: part of the query will be reapplied later, after clipping acctq = dbg1 "acctq" $ filterQuery queryIsAcct query depth = dbg1 "depth" $ queryDepth $ filterQuery queryIsDepth query - matcheddeclaredaccts = dbg1 "matcheddeclaredaccts" $ filter (matchesAccount nodepthq) $ map fst $ jdeclaredaccounts j + matcheddeclaredaccts = + dbg1 "matcheddeclaredaccts" $ + filter (\a -> matchesTaggedAccount nodepthq (a, (journalInheritedAccountTags j a))) $ 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 if | declared && not used -> matcheddeclaredaccts diff --git a/hledger/test/query-tag.test b/hledger/test/query-tag.test index 9989d0549..3c887d3cc 100644 --- a/hledger/test/query-tag.test +++ b/hledger/test/query-tag.test @@ -120,3 +120,97 @@ $ hledger -f - print not:tag:. # 6. query is not affected by implicit tags (XXX ?) $ hledger -f ../../examples/sample.journal reg tag:d +# Querying accounts by tag. +< +account a ; type:A +account l ; type:Liability +account r ; type:R +account o ; othertag: +account u + +2022-01-01 + (r) 1 + +2022-01-02 + (a) 1 + (l) 1 + +# 7. We can match declared accounts by having a tag, +$ hledger -f- accounts --declared tag:. +a +l +r +o + +# 8. not having a tag, +$ hledger -f- accounts --declared not:tag:. +u + +# 9. or a tag and it's value. Tag values are matched infix. +$ hledger -f- accounts --declared tag:type=a +a +l + +# 10. So we must anchor the regex to match single-letter account types. +$ hledger -f- accounts --declared tag:type=^a$ +a + +# 11. But if account type was declared in the long form, matching just one letter fails +$ hledger -f- accounts --declared tag:type=^l$ + +# 12. so we need to match more loosely +$ hledger -f- accounts --declared tag:type=^l +l + +# 13. In the same way, we can match used accounts by tag. +$ hledger -f- accounts --used tag:type=r +r + +# 14. We can match postings by their account's tags. +$ hledger -f- register -w80 tag:type=^a +2022-01-02 (a) 1 1 + +# 15. We can match transactions by their accounts' tags. +$ hledger -f- print tag:type=^a +2022-01-02 + (a) 1 + (l) 1 + +>= + +# 16. And negatively match them by tag. +$ hledger -f- print tag:type=^a not:tag:type=^l + +# 17. We can filter balance reports by account tags. +$ hledger -f- bal tag:type=^a + 1 a +-------------------- + 1 + +# 18. Postingless declared accounts in balance reports are also filtered. +$ hledger -f- bal -N --declared -E o u tag:othertag + 0 o + +# 19. Accounts inherit the tags of their parents. +< +account a ; type:A +account a:aa + +$ hledger -f- accounts tag:type=a +a +a:aa + +# 20. +< +account a ; type:A +account a:aa + +2022-01-01 + (a:aa) 1 + +$ hledger -f- bal -N tag:type=a + 1 a:aa + +# 21. +$ hledger -f- reg -w80 tag:type=a +2022-01-01 (a:aa) 1 1