module Hledger.Query (
Query(..),
QueryOpt(..),
parseQuery,
simplifyQuery,
filterQuery,
queryIsNull,
queryIsAcct,
queryIsDepth,
queryIsDate,
queryIsDate2,
queryIsDateOrDate2,
queryIsStartDateOnly,
queryIsSym,
queryIsReal,
queryIsStatus,
queryIsEmpty,
queryStartDate,
queryEndDate,
queryDateSpan,
queryDateSpan',
queryDepth,
inAccount,
inAccountQuery,
matchesTransaction,
matchesPosting,
matchesAccount,
matchesMixedAmount,
matchesAmount,
words'',
tests_Hledger_Query
)
where
import Data.Data
import Data.Either
import Data.List
import Data.Maybe
import Data.Monoid ((<>))
import qualified Data.Text as T
import Data.Time.Calendar
import Safe (readDef, headDef)
import Test.HUnit
import Text.Megaparsec
import Text.Megaparsec.Text
import Hledger.Utils hiding (words')
import Hledger.Data.Types
import Hledger.Data.AccountName
import Hledger.Data.Amount (amount, nullamt, usd)
import Hledger.Data.Dates
import Hledger.Data.Posting
import Hledger.Data.Transaction
data Query = Any
| None
| Not Query
| Or [Query]
| And [Query]
| Code Regexp
| Desc Regexp
| Acct Regexp
| Date DateSpan
| Date2 DateSpan
| Status ClearedStatus
| Real Bool
| Amt OrdPlus Quantity
| Sym Regexp
| Empty Bool
| Depth Int
| Tag Regexp (Maybe Regexp)
deriving (Eq,Data,Typeable)
instance Show Query where
show Any = "Any"
show None = "None"
show (Not q) = "Not (" ++ show q ++ ")"
show (Or qs) = "Or (" ++ show qs ++ ")"
show (And qs) = "And (" ++ show qs ++ ")"
show (Code r) = "Code " ++ show r
show (Desc r) = "Desc " ++ show r
show (Acct r) = "Acct " ++ show r
show (Date ds) = "Date (" ++ show ds ++ ")"
show (Date2 ds) = "Date2 (" ++ show ds ++ ")"
show (Status b) = "Status " ++ show b
show (Real b) = "Real " ++ show b
show (Amt ord qty) = "Amt " ++ show ord ++ " " ++ show qty
show (Sym r) = "Sym " ++ show r
show (Empty b) = "Empty " ++ show b
show (Depth n) = "Depth " ++ show n
show (Tag s ms) = "Tag " ++ show s ++ " (" ++ show ms ++ ")"
data QueryOpt = QueryOptInAcctOnly AccountName
| QueryOptInAcct AccountName
deriving (Show, Eq, Data, Typeable)
parseQuery :: Day -> T.Text -> (Query,[QueryOpt])
parseQuery d s = (q, opts)
where
terms = words'' prefixes s
(pats, opts) = partitionEithers $ map (parseQueryTerm d) terms
(descpats, pats') = partition queryIsDesc pats
(acctpats, otherpats) = partition queryIsAcct pats'
q = simplifyQuery $ And $ [Or acctpats, Or descpats] ++ otherpats
tests_parseQuery = [
"parseQuery" ~: do
let d = nulldate
parseQuery d "acct:'expenses:autres d\233penses' desc:b" `is` (And [Acct "expenses:autres d\233penses", Desc "b"], [])
parseQuery d "inacct:a desc:\"b b\"" `is` (Desc "b b", [QueryOptInAcct "a"])
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 "\"" `is` (Acct "\"", [])
]
words'' :: [T.Text] -> T.Text -> [T.Text]
words'' prefixes = fromparse . parsewith maybeprefixedquotedphrases
where
maybeprefixedquotedphrases :: Parser [T.Text]
maybeprefixedquotedphrases = choice' [prefixedQuotedPattern, singleQuotedPattern, doubleQuotedPattern, pattern] `sepBy` some spacenonewline
prefixedQuotedPattern :: Parser T.Text
prefixedQuotedPattern = do
not' <- fromMaybe "" `fmap` (optional $ string "not:")
let allowednexts | null not' = prefixes
| otherwise = prefixes ++ [""]
next <- fmap T.pack $ choice' $ map (string . T.unpack) allowednexts
let prefix :: T.Text
prefix = T.pack not' <> next
p <- singleQuotedPattern <|> doubleQuotedPattern
return $ prefix <> stripquotes p
singleQuotedPattern :: Parser T.Text
singleQuotedPattern = between (char '\'') (char '\'') (many $ noneOf ("'" :: [Char])) >>= return . stripquotes . T.pack
doubleQuotedPattern :: Parser T.Text
doubleQuotedPattern = between (char '"') (char '"') (many $ noneOf ("\"" :: [Char])) >>= return . stripquotes . T.pack
pattern :: Parser T.Text
pattern = fmap T.pack $ many (noneOf (" \n\r" :: [Char]))
tests_words'' = [
"words''" ~: do
assertEqual "1" ["a","b"] (words'' [] "a b")
assertEqual "2" ["a b"] (words'' [] "'a b'")
assertEqual "3" ["not:a","b"] (words'' [] "not:a b")
assertEqual "4" ["not:a b"] (words'' [] "not:'a b'")
assertEqual "5" ["not:a b"] (words'' [] "'not:a b'")
assertEqual "6" ["not:desc:a b"] (words'' ["desc:"] "not:desc:'a b'")
let s `gives` r = assertEqual "" r (words'' prefixes s)
"\"acct:expenses:autres d\233penses\"" `gives` ["acct:expenses:autres d\233penses"]
"\"" `gives` ["\""]
]
prefixes :: [T.Text]
prefixes = map (<>":") [
"inacctonly"
,"inacct"
,"amt"
,"code"
,"desc"
,"acct"
,"date"
,"date2"
,"status"
,"cur"
,"real"
,"empty"
,"depth"
,"tag"
]
defaultprefix :: T.Text
defaultprefix = "acct"
parseQueryTerm :: Day -> T.Text -> Either Query QueryOpt
parseQueryTerm _ (T.stripPrefix "inacctonly:" -> Just s) = Right $ QueryOptInAcctOnly s
parseQueryTerm _ (T.stripPrefix "inacct:" -> Just s) = Right $ QueryOptInAcct s
parseQueryTerm d (T.stripPrefix "not:" -> Just s) =
case parseQueryTerm d s of
Left m -> Left $ Not m
Right _ -> Left Any
parseQueryTerm _ (T.stripPrefix "code:" -> Just s) = Left $ Code $ T.unpack s
parseQueryTerm _ (T.stripPrefix "desc:" -> Just s) = Left $ Desc $ T.unpack s
parseQueryTerm _ (T.stripPrefix "acct:" -> Just s) = Left $ Acct $ T.unpack s
parseQueryTerm d (T.stripPrefix "date2:" -> Just s) =
case parsePeriodExpr d s of Left e -> error' $ "\"date2:"++T.unpack s++"\" gave a "++showDateParseError e
Right (_,span) -> Left $ Date2 span
parseQueryTerm d (T.stripPrefix "date:" -> Just s) =
case parsePeriodExpr d s of Left e -> error' $ "\"date:"++T.unpack s++"\" gave a "++showDateParseError e
Right (_,span) -> Left $ Date span
parseQueryTerm _ (T.stripPrefix "status:" -> Just s) =
case parseStatus s of Left e -> error' $ "\"status:"++T.unpack s++"\" gave a parse error: " ++ e
Right st -> Left $ Status st
parseQueryTerm _ (T.stripPrefix "real:" -> Just s) = Left $ Real $ parseBool s || T.null s
parseQueryTerm _ (T.stripPrefix "amt:" -> Just s) = Left $ Amt ord q where (ord, q) = parseAmountQueryTerm s
parseQueryTerm _ (T.stripPrefix "empty:" -> Just s) = Left $ Empty $ parseBool s
parseQueryTerm _ (T.stripPrefix "depth:" -> Just s)
| n >= 0 = Left $ Depth n
| otherwise = error' "depth: should have a positive number"
where n = readDef 0 (T.unpack s)
parseQueryTerm _ (T.stripPrefix "cur:" -> Just s) = Left $ Sym (T.unpack s)
parseQueryTerm _ (T.stripPrefix "tag:" -> Just s) = Left $ Tag n v where (n,v) = parseTag s
parseQueryTerm _ "" = Left $ Any
parseQueryTerm d s = parseQueryTerm d $ defaultprefix<>":"<>s
tests_parseQueryTerm = [
"parseQueryTerm" ~: do
let s `gives` r = parseQueryTerm nulldate s `is` r
"a" `gives` (Left $ Acct "a")
"acct:expenses:autres d\233penses" `gives` (Left $ Acct "expenses:autres d\233penses")
"not:desc:a b" `gives` (Left $ Not $ Desc "a b")
"status:1" `gives` (Left $ Status Cleared)
"status:*" `gives` (Left $ Status Cleared)
"status:!" `gives` (Left $ Status Pending)
"status:0" `gives` (Left $ Status Uncleared)
"status:" `gives` (Left $ Status Uncleared)
"real:1" `gives` (Left $ Real True)
"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"))
]
data OrdPlus = Lt | LtEq | Gt | GtEq | Eq | AbsLt | AbsLtEq | AbsGt | AbsGtEq | AbsEq
deriving (Show,Eq,Data,Typeable)
parseAmountQueryTerm :: T.Text -> (OrdPlus, Quantity)
parseAmountQueryTerm s' =
case s' of
"" -> err
(T.stripPrefix "<+" -> Just s) -> (Lt, readDef err (T.unpack s))
(T.stripPrefix "<=+" -> Just s) -> (LtEq, readDef err (T.unpack s))
(T.stripPrefix ">+" -> Just s) -> (Gt, readDef err (T.unpack s))
(T.stripPrefix ">=+" -> Just s) -> (GtEq, readDef err (T.unpack s))
(T.stripPrefix "=+" -> Just s) -> (Eq, readDef err (T.unpack s))
(T.stripPrefix "+" -> Just s) -> (Eq, readDef err (T.unpack s))
(T.stripPrefix "<-" -> Just s) -> (Lt, negate $ readDef err (T.unpack s))
(T.stripPrefix "<=-" -> Just s) -> (LtEq, negate $ readDef err (T.unpack s))
(T.stripPrefix ">-" -> Just s) -> (Gt, negate $ readDef err (T.unpack s))
(T.stripPrefix ">=-" -> Just s) -> (GtEq, negate $ readDef err (T.unpack s))
(T.stripPrefix "=-" -> Just s) -> (Eq, negate $ readDef err (T.unpack s))
(T.stripPrefix "-" -> Just s) -> (Eq, negate $ readDef err (T.unpack s))
(T.stripPrefix "<=" -> Just s) -> let n = readDef err (T.unpack s) in
case n of
0 -> (LtEq, 0)
_ -> (AbsLtEq, n)
(T.stripPrefix "<" -> Just s) -> let n = readDef err (T.unpack s) in
case n of 0 -> (Lt, 0)
_ -> (AbsLt, n)
(T.stripPrefix ">=" -> Just s) -> let n = readDef err (T.unpack s) in
case n of 0 -> (GtEq, 0)
_ -> (AbsGtEq, n)
(T.stripPrefix ">" -> Just s) -> let n = readDef err (T.unpack s) in
case n of 0 -> (Gt, 0)
_ -> (AbsGt, n)
(T.stripPrefix "=" -> Just s) -> (AbsEq, readDef err (T.unpack s))
s -> (AbsEq, readDef err (T.unpack s))
where
err = error' $ "could not parse as '=', '<', or '>' (optional) followed by a (optionally signed) numeric quantity: " ++ T.unpack s'
tests_parseAmountQueryTerm = [
"parseAmountQueryTerm" ~: do
let s `gives` r = parseAmountQueryTerm s `is` r
"<0" `gives` (Lt,0)
">0" `gives` (Gt,0)
">10000.10" `gives` (AbsGt,10000.1)
"=0.23" `gives` (AbsEq,0.23)
"0.23" `gives` (AbsEq,0.23)
"<=+0.23" `gives` (LtEq,0.23)
"-0.23" `gives` (Eq,(0.23))
]
parseTag :: T.Text -> (Regexp, Maybe Regexp)
parseTag s | "=" `T.isInfixOf` s = (T.unpack n, Just $ tail $ T.unpack v)
| otherwise = (T.unpack s, Nothing)
where (n,v) = T.break (=='=') s
parseStatus :: T.Text -> Either String ClearedStatus
parseStatus s | s `elem` ["*","1"] = Right Cleared
| s `elem` ["!"] = Right Pending
| s `elem` ["","0"] = Right Uncleared
| otherwise = Left $ "could not parse "++show s++" as a status (should be *, ! or empty)"
parseBool :: T.Text -> Bool
parseBool s = s `elem` truestrings
truestrings :: [T.Text]
truestrings = ["1"]
simplifyQuery :: Query -> Query
simplifyQuery q =
let q' = simplify q
in if q' == q then q else simplifyQuery q'
where
simplify (And []) = Any
simplify (And [q]) = simplify q
simplify (And qs) | same qs = simplify $ head qs
| any (==None) qs = None
| all queryIsDate qs = Date $ spansIntersect $ mapMaybe queryTermDateSpan qs
| otherwise = And $ concat $ [map simplify dateqs, map simplify otherqs]
where (dateqs, otherqs) = partition queryIsDate $ filter (/=Any) qs
simplify (Or []) = Any
simplify (Or [q]) = simplifyQuery q
simplify (Or qs) | same qs = simplify $ head qs
| any (==Any) qs = Any
| otherwise = Or $ map simplify $ filter (/=None) qs
simplify (Date (DateSpan Nothing Nothing)) = Any
simplify (Date2 (DateSpan Nothing Nothing)) = Any
simplify q = q
tests_simplifyQuery = [
"simplifyQuery" ~: do
let q `gives` r = assertEqual "" r (simplifyQuery q)
Or [Acct "a"] `gives` Acct "a"
Or [Any,None] `gives` Any
And [Any,None] `gives` None
And [Any,Any] `gives` Any
And [Acct "b",Any] `gives` Acct "b"
And [Any,And [Date (DateSpan Nothing Nothing)]] `gives` Any
And [Date (DateSpan Nothing (Just $ parsedate "2013-01-01")), Date (DateSpan (Just $ parsedate "2012-01-01") Nothing)]
`gives` Date (DateSpan (Just $ parsedate "2012-01-01") (Just $ parsedate "2013-01-01"))
And [Or [],Or [Desc "b b"]] `gives` Desc "b b"
]
same [] = True
same (a:as) = all (a==) as
filterQuery :: (Query -> Bool) -> Query -> Query
filterQuery p = simplifyQuery . filterQuery' p
filterQuery' :: (Query -> Bool) -> Query -> Query
filterQuery' p (And qs) = And $ map (filterQuery p) qs
filterQuery' p (Or qs) = Or $ map (filterQuery p) qs
filterQuery' p q = if p q then q else Any
tests_filterQuery = [
"filterQuery" ~: do
let (q,p) `gives` r = assertEqual "" r (filterQuery p q)
(Any, queryIsDepth) `gives` Any
(Depth 1, queryIsDepth) `gives` Depth 1
(And [And [Status Cleared,Depth 1]], not . queryIsDepth) `gives` Status Cleared
]
queryIsNull :: Query -> Bool
queryIsNull Any = True
queryIsNull (And []) = True
queryIsNull (Not (Or [])) = True
queryIsNull _ = False
queryIsDepth :: Query -> Bool
queryIsDepth (Depth _) = True
queryIsDepth _ = False
queryIsDate :: Query -> Bool
queryIsDate (Date _) = True
queryIsDate _ = False
queryIsDate2 :: Query -> Bool
queryIsDate2 (Date2 _) = True
queryIsDate2 _ = False
queryIsDateOrDate2 :: Query -> Bool
queryIsDateOrDate2 (Date _) = True
queryIsDateOrDate2 (Date2 _) = True
queryIsDateOrDate2 _ = False
queryIsDesc :: Query -> Bool
queryIsDesc (Desc _) = True
queryIsDesc _ = False
queryIsAcct :: Query -> Bool
queryIsAcct (Acct _) = True
queryIsAcct _ = False
queryIsSym :: Query -> Bool
queryIsSym (Sym _) = True
queryIsSym _ = False
queryIsReal :: Query -> Bool
queryIsReal (Real _) = True
queryIsReal _ = False
queryIsStatus :: Query -> Bool
queryIsStatus (Status _) = True
queryIsStatus _ = False
queryIsEmpty :: Query -> Bool
queryIsEmpty (Empty _) = True
queryIsEmpty _ = False
queryIsStartDateOnly :: Bool -> Query -> Bool
queryIsStartDateOnly _ Any = False
queryIsStartDateOnly _ None = False
queryIsStartDateOnly secondary (Or ms) = and $ map (queryIsStartDateOnly secondary) ms
queryIsStartDateOnly secondary (And ms) = and $ map (queryIsStartDateOnly secondary) ms
queryIsStartDateOnly False (Date (DateSpan (Just _) _)) = True
queryIsStartDateOnly True (Date2 (DateSpan (Just _) _)) = True
queryIsStartDateOnly _ _ = False
queryStartDate :: Bool -> Query -> Maybe Day
queryStartDate secondary (Or ms) = earliestMaybeDate $ map (queryStartDate secondary) ms
queryStartDate secondary (And ms) = latestMaybeDate $ map (queryStartDate secondary) ms
queryStartDate False (Date (DateSpan (Just d) _)) = Just d
queryStartDate True (Date2 (DateSpan (Just d) _)) = Just d
queryStartDate _ _ = Nothing
queryEndDate :: Bool -> Query -> Maybe Day
queryEndDate secondary (Or ms) = latestMaybeDate' $ map (queryEndDate secondary) ms
queryEndDate secondary (And ms) = earliestMaybeDate' $ map (queryEndDate secondary) ms
queryEndDate False (Date (DateSpan _ (Just d))) = Just d
queryEndDate True (Date2 (DateSpan _ (Just d))) = Just d
queryEndDate _ _ = Nothing
queryTermDateSpan (Date span) = Just span
queryTermDateSpan _ = Nothing
queryDateSpan :: Bool -> Query -> DateSpan
queryDateSpan secondary q = spansUnion $ queryDateSpans secondary q
queryDateSpans :: Bool -> Query -> [DateSpan]
queryDateSpans secondary (Or qs) = concatMap (queryDateSpans secondary) qs
queryDateSpans secondary (And qs) = concatMap (queryDateSpans secondary) qs
queryDateSpans False (Date span) = [span]
queryDateSpans True (Date2 span) = [span]
queryDateSpans _ _ = []
queryDateSpan' :: Query -> DateSpan
queryDateSpan' q = spansUnion $ queryDateSpans' q
queryDateSpans' :: Query -> [DateSpan]
queryDateSpans' (Or qs) = concatMap queryDateSpans' qs
queryDateSpans' (And qs) = concatMap queryDateSpans' qs
queryDateSpans' (Date span) = [span]
queryDateSpans' (Date2 span) = [span]
queryDateSpans' _ = []
earliestMaybeDate :: [Maybe Day] -> Maybe Day
earliestMaybeDate mds = head $ sortBy compareMaybeDates mds ++ [Nothing]
latestMaybeDate :: [Maybe Day] -> Maybe Day
latestMaybeDate = headDef Nothing . sortBy (flip compareMaybeDates)
earliestMaybeDate' :: [Maybe Day] -> Maybe Day
earliestMaybeDate' = headDef Nothing . sortBy compareMaybeDates . filter isJust
latestMaybeDate' :: [Maybe Day] -> Maybe Day
latestMaybeDate' = headDef Nothing . sortBy (flip compareMaybeDates) . filter isJust
compareMaybeDates :: Maybe Day -> Maybe Day -> Ordering
compareMaybeDates Nothing Nothing = EQ
compareMaybeDates Nothing (Just _) = LT
compareMaybeDates (Just _) Nothing = GT
compareMaybeDates (Just a) (Just b) = compare a b
queryDepth :: Query -> Int
queryDepth q = case queryDepth' q of [] -> 99999
ds -> minimum ds
where
queryDepth' (Depth d) = [d]
queryDepth' (Or qs) = concatMap queryDepth' qs
queryDepth' (And qs) = concatMap queryDepth' qs
queryDepth' _ = []
inAccount :: [QueryOpt] -> Maybe (AccountName,Bool)
inAccount [] = Nothing
inAccount (QueryOptInAcctOnly a:_) = Just (a,False)
inAccount (QueryOptInAcct a:_) = Just (a,True)
inAccountQuery :: [QueryOpt] -> Maybe Query
inAccountQuery [] = Nothing
inAccountQuery (QueryOptInAcctOnly a : _) = Just $ Acct $ accountNameToAccountOnlyRegex a
inAccountQuery (QueryOptInAcct a : _) = Just $ Acct $ accountNameToAccountRegex a
matchesAccount :: Query -> AccountName -> Bool
matchesAccount (None) _ = False
matchesAccount (Not m) a = not $ matchesAccount m a
matchesAccount (Or ms) a = any (`matchesAccount` a) ms
matchesAccount (And ms) a = all (`matchesAccount` a) ms
matchesAccount (Acct r) a = regexMatchesCI r (T.unpack a)
matchesAccount (Depth d) a = accountNameLevel a <= d
matchesAccount (Tag _ _) _ = False
matchesAccount _ _ = True
tests_matchesAccount = [
"matchesAccount" ~: do
assertBool "positive acct match" $ matchesAccount (Acct "b:c") "a:bb:c:d"
let q `matches` a = assertBool "" $ q `matchesAccount` a
Depth 2 `matches` "a:b"
assertBool "" $ Depth 2 `matchesAccount` "a"
assertBool "" $ Depth 2 `matchesAccount` "a:b"
assertBool "" $ not $ Depth 2 `matchesAccount` "a:b:c"
assertBool "" $ Date nulldatespan `matchesAccount` "a"
assertBool "" $ Date2 nulldatespan `matchesAccount` "a"
assertBool "" $ not $ (Tag "a" Nothing) `matchesAccount` "a"
]
matchesMixedAmount :: Query -> MixedAmount -> Bool
matchesMixedAmount q (Mixed []) = q `matchesAmount` nullamt
matchesMixedAmount q (Mixed as) = any (q `matchesAmount`) as
matchesAmount :: Query -> Amount -> Bool
matchesAmount (Not q) a = not $ q `matchesAmount` a
matchesAmount (Any) _ = True
matchesAmount (None) _ = False
matchesAmount (Or qs) a = any (`matchesAmount` a) qs
matchesAmount (And qs) a = all (`matchesAmount` a) qs
matchesAmount (Amt ord n) a = compareAmount ord n a
matchesAmount (Sym r) a = regexMatchesCI ("^" ++ r ++ "$") $ T.unpack $ acommodity a
matchesAmount _ _ = True
compareAmount :: OrdPlus -> Quantity -> Amount -> Bool
compareAmount ord q Amount{aquantity=aq} = case ord of Lt -> aq < q
LtEq -> aq <= q
Gt -> aq > q
GtEq -> aq >= q
Eq -> aq == q
AbsLt -> abs aq < abs q
AbsLtEq -> abs aq <= abs q
AbsGt -> abs aq > abs q
AbsGtEq -> abs aq >= abs q
AbsEq -> abs aq == abs q
matchesPosting :: Query -> Posting -> Bool
matchesPosting (Not q) p = not $ q `matchesPosting` p
matchesPosting (Any) _ = True
matchesPosting (None) _ = False
matchesPosting (Or qs) p = any (`matchesPosting` p) qs
matchesPosting (And qs) p = all (`matchesPosting` p) qs
matchesPosting (Code r) p = regexMatchesCI r $ maybe "" (T.unpack . tcode) $ ptransaction p
matchesPosting (Desc r) p = regexMatchesCI r $ maybe "" (T.unpack . tdescription) $ ptransaction p
matchesPosting (Acct r) p = regexMatchesCI r $ T.unpack $ paccount p
matchesPosting (Date span) p = span `spanContainsDate` postingDate p
matchesPosting (Date2 span) p = span `spanContainsDate` postingDate2 p
matchesPosting (Status Uncleared) p = postingStatus p /= Cleared
matchesPosting (Status s) p = postingStatus p == s
matchesPosting (Real v) p = v == isReal p
matchesPosting q@(Depth _) Posting{paccount=a} = q `matchesAccount` a
matchesPosting q@(Amt _ _) Posting{pamount=amt} = q `matchesMixedAmount` amt
matchesPosting (Empty _) _ = True
matchesPosting (Sym r) Posting{pamount=Mixed as} = any (regexMatchesCI $ "^" ++ r ++ "$") $ map (T.unpack . acommodity) as
matchesPosting (Tag n v) p = not $ null $ matchedTags n v $ postingAllTags p
tests_matchesPosting = [
"matchesPosting" ~: do
assertBool "positive match on cleared posting status" $
(Status Cleared) `matchesPosting` nullposting{pstatus=Cleared}
assertBool "negative match on cleared posting status" $
not $ (Not $ Status Cleared) `matchesPosting` nullposting{pstatus=Cleared}
assertBool "positive match on unclered posting status" $
(Status Uncleared) `matchesPosting` nullposting{pstatus=Uncleared}
assertBool "negative match on unclered posting status" $
not $ (Not $ Status Uncleared) `matchesPosting` nullposting{pstatus=Uncleared}
assertBool "positive match on true posting status acquired from transaction" $
(Status Cleared) `matchesPosting` nullposting{pstatus=Uncleared,ptransaction=Just nulltransaction{tstatus=Cleared}}
assertBool "real:1 on real posting" $ (Real True) `matchesPosting` nullposting{ptype=RegularPosting}
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 "a" $ (Acct "'b") `matchesPosting` nullposting{paccount="'b"}
assertBool "b" $ not $ (Tag "a" (Just "r$")) `matchesPosting` nullposting
assertBool "c" $ (Tag "foo" Nothing) `matchesPosting` nullposting{ptags=[("foo","")]}
assertBool "d" $ (Tag "foo" Nothing) `matchesPosting` nullposting{ptags=[("foo","baz")]}
assertBool "e" $ (Tag "foo" (Just "a")) `matchesPosting` nullposting{ptags=[("foo","bar")]}
assertBool "f" $ not $ (Tag "foo" (Just "a$")) `matchesPosting` nullposting{ptags=[("foo","bar")]}
assertBool "g" $ not $ (Tag " foo " (Just "a")) `matchesPosting` nullposting{ptags=[("foo","bar")]}
assertBool "h" $ not $ (Tag "foo foo" (Just " ar ba ")) `matchesPosting` nullposting{ptags=[("foo foo","bar bar")]}
assertBool "i" $ (Tag "txntag" Nothing) `matchesPosting` nullposting{ptransaction=Just nulltransaction{ttags=[("txntag","")]}}
assertBool "j" $ not $ (Sym "$") `matchesPosting` nullposting{pamount=Mixed [usd 1]}
assertBool "k" $ (Sym "\\$") `matchesPosting` nullposting{pamount=Mixed [usd 1]}
assertBool "l" $ (Sym "shekels") `matchesPosting` nullposting{pamount=Mixed [amount{acommodity="shekels"}]}
assertBool "m" $ not $ (Sym "shek") `matchesPosting` nullposting{pamount=Mixed [amount{acommodity="shekels"}]}
]
matchesTransaction :: Query -> Transaction -> Bool
matchesTransaction (Not q) t = not $ q `matchesTransaction` t
matchesTransaction (Any) _ = True
matchesTransaction (None) _ = False
matchesTransaction (Or qs) t = any (`matchesTransaction` t) qs
matchesTransaction (And qs) t = all (`matchesTransaction` t) qs
matchesTransaction (Code r) t = regexMatchesCI r $ T.unpack $ tcode t
matchesTransaction (Desc r) t = regexMatchesCI r $ T.unpack $ tdescription t
matchesTransaction q@(Acct _) t = any (q `matchesPosting`) $ tpostings t
matchesTransaction (Date span) t = spanContainsDate span $ tdate t
matchesTransaction (Date2 span) t = spanContainsDate span $ transactionDate2 t
matchesTransaction (Status Uncleared) t = tstatus t /= Cleared
matchesTransaction (Status s) t = tstatus t == s
matchesTransaction (Real v) t = v == hasRealPostings t
matchesTransaction q@(Amt _ _) t = any (q `matchesPosting`) $ tpostings t
matchesTransaction (Empty _) _ = True
matchesTransaction (Depth d) t = any (Depth d `matchesPosting`) $ tpostings t
matchesTransaction q@(Sym _) t = any (q `matchesPosting`) $ tpostings t
matchesTransaction (Tag n v) t = not $ null $ matchedTags n v $ transactionAllTags t
tests_matchesTransaction = [
"matchesTransaction" ~: do
let q `matches` t = assertBool "" $ q `matchesTransaction` t
Any `matches` nulltransaction
assertBool "" $ not $ (Desc "x x") `matchesTransaction` nulltransaction{tdescription="x"}
assertBool "" $ (Desc "x x") `matchesTransaction` nulltransaction{tdescription="x x"}
assertBool "" $ (Tag "foo" (Just "a")) `matchesTransaction` nulltransaction{ttags=[("foo","bar")]}
assertBool "" $ (Tag "postingtag" Nothing) `matchesTransaction` nulltransaction{tpostings=[nullposting{ptags=[("postingtag","")]}]}
]
matchedTags :: Regexp -> Maybe Regexp -> [Tag] -> [Tag]
matchedTags namepat valuepat tags = filter (match namepat valuepat) tags
where
match npat Nothing (n,_) = regexMatchesCI npat (T.unpack n)
match npat (Just vpat) (n,v) = regexMatchesCI npat (T.unpack n) && regexMatchesCI vpat (T.unpack v)
tests_Hledger_Query :: Test
tests_Hledger_Query = TestList $
tests_simplifyQuery
++ tests_words''
++ tests_filterQuery
++ tests_parseQueryTerm
++ tests_parseAmountQueryTerm
++ tests_parseQuery
++ tests_matchesAccount
++ tests_matchesPosting
++ tests_matchesTransaction