new query by tag implementation
This commit is contained in:
Simon Michael
parent
2fb2aea056
commit
cb905a741c
@ -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
|
||||
|
||||
<!--
|
||||
- `tag:TAGNAMEREGEX[:TAGVALUEREGEX]` - match a [tag](#tags) name, and
|
||||
optionally the value, by regular expression
|
||||
- `TAGNAME:[TAGVALUEREGEX]` - match a tag name exactly, and optionally
|
||||
the value by regular expression.
|
||||
- `code:CODEREGEX` -->
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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], [])})
|
||||
|
||||
115
tests/tags.test
115
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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user