From bea6fb7464328c351b4b388935771391ea686596 Mon Sep 17 00:00:00 2001 From: Simon Michael Date: Sat, 11 Jun 2011 16:00:00 +0000 Subject: [PATCH] matcher enhancements for account register --- hledger-lib/Hledger/Data/Matching.hs | 140 ++++++++++++++++++--------- 1 file changed, 94 insertions(+), 46 deletions(-) diff --git a/hledger-lib/Hledger/Data/Matching.hs b/hledger-lib/Hledger/Data/Matching.hs index de9315be3..89d7e69ea 100644 --- a/hledger-lib/Hledger/Data/Matching.hs +++ b/hledger-lib/Hledger/Data/Matching.hs @@ -7,16 +7,16 @@ Currently used only by hledger-web. module Hledger.Data.Matching where --- import Data.List +import Data.List -- import Data.Map (findWithDefault, (!)) --- import Data.Maybe +import Data.Maybe -- import Data.Ord import Data.Time.Calendar -- import Data.Time.LocalTime -- import Data.Tree -import Safe (readDef) +import Safe (readDef, headDef) -- import System.Time (ClockTime(TOD)) --- import Test.HUnit +import Test.HUnit import Text.ParserCombinators.Parsec -- import Text.Printf -- import qualified Data.Map as Map @@ -31,23 +31,27 @@ import Hledger.Data.Dates -- import Hledger.Data.Posting -- import Hledger.Data.TimeLog --- | A more general way to match transactions and postings, successor to FilterSpec. (?) --- If the first boolean is False, it's a negative match. +-- | A matcher is an arbitrary boolean expression of various search criteria. +-- It can be used to match postings, transactions, accounts and more. +-- If the first boolean is False, it's an inverse match. +-- Currently used by hledger-web, will probably also replace FilterSpec at some point. data Matcher = MatchAny -- ^ always match | MatchOr [Matcher] -- ^ match if any of these match | MatchAnd [Matcher] -- ^ match if all of these match | MatchDesc Bool String -- ^ match if description matches this regexp | MatchAcct Bool String -- ^ match postings whose account matches this regexp - | MatchInAcct Bool String -- ^ XXX match postings whose transaction contains a posting to an account matching this regexp | MatchDate Bool DateSpan -- ^ match if actual date in this date span | MatchEDate Bool DateSpan -- ^ match if effective date in this date span | MatchStatus Bool Bool -- ^ match if cleared status has this value | MatchReal Bool Bool -- ^ match if "realness" (involves a real non-virtual account ?) has this value | MatchEmpty Bool Bool -- ^ match if "emptiness" (amount is zero ?) has this value | MatchDepth Bool Int -- ^ match if account depth is less than or equal to this value + -- XXX not sure if this belongs here + | MatchInAcct Bool String -- ^ match postings whose transaction contains a posting to an account matching this regexp deriving (Show) --- | Parse a query expression as a list of match patterns OR'd together. +-- | Parse a query expression string as a list of match patterns OR'd together. +-- The current date is required to interpret relative dates. parseMatcher :: Day -> String -> Matcher parseMatcher refdate s = MatchAnd $ map parseword $ words'' ["not:","acct:","desc:"] s where @@ -56,7 +60,7 @@ parseMatcher refdate s = MatchAnd $ map parseword $ words'' ["not:","acct:","des parseword ('d':'e':'s':'c':':':s) = MatchDesc True s parseword ('a':'c':'c':'t':':':s) = MatchAcct True s parseword ('i':'n':'a':'c':'c':'t':':':s) = MatchInAcct True s - parseword ('i':'n':':':s) = MatchInAcct True s + parseword ('i':'n':':':s) = MatchInAcct True s parseword ('d':'a':'t':'e':':':s) = MatchDate True $ spanFromSmartDateString refdate s parseword ('e':'d':'a':'t':'e':':':s) = MatchEDate True $ spanFromSmartDateString refdate s parseword ('s':'t':'a':'t':'u':'s':':':s) = MatchStatus True $ parseStatus s @@ -64,7 +68,7 @@ parseMatcher refdate s = MatchAnd $ map parseword $ words'' ["not:","acct:","des parseword ('e':'m':'p':'t':'y':':':s) = MatchEmpty True $ parseBool s parseword ('d':'e':'p':'t':'h':':':s) = MatchDepth True $ readDef 0 s parseword "" = MatchAny - parseword s = parseword $ "in:"++s + parseword s = parseword $ "acct:"++s parseStatus "*" = True parseStatus _ = False @@ -97,42 +101,7 @@ words'' prefixes = fromparse . parsewith maybeprefixedquotedphrases -- matcher :: GenParser String () Matcher -- matcher = undefined -matchesPosting :: Matcher -> Posting -> Bool -matchesPosting (MatchAny) _ = True -matchesPosting (MatchOr ms) p = any (`matchesPosting` p) ms -matchesPosting (MatchAnd ms) p = all (`matchesPosting` p) ms -matchesPosting (MatchDesc True r) p = regexMatchesCI r $ maybe "" tdescription $ ptransaction p -matchesPosting (MatchDesc False r) p = not $ (MatchDesc True r) `matchesPosting` p -matchesPosting (MatchAcct True r) p = regexMatchesCI r $ paccount p -matchesPosting (MatchAcct False r) p = not $ (MatchAcct True r) `matchesPosting` p -matchesPosting (MatchInAcct True r) p = - case ptransaction p of - Just t -> (MatchAcct True r) `matchesTransaction` t && (MatchAcct False r) `matchesPosting` p - Nothing -> False -matchesPosting (MatchInAcct False r) p = not $ (MatchInAcct True r) `matchesPosting` p -matchesPosting _ _ = False - -matchesTransaction :: Matcher -> Transaction -> Bool -matchesTransaction (MatchAny) _ = True -matchesTransaction (MatchOr ms) t = any (`matchesTransaction` t) ms -matchesTransaction (MatchAnd ms) t = all (`matchesTransaction` t) ms -matchesTransaction (MatchDesc True r) t = regexMatchesCI r $ tdescription t -matchesTransaction (MatchDesc False r) t = not $ (MatchDesc True r) `matchesTransaction` t -matchesTransaction m@(MatchAcct True _) t = any (m `matchesPosting`) $ tpostings t -matchesTransaction (MatchAcct False r) t = not $ (MatchAcct True r) `matchesTransaction` t -matchesTransaction (MatchInAcct sense r) t = (MatchAcct sense r) `matchesTransaction` t -matchesTransaction _ _ = False - --- | Does this matcher specify this account as the one we are "in" ? --- For now, does a case-insensitive exact string match on the full account name. -matchesInAccount :: Matcher -> AccountName -> Bool -matchesInAccount (MatchAny) _ = True -matchesInAccount (MatchOr ms) a = any (`matchesInAccount` a) ms -matchesInAccount (MatchAnd ms) a = all (`matchesInAccount` a) ms -matchesInAccount (MatchInAcct True r) a = lowercase r == lowercase a -- regexMatchesCI r a -matchesInAccount (MatchInAcct False r) a = not $ (MatchInAcct True r) `matchesInAccount` a -matchesInAccount _ _ = True - +-- | Convert a match expression to its inverse. negateMatch :: Matcher -> Matcher negateMatch MatchAny = MatchOr [] -- matches nothing negateMatch (MatchOr ms) = MatchAnd $ map negateMatch ms @@ -147,3 +116,82 @@ negateMatch (MatchReal sense arg) = MatchReal (not sense) arg negateMatch (MatchEmpty sense arg) = MatchEmpty (not sense) arg negateMatch (MatchDepth sense arg) = MatchDepth (not sense) arg +-- | Does the match expression match this posting ? +matchesPosting :: Matcher -> Posting -> Bool +matchesPosting (MatchAny) _ = True +matchesPosting (MatchOr ms) p = any (`matchesPosting` p) ms +matchesPosting (MatchAnd ms) p = all (`matchesPosting` p) ms +matchesPosting (MatchDesc True r) p = regexMatchesCI r $ maybe "" tdescription $ ptransaction p +matchesPosting (MatchDesc False r) p = not $ (MatchDesc True r) `matchesPosting` p +matchesPosting (MatchAcct True r) p = regexMatchesCI r $ paccount p +matchesPosting (MatchAcct False r) p = not $ (MatchAcct True r) `matchesPosting` p +matchesPosting (MatchInAcct True r) p = True + -- case ptransaction p of + -- Just t -> (MatchAcct True r) `matchesTransaction` t && (MatchAcct False r) `matchesPosting` p + -- Nothing -> False +-- matchesPosting (MatchInAcct False r) p = not $ (MatchInAcct True r) `matchesPosting` p +matchesPosting _ _ = False + +-- | Does the match expression match this transaction ? +matchesTransaction :: Matcher -> Transaction -> Bool +matchesTransaction (MatchAny) _ = True +matchesTransaction (MatchOr ms) t = any (`matchesTransaction` t) ms +matchesTransaction (MatchAnd ms) t = all (`matchesTransaction` t) ms +matchesTransaction (MatchDesc True r) t = regexMatchesCI r $ tdescription t +matchesTransaction (MatchDesc False r) t = not $ (MatchDesc True r) `matchesTransaction` t +matchesTransaction m@(MatchAcct True _) t = any (m `matchesPosting`) $ tpostings t +matchesTransaction (MatchAcct False r) t = not $ (MatchAcct True r) `matchesTransaction` t +matchesTransaction (MatchInAcct sense r) t = (MatchAcct sense r) `matchesTransaction` t +matchesTransaction _ _ = False + +-- | Does the match expression include an "in:" clause specifying this account ? +-- For now, does a case-insensitive exact string match on the full account name. +-- XXX perhaps in: should be handled separately. +matchesInAccount :: Matcher -> AccountName -> Bool +matchesInAccount (MatchAny) _ = True +matchesInAccount (MatchOr ms) a = any (`matchesInAccount` a) ms +matchesInAccount (MatchAnd ms) a = all (`matchesInAccount` a) ms +matchesInAccount (MatchInAcct True s) a = lowercase s == lowercase a -- regexMatchesCI r a +matchesInAccount (MatchInAcct False s) a = not $ (MatchInAcct True s) `matchesInAccount` a +matchesInAccount _ _ = True + +-- | Which account does the match expression specify as the one we are in, if any ? +matcherInAccount :: Matcher -> Maybe AccountName +matcherInAccount (MatchOr ms) = case catMaybes $ map matcherInAccount ms of + [a] -> Just a + (a:as@(_:_)) -> if all (==a) as then Just a else Nothing + _ -> Nothing +matcherInAccount (MatchAnd ms) = headDef Nothing $ map Just $ catMaybes $ map matcherInAccount ms +matcherInAccount (MatchInAcct True a) = Just a +matcherInAccount _ = Nothing + +-- | What start date does this matcher specify, if any ? +-- If the matcher is an OR expression, returns the earliest of the alternatives. +matcherStartDate :: Matcher -> Maybe Day +matcherStartDate (MatchOr ms) = earliestMaybeDate $ map matcherStartDate ms +matcherStartDate (MatchAnd ms) = latestMaybeDate $ map matcherStartDate ms +matcherStartDate (MatchDate True (DateSpan (Just d) _)) = Just d +matcherStartDate _ = Nothing + +-- | What is the earliest of these dates, where Nothing is earliest ? +earliestMaybeDate :: [Maybe Day] -> Maybe Day +earliestMaybeDate = headDef Nothing . sortBy compareMaybeDates + +-- | What is the latest of these dates, where Nothing is earliest ? +latestMaybeDate :: [Maybe Day] -> Maybe Day +latestMaybeDate = headDef Nothing . sortBy (flip compareMaybeDates) + +-- | Compare two maybe dates, Nothing is earliest. +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 + [ + + -- "summarisePostingsByInterval" ~: do + -- summarisePostingsByInterval (Quarters 1) Nothing False (DateSpan Nothing Nothing) [] ~?= [] + ] \ No newline at end of file