ledger-style account and description regexp matching

Models.hs

@@ -3,8 +3,11 @@ module Models -- data types & behaviours
 where
 
 import Text.Printf
+import Text.Regex
 import Data.List
 
+import Utils
+
 -- basic types
 
 type Date = String
@@ -17,7 +20,7 @@ type Account = String
 data Amount = Amount {
                       currency :: String,
                       quantity :: Double
-                     } deriving (Eq)
+                     } deriving (Eq,Ord)
 
 instance Num Amount where
     abs (Amount c q) = Amount c (abs q)
@@ -57,15 +60,15 @@ instance Show PeriodicEntry where
 
 -- entries
 -- a register entry is displayed as two or more lines like this:
--- date       description          account                    amount     balance
--- DDDDDDDDDD dddddddddddddddddddd aaaaaaaaaaaaaaaaaaaaaaaaa  AAAAAAAAAA AAAAAAAAAA
---                                 aaaaaaaaaaaaaaaaaaaaaaaaa  AAAAAAAAAA AAAAAAAAAA
---                                 ...                        ...        ...
+-- date       description          account                amount       balance
+-- DDDDDDDDDD dddddddddddddddddddd aaaaaaaaaaaaaaaaaaaaa  AAAAAAAAAAAA AAAAAAAAAAAA
+--                                 aaaaaaaaaaaaaaaaaaaaa  AAAAAAAAAAAA AAAAAAAAAAAA
+--                                 ...                    ...          ...
 -- dateWidth = 10
 -- descWidth = 20
--- acctWidth = 25
--- amtWidth  = 10
--- balWidth  = 10
+-- acctWidth = 21
+-- amtWidth  = 12
+-- balWidth  = 12
 
 data Entry = Entry {
                     edate :: Date,
@@ -73,7 +76,7 @@ data Entry = Entry {
                     ecode :: String,
                     edescription :: String,
                     etransactions :: [Transaction]
-                   } deriving (Eq)
+                   } deriving (Eq,Ord)
 
 instance Show Entry where show = showEntry
 
@@ -92,11 +95,11 @@ autofillEntry e =
 data Transaction = Transaction {
                                 taccount :: Account,
                                 tamount :: Amount
-                               } deriving (Eq)
+                               } deriving (Eq,Ord)
 
 instance Show Transaction where show = showTransaction
 
-showTransaction t = printf "%-25s  %10s" (take 25 $ taccount t) (show $ tamount t)
+showTransaction t = printf "%-21s  %12.2s" (take 21 $ taccount t) (show $ tamount t)
 
 autofillTransactions :: [Transaction] -> [Transaction]
 autofillTransactions ts =
@@ -135,10 +138,16 @@ entryTransactionsFrom :: [Entry] -> [EntryTransaction]
 entryTransactionsFrom es = concat $ map flattenEntry es
 
 matchTransactionAccount :: String -> EntryTransaction -> Bool
-matchTransactionAccount s t = s `isInfixOf` (account t)
+matchTransactionAccount s t =
+    case matchRegex (mkRegex s) (account t) of
+      Nothing -> False
+      otherwise -> True
 
 matchTransactionDescription :: String -> EntryTransaction -> Bool
-matchTransactionDescription s t = s `isInfixOf` (description t)
+matchTransactionDescription s t =
+    case matchRegex (mkRegex s) (description t) of
+      Nothing -> False
+      otherwise -> True
 
 showTransactionsWithBalances :: [EntryTransaction] -> Amount -> String
 showTransactionsWithBalances [] _ = []
@@ -162,7 +171,7 @@ showTransactionAndBalance :: EntryTransaction -> Amount -> String
 showTransactionAndBalance t b =
     (replicate 32 ' ') ++ (showTransaction $ transaction t) ++ (showBalance b)
 
-showBalance b = printf " %10.2s" (show b)
+showBalance b = printf " %12.2s" (show b)
 
 -- accounts
 
@@ -175,14 +184,6 @@ expandAccounts l = nub $ concat $ map expand l
                 where
                   expand l' = map (concat . intersperse ":") (tail $ inits $ splitAtElement ':' l')
 
-splitAtElement :: Eq a => a -> [a] -> [[a]]
-splitAtElement e l = 
-    case dropWhile (e==) l of
-      [] -> []
-      l' -> first : splitAtElement e rest
-        where
-          (first,rest) = break (e==) l'
-
 -- ledger
 
 data Ledger = Ledger {
@@ -210,6 +211,12 @@ ledgerAccountTree = sort . expandAccounts . ledgerAccountsUsed
 ledgerTransactions :: Ledger -> [EntryTransaction]
 ledgerTransactions l = entryTransactionsFrom $ entries l
 
-ledgerTransactionsMatching :: String -> Ledger -> [EntryTransaction]
-ledgerTransactionsMatching s l = filter (\t -> matchTransactionAccount s t) (ledgerTransactions l)
-
+ledgerTransactionsMatching :: ([String],[String]) -> Ledger -> [EntryTransaction]
+ledgerTransactionsMatching ([],[]) l = ledgerTransactionsMatching ([".*"],[".*"]) l
+ledgerTransactionsMatching (rs,[]) l = ledgerTransactionsMatching (rs,[".*"]) l
+ledgerTransactionsMatching ([],rs) l = ledgerTransactionsMatching ([".*"],rs) l
+ledgerTransactionsMatching (acctregexps,descregexps) l =
+    intersect 
+    (concat [filter (matchTransactionAccount r) ts | r <- acctregexps])
+    (concat [filter (matchTransactionDescription r) ts | r <- descregexps])
+    where ts = ledgerTransactions l

Options.hs

@@ -7,12 +7,14 @@ import Data.Maybe ( fromMaybe )
 import System.Environment (getEnv)
 --import TildeExpand -- confuses my ghc 6.7
     
+import Utils
+
 data Flag = File String | Version deriving Show
     
 options :: [OptDescr Flag]
 options = [
-           Option ['f']     ["file"] (OptArg inp "FILE") "ledger file, or - to read stdin"
-          , Option ['v'] ["version"] (NoArg Version) "show version number"
+            Option ['f'] ["file"]    (OptArg inp "FILE") "ledger file, or - to read stdin"
+          , Option ['v'] ["version"] (NoArg Version)     "show version number"
           ]
 
 inp :: Maybe String -> Flag
@@ -20,7 +22,7 @@ inp  = File . fromMaybe "stdin"
     
 getOptions :: [String] -> IO ([Flag], [String])
 getOptions argv =
-    case getOpt Permute options argv of
+    case getOpt RequireOrder options argv of
       (o,n,[]  ) -> return (o,n)
       (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))
         where header = "Usage: hledger [OPTIONS]"
@@ -34,3 +36,11 @@ defaultLedgerFile = "ledger.dat"
 getLedgerFilePath :: IO String
 getLedgerFilePath = do
   getEnv "LEDGER" `catch` \_ -> return defaultLedgerFile >>= return
+
+-- ledger pattern args are a list of account patterns optionally followed
+-- by -- and a list of description patterns
+ledgerPatternArgs :: [String] -> ([String],[String])
+ledgerPatternArgs args = 
+    case "--" `elem` args of
+      True -> ((takeWhile (/= "--") args), tail $ (dropWhile (/= "--") args))
+      False -> (args,[])

TODO

@@ -25,6 +25,7 @@ environment
  robust ledger file finding
 
 documentation
+ --help
  literate docs
  haddock
 

Tests.hs

@@ -282,4 +282,13 @@ props =
     ,
      ledgerAccountTree ledger7 == 
      ["assets","assets:cash","assets:checking","equity","equity:opening balances","expenses","expenses:vacation"]
+    ,
+     ledgerPatternArgs [] == ([],[])
+    ,ledgerPatternArgs ["a"] == (["a"],[])
+    ,ledgerPatternArgs ["a","b"] == (["a","b"],[])
+    ,ledgerPatternArgs ["a","b","--"] == (["a","b"],[])
+    ,ledgerPatternArgs ["a","b","--","c","b"] == (["a","b"],["c","b"])
+    ,ledgerPatternArgs ["--","c"] == ([],["c"])
+    ,ledgerPatternArgs ["--"] == ([],[])
     ]
+

hledger.hs

@@ -61,5 +61,7 @@ doWithParsed a p =
 
 printRegister :: [String] -> Ledger -> IO ()
 printRegister args ledger =
-    putStr $ showTransactionsWithBalances (ledgerTransactionsMatching (head (args ++ [""])) ledger) 0
-
+    putStr $ showTransactionsWithBalances 
+               (ledgerTransactionsMatching (acctpats,descpats) ledger)
+               0
+        where (acctpats,descpats) = ledgerPatternArgs args