feat: queries can now match account tags (#1817)

Accounts, postings, and transactions can now all be filtered by the
tags in an account's declaration. In particular it's now possible to
more reliably select accounts by type, using their type: tag rather
than their name:

    account myasset       ; type:Asset
    account myliability   ; type:Liability

    $ hledger accounts tag:type=^a
    myasset

Accounts inherit tags from their parents.

API changes:
A finalised Journal has a new jdeclaredaccounttags field
for easy lookup of account tags.
Query.matchesTaggedAccount is a tag-aware version of matchesAccount.

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

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.

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

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}

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 <- j
-        newj <- journalAddForecast (forecastPeriod iopts j) j
+          -- Add account tags to postings' tags
-        -- Add auto postings if enabled
+          & 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" [
     ]
 
   ]
+
+

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

hledger-lib/Hledger/Reports/MultiBalanceReport.hs

@@ -284,9 +284,14 @@ acctChanges ReportSpec{_rsQuery=query,_rsReportOpts=ReportOpts{accountlistmode_,
     ps' = ps ++ if declared_ then declaredacctps else []
       where
         declaredacctps =
-          [nullposting{paccount=n} | n <- journalLeafAccountNamesDeclared j
+          [nullposting{paccount=a}
-                                   , acctq `matchesAccount` n]
+          | a <- journalLeafAccountNamesDeclared j
-          where acctq  = dbg3 "acctq" $ filterQueryOrNotQuery queryIsAcct query
+          , 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

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

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