From edbedab32c846ad3e7f108fc65feff5b5db41d74 Mon Sep 17 00:00:00 2001 From: Simon Michael Date: Tue, 13 Feb 2007 03:48:16 +0000 Subject: [PATCH] ledger-style account and description regexp matching --- Models.hs | 57 ++++++++++++++++++++++++++++++------------------------ Options.hs | 16 ++++++++++++--- TODO | 1 + Tests.hs | 9 +++++++++ hledger.hs | 6 ++++-- 5 files changed, 59 insertions(+), 30 deletions(-) diff --git a/Models.hs b/Models.hs index 37b9f1e40..a98cbc344 100644 --- a/Models.hs +++ b/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 diff --git a/Options.hs b/Options.hs index 69a8cfd2e..3d2fc67a0 100644 --- a/Options.hs +++ b/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,[]) diff --git a/TODO b/TODO index 0a9f75cba..c1ce05b7c 100644 --- a/TODO +++ b/TODO @@ -25,6 +25,7 @@ environment robust ledger file finding documentation + --help literate docs haddock diff --git a/Tests.hs b/Tests.hs index deb17c82a..e1d82a76f 100644 --- a/Tests.hs +++ b/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 ["--"] == ([],[]) ] + diff --git a/hledger.hs b/hledger.hs index 3d33868da..c50b23703 100644 --- a/hledger.hs +++ b/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