From cb905a741ca28aef7e39316ccbf2bfe729e60d4b Mon Sep 17 00:00:00 2001 From: Simon Michael Date: Mon, 28 May 2012 00:27:55 +0000 Subject: [PATCH] new query by tag implementation --- MANUAL.md | 3 +- hledger-lib/Hledger/Data/Posting.hs | 10 ++ hledger-lib/Hledger/Data/Query.hs | 47 ++++++++- hledger-lib/Hledger/Data/Types.hs | 6 +- hledger-lib/Hledger/Read/JournalReader.hs | 2 - tests/tags.test | 115 +++++++++++++--------- 6 files changed, 127 insertions(+), 56 deletions(-) diff --git a/MANUAL.md b/MANUAL.md index 256024b7f..930b3c91c 100644 --- a/MANUAL.md +++ b/MANUAL.md @@ -890,10 +890,9 @@ currently supported: - `status:1` or `status:0` - match cleared/uncleared transactions - `depth:N` - match (or display, depending on command) accounts at or above this depth - `not:` before any of the above negates the match +- `tag:NAME[=VALUEREGEX]` - match by exact [tag](#tags) name, and optionally match the tag value by regular expression diff --git a/hledger-lib/Hledger/Data/Posting.hs b/hledger-lib/Hledger/Data/Posting.hs index f02b00bee..e2678af4a 100644 --- a/hledger-lib/Hledger/Data/Posting.hs +++ b/hledger-lib/Hledger/Data/Posting.hs @@ -17,6 +17,8 @@ module Hledger.Data.Posting ( isBalancedVirtual, isEmptyPosting, hasAmount, + postingAllTags, + transactionAllTags, -- * date operations postingDate, isPostingInDateSpan, @@ -127,6 +129,14 @@ postingCleared p = if pstatus p then True else maybe False tstatus $ ptransaction p +-- | Tags for this posting including any inherited from its parent transaction. +postingAllTags :: Posting -> [Tag] +postingAllTags p = ptags p ++ maybe [] transactionAllTags (ptransaction p) + +-- | Tags for this transaction including any inherited from above, when that is implemented. +transactionAllTags :: Transaction -> [Tag] +transactionAllTags t = ttags t + -- | Does this posting fall within the given date span ? isPostingInDateSpan :: DateSpan -> Posting -> Bool isPostingInDateSpan s = spanContainsDate s . postingDate diff --git a/hledger-lib/Hledger/Data/Query.hs b/hledger-lib/Hledger/Data/Query.hs index 1c29c00c1..e5746ddab 100644 --- a/hledger-lib/Hledger/Data/Query.hs +++ b/hledger-lib/Hledger/Data/Query.hs @@ -36,14 +36,13 @@ import Data.Either import Data.List import Data.Maybe import Data.Time.Calendar -import Safe (readDef, headDef) +import Safe (readDef, headDef, headMay) import Test.HUnit import Text.ParserCombinators.Parsec import Hledger.Utils import Hledger.Data.Types import Hledger.Data.AccountName -import Hledger.Data.Amount import Hledger.Data.Dates import Hledger.Data.Posting import Hledger.Data.Transaction @@ -65,6 +64,8 @@ data Query = Any -- ^ always match | Empty Bool -- ^ if true, show zero-amount postings/accounts which are usually not shown -- more of a query option than a query criteria ? | Depth Int -- ^ match if account depth is less than or equal to this value + | Tag String (Maybe String) -- ^ match if a tag with this exact name, and with value + -- matching the regexp if provided, exists deriving (Show, Eq) -- | A query option changes a query's/report's behaviour and output in some way. @@ -128,8 +129,6 @@ tests_parseQuery = [ parseQuery d "inacct:a inacct:b" `is` (Any, [QueryOptInAcct "a", QueryOptInAcct "b"]) parseQuery d "desc:'x x'" `is` (Desc "x x", []) parseQuery d "'a a' 'b" `is` (Or [Acct "a a",Acct "'b"], []) - -- parseQuery d "a b desc:x desc:y status:1" `is` - -- (And [Or [Acct "a", Acct "b"], Or [Desc "x", Desc "y"], Status True], []) ] -- keep synced with patterns below, excluding "not" @@ -200,6 +199,7 @@ parseQueryTerm _ ('s':'t':'a':'t':'u':'s':':':s) = Left $ Status $ parseStatus s parseQueryTerm _ ('r':'e':'a':'l':':':s) = Left $ Real $ parseBool s parseQueryTerm _ ('e':'m':'p':'t':'y':':':s) = Left $ Empty $ parseBool s parseQueryTerm _ ('d':'e':'p':'t':'h':':':s) = Left $ Depth $ readDef 0 s +parseQueryTerm _ ('t':'a':'g':':':s) = Left $ Tag n v where (n,v) = parseTag s parseQueryTerm _ "" = Left $ Any parseQueryTerm d s = parseQueryTerm d $ defaultprefix++":"++s @@ -216,8 +216,15 @@ tests_parseQueryTerm = [ "date:2008" `gives` (Left $ Date $ DateSpan (Just $ parsedate "2008/01/01") (Just $ parsedate "2009/01/01")) "date:from 2012/5/17" `gives` (Left $ Date $ DateSpan (Just $ parsedate "2012/05/17") Nothing) "inacct:a" `gives` (Right $ QueryOptInAcct "a") + "tag:a" `gives` (Left $ Tag "a" Nothing) + "tag:a=some value" `gives` (Left $ Tag "a" (Just "some value")) ] +parseTag :: String -> (String, Maybe String) +parseTag s | '=' `elem` s = (n, Just $ tail v) + | otherwise = (s, Nothing) + where (n,v) = break (=='=') s + -- | Parse the boolean value part of a "status:" query, allowing "*" as -- another way to spell True, similar to the journal file format. parseStatus :: String -> Bool @@ -419,6 +426,7 @@ matchesAccount (Or ms) a = any (`matchesAccount` a) ms matchesAccount (And ms) a = all (`matchesAccount` a) ms matchesAccount (Acct r) a = regexMatchesCI r a matchesAccount (Depth d) a = accountNameLevel a <= d +matchesAccount (Tag _ _) _ = False matchesAccount _ _ = True tests_matchesAccount = [ @@ -432,6 +440,7 @@ tests_matchesAccount = [ assertBool "" $ not $ Depth 2 `matchesAccount` "a:b:c" assertBool "" $ Date nulldatespan `matchesAccount` "a" assertBool "" $ EDate nulldatespan `matchesAccount` "a" + assertBool "" $ not $ (Tag "a" Nothing) `matchesAccount` "a" ] -- | Does the match expression match this posting ? @@ -457,6 +466,8 @@ matchesPosting (Depth d) Posting{paccount=a} = Depth d `matchesAccount` a -- matchesPosting (Empty False) Posting{pamount=a} = True -- matchesPosting (Empty True) Posting{pamount=a} = isZeroMixedAmount a matchesPosting (Empty _) _ = True +matchesPosting (Tag n Nothing) p = isJust $ lookupTagByName n $ postingAllTags p +matchesPosting (Tag n (Just v)) p = isJust $ lookupTagByNameAndValue (n,v) $ postingAllTags p -- matchesPosting _ _ = False tests_matchesPosting = [ @@ -476,6 +487,15 @@ tests_matchesPosting = [ assertBool "real:1 on virtual posting fails" $ not $ (Real True) `matchesPosting` nullposting{ptype=VirtualPosting} assertBool "real:1 on balanced virtual posting fails" $ not $ (Real True) `matchesPosting` nullposting{ptype=BalancedVirtualPosting} assertBool "" $ (Acct "'b") `matchesPosting` nullposting{paccount="'b"} + assertBool "" $ not $ (Tag "a" (Just "r$")) `matchesPosting` nullposting + assertBool "" $ (Tag "foo" Nothing) `matchesPosting` nullposting{ptags=[("foo","")]} + assertBool "" $ (Tag "foo" Nothing) `matchesPosting` nullposting{ptags=[("foo","baz")]} + assertBool "" $ (Tag "foo" (Just "a")) `matchesPosting` nullposting{ptags=[("foo","bar")]} + assertBool "" $ not $ (Tag "foo" (Just "a$")) `matchesPosting` nullposting{ptags=[("foo","bar")]} + assertBool "" $ not $ (Tag " foo " (Just "a")) `matchesPosting` nullposting{ptags=[("foo","bar")]} + assertBool "" $ not $ (Tag "foo foo" (Just " ar ba ")) `matchesPosting` nullposting{ptags=[("foo foo","bar bar")]} + -- a tag match on a posting also sees inherited tags + assertBool "" $ (Tag "txntag" Nothing) `matchesPosting` nullposting{ptransaction=Just nulltransaction{ttags=[("txntag","")]}} ] -- | Does the match expression match this transaction ? @@ -493,6 +513,9 @@ matchesTransaction (Status v) t = v == tstatus t matchesTransaction (Real v) t = v == hasRealPostings t matchesTransaction (Empty _) _ = True matchesTransaction (Depth d) t = any (Depth d `matchesPosting`) $ tpostings t +matchesTransaction (Tag n Nothing) t = isJust $ lookupTagByName n $ transactionAllTags t +matchesTransaction (Tag n (Just v)) t = isJust $ lookupTagByNameAndValue (n,v) $ transactionAllTags t + -- matchesTransaction _ _ = False tests_matchesTransaction = [ @@ -501,8 +524,24 @@ tests_matchesTransaction = [ Any `matches` nulltransaction assertBool "" $ not $ (Desc "x x") `matchesTransaction` nulltransaction{tdescription="x"} assertBool "" $ (Desc "x x") `matchesTransaction` nulltransaction{tdescription="x x"} + -- see posting for more tag tests + assertBool "" $ (Tag "foo" (Just "a")) `matchesTransaction` nulltransaction{ttags=[("foo","bar")]} + -- a tag match on a transaction usually ignores posting tags + assertBool "" $ not $ (Tag "postingtag" Nothing) `matchesTransaction` nulltransaction{tpostings=[nullposting{ptags=[("postingtag","")]}]} ] +lookupTagByName :: String -> [Tag] -> Maybe Tag +lookupTagByName namepat tags = headMay [(n,v) | (n,v) <- tags, matchTagName namepat n] + +lookupTagByNameAndValue :: Tag -> [Tag] -> Maybe Tag +lookupTagByNameAndValue (namepat, valpat) tags = headMay [(n,v) | (n,v) <- tags, matchTagName namepat n, matchTagValue valpat v] + +matchTagName :: String -> String -> Bool +matchTagName pat name = pat == name + +matchTagValue :: String -> String -> Bool +matchTagValue pat value = regexMatchesCI pat value + postingEffectiveDate :: Posting -> Maybe Day postingEffectiveDate p = maybe Nothing (Just . transactionEffectiveDate) $ ptransaction p diff --git a/hledger-lib/Hledger/Data/Types.hs b/hledger-lib/Hledger/Data/Types.hs index f17b8b9c1..170985113 100644 --- a/hledger-lib/Hledger/Data/Types.hs +++ b/hledger-lib/Hledger/Data/Types.hs @@ -89,13 +89,15 @@ newtype MixedAmount = Mixed [Amount] deriving (Eq,Ord) data PostingType = RegularPosting | VirtualPosting | BalancedVirtualPosting deriving (Eq,Show) +type Tag = (String, String) + data Posting = Posting { pstatus :: Bool, paccount :: AccountName, pamount :: MixedAmount, pcomment :: String, -- ^ this posting's non-tag comment lines, as a single non-indented string ptype :: PostingType, - ptags :: [(String,String)], + ptags :: [Tag], ptransaction :: Maybe Transaction -- ^ this posting's parent transaction (co-recursive types). -- Tying this knot gets tedious, Maybe makes it easier/optional. } @@ -112,7 +114,7 @@ data Transaction = Transaction { tcode :: String, tdescription :: String, tcomment :: String, -- ^ this transaction's non-tag comment lines, as a single non-indented string - ttags :: [(String,String)], + ttags :: [Tag], tpostings :: [Posting], -- ^ this transaction's postings (co-recursive types). tpreceding_comment_lines :: String } deriving (Eq) diff --git a/hledger-lib/Hledger/Read/JournalReader.hs b/hledger-lib/Hledger/Read/JournalReader.hs index 778175b6f..ebee971a3 100644 --- a/hledger-lib/Hledger/Read/JournalReader.hs +++ b/hledger-lib/Hledger/Read/JournalReader.hs @@ -752,8 +752,6 @@ commentline = do -- newer comment parsers -type Tag = (String, String) - inlinecomment :: GenParser Char JournalContext ([String],[Tag]) inlinecomment = try (do {md <- tagcomment; newline; return ([], [md])}) <|> (do {c <- comment; newline; return ([rstrip c], [])}) diff --git a/tests/tags.test b/tests/tags.test index 6efddd953..fdbdd5b93 100644 --- a/tests/tags.test +++ b/tests/tags.test @@ -25,57 +25,80 @@ bin/hledger -f - print >>>2 >>>=0 -# 2. print (and a few other commands) can filter by tag value -# bin/hledger -f - print tag foo=bar -# <<< -# 2010/01/01 -# ; foo:bar -# a 1 -# b -1 +# 2. reports can filter by tag existence +bin/hledger -f - print tag:foo +<<< +2010/01/01 ; foo:bar + a 1 + b -1 -# 2010/01/02 -# ; foo:baz -# c 1 -# d -1 +2010/01/02 + ; foo:baz + c 1 + d -1 -# 2010/01/03 -# e 1 -# f -1 -# >>> -# 2010/01/01 -# ; foo: bar -# a 1 -# b -1 +2010/01/03 + e 1 + f -1 +>>> +2010/01/01 + ; foo: bar + a 1 + b -1 -# >>>2 -# >>>=0 +2010/01/02 + ; foo: baz + c 1 + d -1 -# # 3. or tag existence ? not yet -# bin/hledger -f - print tag foo -# <<< -# 2010/01/01 -# ; foo:bar -# a 1 -# b -1 +>>>2 +>>>=0 -# 2010/01/02 -# ; foo:baz -# c 1 -# d -1 +# 3. or tag value +bin/hledger -f - print tag:foo=bar +<<< +2010/01/01 + ; foo:bar + a 1 + b -1 -# 2010/01/03 -# e 1 -# f -1 -# >>> -# 2010/01/01 -# ; foo:bar -# a 1 -# b -1 +2010/01/02 + ; foo:baz + c 1 + d -1 -# 2010/01/02 -# ; foo:baz -# c 1 -# d -1 +2010/01/03 + e 1 + f -1 +>>> +2010/01/01 + ; foo: bar + a 1 + b -1 + +>>>2 +>>>=0 + +# 4. postings inherit their transaction's tags +bin/hledger -f - register tag:foo=bar +<<< +2010/01/01 + a 1 ; foo:bar + b -1 + +2010/01/02 + ; foo:baz + c 1 + d -1 + +2010/01/03 + ; foo:bar + e 1 + f -1 +>>> +2010/01/01 a 1 1 +2010/01/03 e 1 2 + f -1 1 +>>>2 +>>>=0 -# >>>2 -# >>>=0