slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source 
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.
This commit is contained in:
Simon Michael 2022-01-28 19:56:49 -10:00
parent 2f48307c63
commit 56be63e6f1
9 changed files with 196 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
hledger-lib/Hledger/Data/Journal.hs
View File

@ -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

7
hledger-lib/Hledger/Data/Posting.hs
View File

@ -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.

4
hledger-lib/Hledger/Data/Types.hs
View File

@ -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

29
hledger-lib/Hledger/Query.hs
View File

@ -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}

35
hledger-lib/Hledger/Read/Common.hs
View File

@ -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,10 +328,17 @@ 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
newj <- j
-- Add account tags to postings' tags
& journalPostingsAddAccountTags
-- Add forecast transactions if enabled
newj <- journalAddForecast (forecastPeriod iopts j) j
& 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)
-- 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
@ -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" [
]
]

3
hledger-lib/Hledger/Read/JournalReader.hs
View File

@ -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

11
hledger-lib/Hledger/Reports/MultiBalanceReport.hs
View File

@ -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
, acctq `matchesAccount` n]
where acctq = dbg3 "acctq" $ filterQueryOrNotQuery queryIsAcct query
[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

4
hledger/Hledger/Cli/Commands/Accounts.hs
View File

@ -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

94
hledger/test/query-tag.test
View File

@ -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