module Hledger.Query (
Query(..),
QueryOpt(..),
parseQuery,
simplifyQuery,
filterQuery,
queryIsNull,
queryIsDepth,
queryIsDate,
queryIsStartDateOnly,
queryStartDate,
queryDateSpan,
queryDepth,
queryEmpty,
inAccount,
inAccountQuery,
matchesAccount,
matchesPosting,
matchesTransaction,
tests_Hledger_Query
)
where
import Data.Either
import Data.List
import Data.Maybe
import Data.Time.Calendar
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.Dates
import Hledger.Data.Posting
import Hledger.Data.Transaction
data Query = Any
| None
| Not Query
| Or [Query]
| And [Query]
| Desc String
| Acct String
| Date DateSpan
| EDate DateSpan
| Status Bool
| Real Bool
| Empty Bool
| Depth Int
| Tag String (Maybe String)
deriving (Show, Eq)
data QueryOpt = QueryOptInAcctOnly AccountName
| QueryOptInAcct AccountName
deriving (Show, Eq)
parseQuery :: Day -> String -> (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'' :: [String] -> String -> [String]
words'' prefixes = fromparse . parsewith maybeprefixedquotedphrases
where
maybeprefixedquotedphrases = choice' [prefixedQuotedPattern, quotedPattern, pattern] `sepBy` many1 spacenonewline
prefixedQuotedPattern = do
not' <- fromMaybe "" `fmap` (optionMaybe $ string "not:")
let allowednexts | null not' = prefixes
| otherwise = prefixes ++ [""]
next <- choice' $ map string allowednexts
let prefix = not' ++ next
p <- quotedPattern
return $ prefix ++ stripquotes p
quotedPattern = do
p <- between (oneOf "'\"") (oneOf "'\"") $ many $ noneOf "'\""
return $ stripquotes p
pattern = many (noneOf " \n\r")
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 = map (++":") [
"inacctonly"
,"inacct"
,"desc"
,"acct"
,"date"
,"edate"
,"status"
,"real"
,"empty"
,"depth"
,"tag"
]
defaultprefix = "acct"
parseQueryTerm :: Day -> String -> Either Query QueryOpt
parseQueryTerm _ ('i':'n':'a':'c':'c':'t':'o':'n':'l':'y':':':s) = Right $ QueryOptInAcctOnly s
parseQueryTerm _ ('i':'n':'a':'c':'c':'t':':':s) = Right $ QueryOptInAcct s
parseQueryTerm d ('n':'o':'t':':':s) = case parseQueryTerm d s of
Left m -> Left $ Not m
Right _ -> Left Any
parseQueryTerm _ ('d':'e':'s':'c':':':s) = Left $ Desc s
parseQueryTerm _ ('a':'c':'c':'t':':':s) = Left $ Acct s
parseQueryTerm d ('d':'a':'t':'e':':':s) =
case parsePeriodExpr d s of Left _ -> Left None
Right (_,span) -> Left $ Date span
parseQueryTerm d ('e':'d':'a':'t':'e':':':s) =
case parsePeriodExpr d s of Left _ -> Left None
Right (_,span) -> Left $ EDate span
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
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 True)
"status:0" `gives` (Left $ Status False)
"status:" `gives` (Left $ Status False)
"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"))
]
parseTag :: String -> (String, Maybe String)
parseTag s | '=' `elem` s = (n, Just $ tail v)
| otherwise = (s, Nothing)
where (n,v) = break (=='=') s
parseStatus :: String -> Bool
parseStatus s = s `elem` (truestrings ++ ["*"])
parseBool :: String -> Bool
parseBool s = s `elem` truestrings
truestrings :: [String]
truestrings = ["1","t","true"]
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 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 True,Depth 1]], not . queryIsDepth) `gives` Status True
]
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
queryIsDesc :: Query -> Bool
queryIsDesc (Desc _) = True
queryIsDesc _ = False
queryIsAcct :: Query -> Bool
queryIsAcct (Acct _) = True
queryIsAcct _ = False
queryIsStartDateOnly :: Bool -> Query -> Bool
queryIsStartDateOnly _ Any = False
queryIsStartDateOnly _ None = False
queryIsStartDateOnly effective (Or ms) = and $ map (queryIsStartDateOnly effective) ms
queryIsStartDateOnly effective (And ms) = and $ map (queryIsStartDateOnly effective) ms
queryIsStartDateOnly False (Date (DateSpan (Just _) _)) = True
queryIsStartDateOnly True (EDate (DateSpan (Just _) _)) = True
queryIsStartDateOnly _ _ = False
queryStartDate :: Bool -> Query -> Maybe Day
queryStartDate effective (Or ms) = earliestMaybeDate $ map (queryStartDate effective) ms
queryStartDate effective (And ms) = latestMaybeDate $ map (queryStartDate effective) ms
queryStartDate False (Date (DateSpan (Just d) _)) = Just d
queryStartDate True (EDate (DateSpan (Just d) _)) = Just d
queryStartDate _ _ = Nothing
queryTermDateSpan (Date span) = Just span
queryTermDateSpan _ = Nothing
queryDateSpan :: Bool -> Query -> DateSpan
queryDateSpan effective q = spansUnion $ queryDateSpans effective q
queryDateSpans :: Bool -> Query -> [DateSpan]
queryDateSpans effective (Or qs) = concatMap (queryDateSpans effective) qs
queryDateSpans effective (And qs) = concatMap (queryDateSpans effective) qs
queryDateSpans False (Date span) = [span]
queryDateSpans True (EDate span) = [span]
queryDateSpans _ _ = []
earliestMaybeDate :: [Maybe Day] -> Maybe Day
earliestMaybeDate = headDef Nothing . sortBy compareMaybeDates
latestMaybeDate :: [Maybe Day] -> Maybe Day
latestMaybeDate = headDef Nothing . sortBy (flip compareMaybeDates)
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' _ = []
queryEmpty :: Query -> Bool
queryEmpty = headDef False . queryEmpty'
where
queryEmpty' (Empty v) = [v]
queryEmpty' (Or qs) = concatMap queryEmpty' qs
queryEmpty' (And qs) = concatMap queryEmpty' qs
queryEmpty' _ = []
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 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 "" $ EDate nulldatespan `matchesAccount` "a"
assertBool "" $ not $ (Tag "a" Nothing) `matchesAccount` "a"
]
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 (Desc r) p = regexMatchesCI r $ maybe "" tdescription $ ptransaction p
matchesPosting (Acct r) p = regexMatchesCI r $ paccount p
matchesPosting (Date span) p =
case d of Just d' -> spanContainsDate span d'
Nothing -> False
where d = maybe Nothing (Just . tdate) $ ptransaction p
matchesPosting (EDate span) p =
case postingEffectiveDate p of Just d -> spanContainsDate span d
Nothing -> False
matchesPosting (Status v) p = v == postingCleared p
matchesPosting (Real v) p = v == isReal p
matchesPosting (Depth d) Posting{paccount=a} = Depth d `matchesAccount` 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
tests_matchesPosting = [
"matchesPosting" ~: do
assertBool "positive match on true posting status" $
(Status True) `matchesPosting` nullposting{pstatus=True}
assertBool "negative match on true posting status" $
not $ (Not $ Status True) `matchesPosting` nullposting{pstatus=True}
assertBool "positive match on false posting status" $
(Status False) `matchesPosting` nullposting{pstatus=False}
assertBool "negative match on false posting status" $
not $ (Not $ Status False) `matchesPosting` nullposting{pstatus=False}
assertBool "positive match on true posting status acquired from transaction" $
(Status True) `matchesPosting` nullposting{pstatus=False,ptransaction=Just nulltransaction{tstatus=True}}
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 "" $ (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")]}
assertBool "" $ (Tag "txntag" Nothing) `matchesPosting` nullposting{ptransaction=Just nulltransaction{ttags=[("txntag","")]}}
]
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 (Desc r) t = regexMatchesCI r $ tdescription t
matchesTransaction q@(Acct _) t = any (q `matchesPosting`) $ tpostings t
matchesTransaction (Date span) t = spanContainsDate span $ tdate t
matchesTransaction (EDate span) t = spanContainsDate span $ transactionEffectiveDate t
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
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 "" $ 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
tests_Hledger_Query :: Test
tests_Hledger_Query = TestList $
tests_simplifyQuery
++ tests_words''
++ tests_filterQuery
++ tests_parseQueryTerm
++ tests_parseQuery
++ tests_matchesAccount
++ tests_matchesPosting
++ tests_matchesTransaction