consolidate new matching support

hledger-lib/Hledger/Data.hs

@@ -13,11 +13,12 @@ module Hledger.Data (
                module Hledger.Data.Amount,
                module Hledger.Data.Commodity,
                module Hledger.Data.Dates,
-               module Hledger.Data.Transaction,
-               module Hledger.Data.Ledger,
                module Hledger.Data.Journal,
+               module Hledger.Data.Ledger,
+               module Hledger.Data.Matching,
                module Hledger.Data.Posting,
                module Hledger.Data.TimeLog,
+               module Hledger.Data.Transaction,
                module Hledger.Data.Types,
                module Hledger.Data.Utils,
                tests_Hledger_Data
@@ -28,11 +29,12 @@ import Hledger.Data.AccountName
 import Hledger.Data.Amount
 import Hledger.Data.Commodity
 import Hledger.Data.Dates
-import Hledger.Data.Transaction
-import Hledger.Data.Ledger
 import Hledger.Data.Journal
+import Hledger.Data.Ledger
+import Hledger.Data.Matching
 import Hledger.Data.Posting
 import Hledger.Data.TimeLog
+import Hledger.Data.Transaction
 import Hledger.Data.Types
 import Hledger.Data.Utils
 

hledger-lib/Hledger/Data/Journal.hs

@@ -21,6 +21,7 @@ import Hledger.Data.Dates (nulldatespan)
 import Hledger.Data.Transaction (journalTransactionWithDate,balanceTransaction)
 import Hledger.Data.Posting
 import Hledger.Data.TimeLog
+import Hledger.Data.Matching
 
 
 instance Show Journal where
@@ -101,24 +102,16 @@ journalAccountNameTree = accountNameTreeFrom . journalAccountNames
 -------------------------------------------------------------------------------
 -- filtering V2
 
--- | Keep only transactions matching the query expression.
--- filterJournalTransactions2 :: Matcher -> Journal -> Journal
--- filterJournalTransactions2 = undefined
--- pats j@Journal{jtxns=ts} = j{jtxns=filter matchdesc ts}
---     where matchdesc = matchpats pats . tdescription
-
 -- | Keep only postings matching the query expression.
 -- This can leave unbalanced transactions.
 filterJournalPostings2 :: Matcher -> Journal -> Journal
-filterJournalPostings2 m j@Journal{jtxns=ts} = j{jtxns=map filterpostings ts}
-    where filterpostings t@Transaction{tpostings=ps} = t{tpostings=filter (m `matches`) ps}
+filterJournalPostings2 m j@Journal{jtxns=ts} = j{jtxns=map filtertransactionpostings ts}
+    where
+      filtertransactionpostings t@Transaction{tpostings=ps} = t{tpostings=filter (m `matchesPosting`) ps}
 
-matches :: Matcher -> Posting -> Bool
-matches (MatchOr ms) p = any (`matches` p) ms
-matches (MatchAnd ms) p = all (`matches` p) ms
-matches (MatchAcct True r) p = containsRegex r $ paccount p
-matches (MatchAcct False r) p = not $ matches (MatchAcct True r) p
-matches _ _ = False
+-- | Keep only transactions matching the query expression.
+filterJournalTransactions2 :: Matcher -> Journal -> Journal
+filterJournalTransactions2 m j@Journal{jtxns=ts} = j{jtxns=filter (m `matchesTransaction`) ts}
 
 -------------------------------------------------------------------------------
 -- filtering V1

hledger-lib/Hledger/Data/Matching.hs

@@ -0,0 +1,133 @@
+{-|
+
+More generic matching, done in one step, unlike FilterSpec and filterJournal*. 
+Currently used only by hledger-web.
+
+-}
+
+module Hledger.Data.Matching
+where
+-- import Data.List
+-- import Data.Map (findWithDefault, (!))
+-- import Data.Maybe
+-- import Data.Ord
+import Data.Time.Calendar
+-- import Data.Time.LocalTime
+-- import Data.Tree
+import Safe (readDef)
+-- import System.Time (ClockTime(TOD))
+-- import Test.HUnit
+import Text.ParserCombinators.Parsec
+-- import Text.Printf
+-- import qualified Data.Map as Map
+
+import Hledger.Utils
+import Hledger.Data.Types
+-- import Hledger.Data.AccountName
+-- import Hledger.Data.Amount
+-- import Hledger.Data.Commodity (canonicaliseCommodities)
+import Hledger.Data.Dates
+-- import Hledger.Data.Transaction (journalTransactionWithDate,balanceTransaction)
+-- 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.
+data Matcher = MatchOr [Matcher]          -- ^ match if any match
+             | MatchAnd [Matcher]         -- ^ match if all match
+             | MatchDesc Bool String      -- ^ match if description matches this regexp
+             | MatchAcct Bool String      -- ^ match postings whose account matches this regexp
+             | MatchOtherAcct Bool String -- ^ 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
+    deriving (Show)
+
+-- | Parse a query expression as a list of match patterns OR'd together.
+parseMatcher :: Day -> String -> Matcher
+parseMatcher refdate s = MatchOr $ map parseword $ words'' ["otheracct:"] s
+  where
+    parseword :: String -> Matcher
+    parseword ('n':'o':'t':':':s) = negateMatch $ parseMatcher refdate s
+    parseword ('d':'e':'s':'c':':':s) = MatchDesc True s
+    parseword ('a':'c':'c':'t':':':s) = MatchAcct True s
+    parseword ('o':'t':'h':'e':'r':'a':'c':'c':'t':':':s) = MatchOtherAcct 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
+    parseword ('r':'e':'a':'l':':':s) = MatchReal True $ parseBool s
+    parseword ('e':'m':'p':'t':'y':':':s) = MatchEmpty True $ parseBool s
+    parseword ('d':'e':'p':'t':'h':':':s) = MatchDepth True $ readDef 0 s
+    parseword s = parseword $ "acct:"++s
+
+    parseStatus "*" = True
+    parseStatus _ = False
+
+    parseBool s = s `elem` ["t","true","1","on"]
+
+-- | Quote-and-prefix-aware version of words - don't split on spaces which
+-- are inside quotes, including quotes which may have one of the specified
+-- prefixes in front.
+words'' :: [String] -> String -> [String]
+words'' prefixes = fromparse . parsewith maybeprefixedquotedphrases
+    where
+      maybeprefixedquotedphrases = choice' [prefixedQuotedPattern, quotedPattern, pattern] `sepBy` many1 spacenonewline
+      prefixedQuotedPattern = do
+        prefix <- choice' $ map string prefixes
+        p <- quotedPattern
+        return $ prefix ++ stripquotes p
+      quotedPattern = do
+        p <- between (oneOf "'\"") (oneOf "'\"") $ many $ noneOf "'\""
+        return $ stripquotes p
+      pattern = many (noneOf " \n\r\"")
+
+-- -- | Parse the query string as a boolean tree of match patterns.
+-- parseMatcher :: String -> Matcher
+-- parseMatcher s = either (const (MatchOr [])) id $ runParser matcher () "" $ lexmatcher s
+
+-- lexmatcher :: String -> [String]
+-- lexmatcher s = words' s
+
+-- matcher :: GenParser String () Matcher
+-- matcher = undefined
+
+matchesPosting :: Matcher -> Posting -> Bool
+matchesPosting (MatchOr ms) p = any (`matchesPosting` p) ms
+matchesPosting (MatchAnd ms) p = all (`matchesPosting` p) ms
+matchesPosting (MatchDesc True r) p = regexMatches r $ maybe "" tdescription $ ptransaction p
+matchesPosting (MatchDesc False r) p = not $ (MatchDesc True r) `matchesPosting` p
+matchesPosting (MatchAcct True r) p = regexMatches r $ paccount p
+matchesPosting (MatchAcct False r) p = not $ (MatchAcct True r) `matchesPosting` p
+matchesPosting (MatchOtherAcct True r) p =
+    case ptransaction p of
+        Just t -> (MatchAcct True r) `matchesTransaction` t && (MatchAcct False r) `matchesPosting` p
+        Nothing -> False
+matchesPosting (MatchOtherAcct False r) p = not $ (MatchOtherAcct True r) `matchesPosting` p
+matchesPosting _ _ = False
+
+matchesTransaction :: Matcher -> Transaction -> Bool
+matchesTransaction (MatchOr ms) t = any (`matchesTransaction` t) ms
+matchesTransaction (MatchAnd ms) t = all (`matchesTransaction` t) ms
+matchesTransaction (MatchDesc True r) t = regexMatches 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 m@(MatchOtherAcct sense r) t = (MatchAcct sense r) `matchesTransaction` t
+matchesTransaction _ _ = False
+
+negateMatch :: Matcher -> Matcher
+negateMatch (MatchOr ms)               = MatchAnd $ map negateMatch ms
+negateMatch (MatchAnd ms)              = MatchOr $ map negateMatch ms
+negateMatch (MatchAcct sense arg)      = MatchAcct (not sense) arg
+negateMatch (MatchDesc sense arg)      = MatchDesc (not sense) arg
+negateMatch (MatchOtherAcct sense arg) = MatchOtherAcct (not sense) arg
+negateMatch (MatchDate sense arg)      = MatchDate (not sense) arg
+negateMatch (MatchEDate sense arg)     = MatchEDate (not sense) arg
+negateMatch (MatchStatus sense arg)    = MatchStatus (not sense) arg
+negateMatch (MatchReal sense arg)      = MatchReal (not sense) arg
+negateMatch (MatchEmpty sense arg)     = MatchEmpty (not sense) arg
+negateMatch (MatchDepth sense arg)     = MatchDepth (not sense) arg
+

hledger-lib/Hledger/Data/Types.hs

@@ -198,17 +198,3 @@ data FilterSpec = FilterSpec {
     ,depth     :: Maybe Int
     } deriving (Show)
 
--- | A more general way to match transactions and postings, successor to FilterSpec. (?)
--- If the first boolean is False, it's a negative match.
-data Matcher = MatchDesc Bool String          -- ^ match if description matches this regexp
-             | MatchAcct Bool String          -- ^ match postings whose account matches this regexp
-             | MatchOtherAcct Bool String -- ^ match postings whose transaction contains a posting to an account matching this regexp
-             | MatchADate 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
-             | MatchAnd [Matcher]         -- ^ match if all match
-             | MatchOr [Matcher]          -- ^ match if any match
-    deriving (Show)

hledger-web/.hledger/web/templates/registerreportitem.hamlet

@@ -1,6 +1,6 @@
 <tr.item.#{evenodd}.#{firstposting}
  <td.date>#{date}
  <td.description>#{desc}
- <td.account><a href="@{here}?a=#{acctpat}#{pparam}">#{acct}
+ <td.account><a href="@?{accturl}">#{acct}
  <td.amount align=right>#{mixedAmountAsHtml $ pamount posting}
  <td.balance align=right>#{mixedAmountAsHtml b}

hledger-web/.hledger/web/templates/topbar.hamlet

@@ -5,7 +5,5 @@
   #{version}
  <a.toprightlink href=#{manualurl} target=hledgerhelp>manual
  <h1>#{title}
- \ #
- <span#journaldesc>#{desc}
 $maybe m <- msg
  <div#message>#{m}