From 6bf13fb26200947228a54c4ca7c98192d736fe2b Mon Sep 17 00:00:00 2001 From: Simon Michael Date: Sat, 10 Feb 2007 23:24:33 +0000 Subject: [PATCH] much refactoring, get quickcheck working, beginnings of account matching --- Models.hs | 115 +++++++++++++++++++++++++++++++++-------------------- Options.hs | 4 +- Parse.hs | 16 +++++--- TODO | 25 +++++++++--- Tests.hs | 73 +++++++++++++++++++++------------- hledger.hs | 40 +++++++++---------- 6 files changed, 168 insertions(+), 105 deletions(-) diff --git a/Models.hs b/Models.hs index 5be80feb3..633f6d661 100644 --- a/Models.hs +++ b/Models.hs @@ -3,7 +3,9 @@ module Models -- data types & behaviours where import Text.Printf -import List +import Data.List + +-- types data Ledger = Ledger { modifier_entries :: [ModifierEntry], @@ -36,8 +38,8 @@ data Amount = Amount { type Date = String type Account = String --- Amount arithmetic --- ignores currency conversion +-- Amount arithmetic - ignores currency conversion + instance Num Amount where abs (Amount c q) = Amount c (abs q) signum (Amount c q) = Amount c (signum q) @@ -69,16 +71,8 @@ instance Show PeriodicEntry where instance Show Entry where show = showEntry -showEntryOld :: Entry -> String -showEntryOld e = date e ++ " " ++ s ++ c ++ d ++ "\n" ++ unlines (map show (transactions e)) - where - d = description e - s = case (status e) of {True -> "* "; False -> ""} - c = case (length(code e) > 0) of {True -> (code e ++ " "); False -> ""} - -- 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 -- ... ... ... @@ -88,18 +82,22 @@ showEntryOld e = date e ++ " " ++ s ++ c ++ d ++ "\n" ++ unlines (map show (tran -- amtWidth = 10 -- balWidth = 10 +showEntry :: Entry -> String +showEntry e = unlines $ map fst (entryLines e) + -- convert an Entry to entry lines (string, amount pairs) entryLines :: Entry -> [(String,Amount)] entryLines e = - [(entrydesc ++ (show t), amount t)] - ++ map (\t -> (prependSpace $ show t, amount t)) ts + [firstline] ++ otherlines where t:ts = transactions e entrydesc = printf "%-10s %-20s " (date e) (take 20 $ description e) - prependSpace = (printf (take 32 (repeat ' ')) ++) + firstline = (entrydesc ++ (show t), amount t) + otherlines = map (\t -> (prependSpace $ show t, amount t)) ts + prependSpace = (replicate 32 ' ' ++) instance Show Transaction where - show t = printf "%-25s %10s " (take 25 $ account t) (show $ amount t) + show t = printf "%-25s %10s" (take 25 $ account t) (show $ amount t) instance Show Amount where show (Amount cur qty) = @@ -108,58 +106,87 @@ instance Show Amount where "0.00" -> "0" otherwise -> cur ++ roundedqty -showEntry :: Entry -> String -showEntry e = unlines $ map fst (entryLines e) +-- in the register report we show entries plus a running balance + +showEntriesWithBalances :: [Entry] -> Amount -> String +showEntriesWithBalances [] _ = "" +showEntriesWithBalances (e:es) b = + showEntryWithBalances e b ++ (showEntriesWithBalances es b') + where b' = b + (entryBalance e) + +entryBalance :: Entry -> Amount +entryBalance = sumTransactions . transactions + +showEntryWithBalances :: Entry -> Amount -> String +showEntryWithBalances e b = + unlines [s | (s,a,b) <- entryLinesWithBalances (entryLines e) b] --- add balances to entry lines, given a starting balance entryLinesWithBalances :: [(String,Amount)] -> Amount -> [(String,Amount,Amount)] entryLinesWithBalances [] _ = [] entryLinesWithBalances ((str,amt):els) bal = [(str',amt,bal')] ++ entryLinesWithBalances els bal' where bal' = bal + amt - str' = str ++ (printf "%10.2s" (show bal')) - -showEntryWithBalances :: Entry -> Amount -> String -showEntryWithBalances e b = unlines $ - [s | (s,a,b) <- entryLinesWithBalances (entryLines e) b] - --- show register entries, keeping a running balance -showRegisterEntries :: [Entry] -> Amount -> String -showRegisterEntries [] _ = "" -showRegisterEntries (e:es) b = - showEntryWithBalances e b ++ (showRegisterEntries es b') - where b' = b + (sumTransactions (transactions e)) + str' = str ++ (printf " %10.2s" (show bal')) -- misc --- fill in missing amounts etc., as far as possible -autofill :: Entry -> Entry -autofill e = Entry (date e) (status e) (code e) (description e) - (autofillTransactions (transactions e)) +autofillEntry :: Entry -> Entry +autofillEntry e = + Entry (date e) (status e) (code e) (description e) + (autofillTransactions (transactions e)) autofillTransactions :: [Transaction] -> [Transaction] autofillTransactions ts = - let (ns,as) = normalAndAutoTransactions ts in + let (ns, as) = normalAndAutoTransactions ts in case (length as) of 0 -> ns - 1 -> ns ++ [Transaction (account (head as)) (-(sumTransactions ns))] + 1 -> ns ++ [balanceTransaction $ head as] + where balanceTransaction t = t{amount = -(sumTransactions ns)} otherwise -> error "too many blank transactions in this entry" normalAndAutoTransactions :: [Transaction] -> ([Transaction], [Transaction]) -normalAndAutoTransactions ts = - ([t | t <- ts, (currency $ amount t) /= "AUTO"], - [t | t <- ts, (currency $ amount t) == "AUTO"]) +normalAndAutoTransactions ts = + partition isNormal ts + where isNormal t = (currency $ amount t) /= "AUTO" sumTransactions :: [Transaction] -> Amount sumTransactions ts = sum [amount t | t <- ts] -transactionsFrom :: [Entry] -> [Transaction] -transactionsFrom es = concat $ map transactions es +transactionsFromEntries :: [Entry] -> [Transaction] +transactionsFromEntries es = concat $ map transactions es -accountsFrom :: [Transaction] -> [Account] -accountsFrom ts = nub $ map account ts +accountsFromTransactions :: [Transaction] -> [Account] +accountsFromTransactions ts = nub $ map account ts accountsUsed :: Ledger -> [Account] -accountsUsed l = accountsFrom $ transactionsFrom $ entries l +accountsUsed l = accountsFromTransactions $ transactionsFromEntries $ entries l +-- ["a:b:c","d:e"] -> ["a","a:b","a:b:c","d","d:e"] +expandAccounts :: [Account] -> [Account] +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' + +accountTree :: Ledger -> [Account] +accountTree = sort . expandAccounts . accountsUsed + +entriesMatching :: String -> Ledger -> [Entry] +entriesMatching s l = filterEntriesByAccount s (entries l) + +filterEntriesByAccount :: String -> [Entry] -> [Entry] +filterEntriesByAccount s es = filter (matchEntryAccount s) es + +matchEntryAccount :: String -> Entry -> Bool +matchEntryAccount s e = any (matchTransactionAccount s) (transactions e) + +matchTransactionAccount :: String -> Transaction -> Bool +matchTransactionAccount s t = s `isInfixOf` (account t) diff --git a/Options.hs b/Options.hs index 3bdfe19a3..69a8cfd2e 100644 --- a/Options.hs +++ b/Options.hs @@ -31,6 +31,6 @@ get_content (File s) = Just s --defaultLedgerFile = tildeExpand "~/ledger.dat" defaultLedgerFile = "ledger.dat" -ledgerFilePath :: IO String -ledgerFilePath = do +getLedgerFilePath :: IO String +getLedgerFilePath = do getEnv "LEDGER" `catch` \_ -> return defaultLedgerFile >>= return diff --git a/Parse.hs b/Parse.hs index 20ad6eb53..24cf1b856 100644 --- a/Parse.hs +++ b/Parse.hs @@ -182,7 +182,7 @@ ledgerentry = do transactions <- ledgertransactions ledgernondatalines let entry = Entry date status code description transactions - return $ autofill entry + return $ autofillEntry entry ledgerdate :: Parser String ledgerdate = do date <- many1 (digit <|> char '/'); many1 spacenonewline; return date @@ -235,11 +235,15 @@ whiteSpace1 :: Parser () whiteSpace1 = do space; whiteSpace --- ok, what can we do with it ? - -printParseResult r = case r of - Left e -> parseError e - Right v -> print v +-- utils +parseError :: (Show a) => a -> IO () parseError e = do putStr "ledger parse error at "; print e +printParseResult :: Show v => Either ParseError v -> IO () +printParseResult r = case r of Left e -> parseError e + Right v -> print v + +parseLedgerFile :: String -> IO (Either ParseError Ledger) +parseLedgerFile f = parseFromFile ledger f + diff --git a/TODO b/TODO index 4b9b49e35..df95edd10 100644 --- a/TODO +++ b/TODO @@ -1,9 +1,24 @@ features + register + account matching + match transactions, not entries + +$ ledger reg equi +2007/01/01 opening balance equity:opening balan.. $-4.82 $-4.82 +2007/01/25 balance adjustment equity $91.15 $86.33 +$ hledger reg equi +2007/01/01 opening balance assets:cash $4.82 $4.82 + equity:opening balances $-4.82 0 +2007/01/25 balance adjustment equity $91.15 $91.15 + assets:cash $-91.15 0 + description matching + regexp matching + balance - show top-level acct balance - show per-account balances + show top-level acct balances + show all account balances + print - matching by account/description regexp more directives, eg include read timelog files -p period expressions @@ -14,13 +29,11 @@ features read gnucash files testing - get quickcheck working - consider hunit dsl ledger regression/compatibility tests environment cleaner option processing - smart ledger file finding + robust ledger file finding documentation literate docs diff --git a/Tests.hs b/Tests.hs index 4208902d5..252659c0b 100644 --- a/Tests.hs +++ b/Tests.hs @@ -202,15 +202,21 @@ ledger7 = Ledger [] [] -- utils +assertEqual' e a = assertEqual "" e a + +parse' p ts = parse p "" ts + assertParseEqual :: (Show a, Eq a) => a -> (Either ParseError a) -> Assertion assertParseEqual expected parsed = case parsed of Left e -> parseError e - Right v -> assertEqual " " expected v + Right v -> assertEqual " " expected v -assertEqual' e a = assertEqual "" e a - -parse' p ts = parse p "" ts +parseEquals :: Eq a => (Either ParseError a) -> a -> Bool +parseEquals parsed other = + case parsed of + Left e -> False + Right v -> v == other -- hunit tests @@ -229,36 +235,49 @@ parse' p ts = parse p "" ts -- parseTest ledger periodic_entry2_str -- parseLedgerFile ledgerFilePath >>= printParseResult -test_parse_ledgertransaction :: Assertion -test_parse_ledgertransaction = +test_ledgertransaction :: Assertion +test_ledgertransaction = assertParseEqual transaction1 (parse' ledgertransaction transaction1_str) -test_parse_ledgerentry = +test_ledgerentry = assertParseEqual entry1 (parse' ledgerentry entry1_str) -test_autofill_entry = +test_autofillEntry = assertEqual' - (Amount "$" (-47.18)) - (amount $ last $ transactions $ autofill entry1) + (Amount "$" (-47.18)) + (amount $ last $ transactions $ autofillEntry entry1) -tests = TestList [ - t "test_parse_ledgertransaction" test_parse_ledgertransaction - , t "test_parse_ledgerentry" test_parse_ledgerentry - , t "test_autofill_entry" test_autofill_entry - ] - where t label fn = TestLabel label $ TestCase fn +test_expandAccounts = + assertEqual' + ["assets","assets:cash","assets:checking","expenses","expenses:vacation"] + (expandAccounts ["assets:cash","assets:checking","expenses:vacation"]) -tests2 = Test.HUnit.test [ - "test1" ~: assertEqual "2 equals 2" 2 2 - ] +test_accountTree = + assertEqual' + ["assets","assets:cash","assets:checking","equity","equity:opening balances","expenses","expenses:vacation"] + (accountTree ledger7) + +tests = let t l f = TestLabel l $ TestCase f in TestList + [ + t "test_ledgertransaction" test_ledgertransaction + , t "test_ledgerentry" test_ledgerentry + , t "test_autofillEntry" test_autofillEntry + , t "test_expandAccounts" test_expandAccounts + , t "test_accountTree" test_accountTree + ] + +tests2 = Test.HUnit.test + [ + "test1" ~: assertEqual "2 equals 2" 2 2 + ] -- quickcheck properties -prop1 = 1 == 1 ---prop_test_parse_ledgertransaction = --- (Transaction "expenses:food:dining" (Amount "$" 10)) == --- (parse' ledgertransaction transaction_str)) - -props = [ - prop1 - ] \ No newline at end of file +props = + [ + (parse' ledgertransaction transaction1_str) `parseEquals` + (Transaction "expenses:food:dining" (Amount "$" 10)) + , + (accountTree ledger7) == + ["assets","assets:cash","assets:checking","equity","equity:opening balances","expenses","expenses:vacation"] + ] diff --git a/hledger.hs b/hledger.hs index 72091c4f6..b488ae7f9 100644 --- a/hledger.hs +++ b/hledger.hs @@ -6,8 +6,8 @@ module Main -- almost all IO is handled here where -import System (getArgs) -import Data.List (isPrefixOf) +import System +import Data.List import Test.HUnit (runTestTT) import Test.QuickCheck (quickCheck) import Text.ParserCombinators.Parsec (parseFromFile, ParseError) @@ -33,32 +33,32 @@ main = do test :: IO () test = do - putStrLn "hunit " - runTestTT tests - putStr "quickcheck " - mapM quickCheck props + hcounts <- runTestTT tests + qcounts <- mapM quickCheck props + --print $ "hunit: " ++ (showHunitCounts hcounts) + --print $ "quickcheck: " ++ (concat $ intersperse " " $ map show qcounts) return () + where showHunitCounts c = + reverse $ tail $ reverse ("passed " ++ (unwords $ drop 5 $ words (show c))) register :: [String] -> IO () register args = do - p <- parseLedgerFile ledgerFilePath - case p of Left e -> parseError e - Right l -> printRegister l + getLedgerFilePath >>= parseLedgerFile >>= doWithParsed (printRegister args) balance :: [String] -> IO () -balance args = do - p <- parseLedgerFile ledgerFilePath - case p of Left e -> parseError e - Right l -> printBalances l +balance args = + return () -- utils -parseLedgerFile :: IO String -> IO (Either ParseError Ledger) -parseLedgerFile f = f >>= parseFromFile ledger +-- doWithLedgerFile = +-- getLedgerFilePath >>= parseLedgerFile >>= doWithParsed -printRegister :: Ledger -> IO () -printRegister l = putStr $ showRegisterEntries (entries l) 0 - -printBalances :: Ledger -> IO () -printBalances l = putStr $ showRegisterEntries (entries l) 0 +doWithParsed :: (a -> IO ()) -> (Either ParseError a) -> IO () +doWithParsed a p = + case p of Left e -> parseError e + Right v -> a v +printRegister :: [String] -> Ledger -> IO () +printRegister args ledger = + putStr $ showEntriesWithBalances (entriesMatching (head (args ++ [""])) ledger) 0