module Hledger.Data.Matching
where
import Data.Either
import Data.List
import Data.Maybe
import Data.Time.Calendar
import Safe (readDef, headDef)
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
data Matcher = MatchAny
| MatchNone
| MatchNot Matcher
| MatchOr [Matcher]
| MatchAnd [Matcher]
| MatchDesc String
| MatchAcct String
| MatchDate DateSpan
| MatchEDate DateSpan
| MatchStatus Bool
| MatchReal Bool
| MatchEmpty Bool
| MatchDepth Int
deriving (Show, Eq)
data QueryOpt = QueryOptInAcctOnly AccountName
| QueryOptInAcct AccountName
deriving (Show, Eq)
inAccount :: [QueryOpt] -> Maybe (AccountName,Bool)
inAccount [] = Nothing
inAccount (QueryOptInAcctOnly a:_) = Just (a,False)
inAccount (QueryOptInAcct a:_) = Just (a,True)
inAccountMatcher :: [QueryOpt] -> Maybe Matcher
inAccountMatcher [] = Nothing
inAccountMatcher (QueryOptInAcctOnly a:_) = Just $ MatchAcct $ accountNameToAccountOnlyRegex a
inAccountMatcher (QueryOptInAcct a:_) = Just $ MatchAcct $ accountNameToAccountRegex a
parseQuery :: Day -> String -> (Matcher,[QueryOpt])
parseQuery d s = (m,qopts)
where
terms = words'' prefixes s
(matchers, qopts) = partitionEithers $ map (parseMatcher d) terms
m = case matchers of [] -> MatchAny
(m':[]) -> m'
ms -> MatchAnd ms
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\"")
prefixes = map (++":") [
"inacct","inacctonly",
"desc","acct","date","edate","status","real","empty","depth"
]
defaultprefix = "acct"
parseMatcher :: Day -> String -> Either Matcher QueryOpt
parseMatcher _ ('i':'n':'a':'c':'c':'t':'o':'n':'l':'y':':':s) = Right $ QueryOptInAcctOnly s
parseMatcher _ ('i':'n':'a':'c':'c':'t':':':s) = Right $ QueryOptInAcct s
parseMatcher d ('n':'o':'t':':':s) = case parseMatcher d s of
Left m -> Left $ MatchNot m
Right _ -> Left MatchAny
parseMatcher _ ('d':'e':'s':'c':':':s) = Left $ MatchDesc s
parseMatcher _ ('a':'c':'c':'t':':':s) = Left $ MatchAcct s
parseMatcher d ('d':'a':'t':'e':':':s) =
case parsePeriodExpr d s of Left _ -> Left MatchNone
Right (_,span) -> Left $ MatchDate span
parseMatcher d ('e':'d':'a':'t':'e':':':s) =
case parsePeriodExpr d s of Left _ -> Left MatchNone
Right (_,span) -> Left $ MatchEDate span
parseMatcher _ ('s':'t':'a':'t':'u':'s':':':s) = Left $ MatchStatus $ parseStatus s
parseMatcher _ ('r':'e':'a':'l':':':s) = Left $ MatchReal $ parseBool s
parseMatcher _ ('e':'m':'p':'t':'y':':':s) = Left $ MatchEmpty $ parseBool s
parseMatcher _ ('d':'e':'p':'t':'h':':':s) = Left $ MatchDepth $ readDef 0 s
parseMatcher _ "" = Left $ MatchAny
parseMatcher d s = parseMatcher d $ defaultprefix++":"++s
parseStatus :: String -> Bool
parseStatus s = s `elem` (truestrings ++ ["*"])
parseBool :: String -> Bool
parseBool s = s `elem` truestrings
truestrings :: [String]
truestrings = ["1","t","true"]
negateMatcher :: Matcher -> Matcher
negateMatcher = MatchNot
matchesPosting :: Matcher -> Posting -> Bool
matchesPosting (MatchNot m) p = not $ matchesPosting m p
matchesPosting (MatchAny) _ = True
matchesPosting (MatchNone) _ = False
matchesPosting (MatchOr ms) p = any (`matchesPosting` p) ms
matchesPosting (MatchAnd ms) p = all (`matchesPosting` p) ms
matchesPosting (MatchDesc r) p = regexMatchesCI r $ maybe "" tdescription $ ptransaction p
matchesPosting (MatchAcct r) p = regexMatchesCI r $ paccount p
matchesPosting (MatchDate span) p =
case d of Just d' -> spanContainsDate span d'
Nothing -> False
where d = maybe Nothing (Just . tdate) $ ptransaction p
matchesPosting (MatchEDate span) p =
case postingEffectiveDate p of Just d -> spanContainsDate span d
Nothing -> False
matchesPosting (MatchStatus v) p = v == postingCleared p
matchesPosting (MatchReal v) p = v == isReal p
matchesPosting (MatchEmpty v) Posting{pamount=a} = v == isZeroMixedAmount a
matchesPosting _ _ = False
matchesTransaction :: Matcher -> Transaction -> Bool
matchesTransaction (MatchNot m) t = not $ matchesTransaction m t
matchesTransaction (MatchAny) _ = True
matchesTransaction (MatchNone) _ = False
matchesTransaction (MatchOr ms) t = any (`matchesTransaction` t) ms
matchesTransaction (MatchAnd ms) t = all (`matchesTransaction` t) ms
matchesTransaction (MatchDesc r) t = regexMatchesCI r $ tdescription t
matchesTransaction m@(MatchAcct _) t = any (m `matchesPosting`) $ tpostings t
matchesTransaction (MatchDate span) t = spanContainsDate span $ tdate t
matchesTransaction (MatchEDate span) t = spanContainsDate span $ transactionEffectiveDate t
matchesTransaction (MatchStatus v) t = v == tstatus t
matchesTransaction (MatchReal v) t = v == hasRealPostings t
matchesTransaction _ _ = False
postingEffectiveDate :: Posting -> Maybe Day
postingEffectiveDate p = maybe Nothing (Just . transactionEffectiveDate) $ ptransaction p
matchesAccount :: Matcher -> AccountName -> Bool
matchesAccount (MatchNot m) a = not $ matchesAccount m a
matchesAccount (MatchAny) _ = True
matchesAccount (MatchNone) _ = False
matchesAccount (MatchOr ms) a = any (`matchesAccount` a) ms
matchesAccount (MatchAnd ms) a = all (`matchesAccount` a) ms
matchesAccount (MatchAcct r) a = regexMatchesCI r a
matchesAccount _ _ = False
matcherStartDate :: Bool -> Matcher -> Maybe Day
matcherStartDate effective (MatchOr ms) = earliestMaybeDate $ map (matcherStartDate effective) ms
matcherStartDate effective (MatchAnd ms) = latestMaybeDate $ map (matcherStartDate effective) ms
matcherStartDate False (MatchDate (DateSpan (Just d) _)) = Just d
matcherStartDate True (MatchEDate (DateSpan (Just d) _)) = Just d
matcherStartDate _ _ = Nothing
matcherIsStartDateOnly :: Bool -> Matcher -> Bool
matcherIsStartDateOnly _ MatchAny = False
matcherIsStartDateOnly _ MatchNone = False
matcherIsStartDateOnly effective (MatchOr ms) = and $ map (matcherIsStartDateOnly effective) ms
matcherIsStartDateOnly effective (MatchAnd ms) = and $ map (matcherIsStartDateOnly effective) ms
matcherIsStartDateOnly False (MatchDate (DateSpan (Just _) _)) = True
matcherIsStartDateOnly True (MatchEDate (DateSpan (Just _) _)) = True
matcherIsStartDateOnly _ _ = False
matcherIsNull MatchAny = True
matcherIsNull (MatchAnd []) = True
matcherIsNull (MatchNot (MatchOr [])) = True
matcherIsNull _ = False
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
tests_Hledger_Data_Matching :: Test
tests_Hledger_Data_Matching = TestList
[
"parseQuery" ~: do
let d = parsedate "2011/1/1"
parseQuery d "a" `is` (MatchAcct "a", [])
parseQuery d "acct:a" `is` (MatchAcct "a", [])
parseQuery d "acct:a desc:b" `is` (MatchAnd [MatchAcct "a", MatchDesc "b"], [])
parseQuery d "\"acct:expenses:autres d\233penses\"" `is` (MatchAcct "expenses:autres d\233penses", [])
parseQuery d "not:desc:'a b'" `is` (MatchNot $ MatchDesc "a b", [])
parseQuery d "inacct:a desc:b" `is` (MatchDesc "b", [QueryOptInAcct "a"])
parseQuery d "inacct:a inacct:b" `is` (MatchAny, [QueryOptInAcct "a", QueryOptInAcct "b"])
parseQuery d "status:1" `is` (MatchStatus True, [])
parseQuery d "status:0" `is` (MatchStatus False, [])
parseQuery d "status:" `is` (MatchStatus False, [])
parseQuery d "real:1" `is` (MatchReal True, [])
,"matchesAccount" ~: do
assertBool "positive acct match" $ matchesAccount (MatchAcct "b:c") "a:bb:c:d"
,"matchesPosting" ~: do
assertBool "positive match on true posting status" $
(MatchStatus True) `matchesPosting` nullposting{pstatus=True}
assertBool "negative match on true posting status" $
not $ (MatchNot $ MatchStatus True) `matchesPosting` nullposting{pstatus=True}
assertBool "positive match on false posting status" $
(MatchStatus False) `matchesPosting` nullposting{pstatus=False}
assertBool "negative match on false posting status" $
not $ (MatchNot $ MatchStatus False) `matchesPosting` nullposting{pstatus=False}
assertBool "positive match on true posting status acquired from transaction" $
(MatchStatus True) `matchesPosting` nullposting{pstatus=False,ptransaction=Just nulltransaction{tstatus=True}}
assertBool "real:1 on real posting" $ (MatchReal True) `matchesPosting` nullposting{ptype=RegularPosting}
assertBool "real:1 on virtual posting fails" $ not $ (MatchReal True) `matchesPosting` nullposting{ptype=VirtualPosting}
assertBool "real:1 on balanced virtual posting fails" $ not $ (MatchReal True) `matchesPosting` nullposting{ptype=BalancedVirtualPosting}
,"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'")
]