From 7b32caa0aaa862f78e9b4d63c5b5806693b91922 Mon Sep 17 00:00:00 2001 From: Simon Michael Date: Thu, 15 Feb 2007 02:08:18 +0000 Subject: [PATCH] balance report, refactoring .. not finished but feeling paranoid about systems today\! --- Account.hs | 102 ++++++++++++++++++++++++++++++++ Models.hs | 169 +++++++++++++++++++++++++++++++++++++++++++++++------ Options.hs | 8 ++- TODO | 15 +++-- Tests.hs | 15 ++--- hledger.hs | 45 ++++++++------ 6 files changed, 303 insertions(+), 51 deletions(-) create mode 100644 Account.hs diff --git a/Account.hs b/Account.hs new file mode 100644 index 000000000..9b8e1d2cd --- /dev/null +++ b/Account.hs @@ -0,0 +1,102 @@ + +module Account -- +where + +import Debug.Trace +import Text.Printf +import Text.Regex +import Data.List + +import Utils + +-- AccountNames are strings like "assets:cash:petty"; from these we build +-- the chart of accounts, which should be a simple hierarchy. We could +-- almost get by with just these, but see below. +type AccountName = String + +accountNameComponents :: AccountName -> [String] +accountNameComponents = splitAtElement ':' + +accountNameFromComponents :: [String] -> AccountName +accountNameFromComponents = concat . intersperse ":" + +accountLeafName :: AccountName -> String +accountLeafName = rhead . accountNameComponents + +accountNameLevel :: AccountName -> Int +accountNameLevel = length . accountNameComponents + +-- ["a:b:c","d:e"] -> ["a","a:b","a:b:c","d","d:e"] +expandAccountNames :: [AccountName] -> [AccountName] +expandAccountNames as = nub $ concat $ map expand as + where expand as = map accountNameFromComponents (tail $ inits $ accountNameComponents as) + +-- ["a:b:c","d:e"] -> ["a","d"] +topAccountNames :: [AccountName] -> [AccountName] +topAccountNames as = [a | a <- expandAccountNames as, accountNameLevel a == 1] + +parentAccountName :: AccountName -> Maybe AccountName +parentAccountName a = + case accountNameLevel a > 1 of + True -> Just $ accountNameFromComponents $ rtail $ accountNameComponents a + False -> Nothing + +s `isSubAccountNameOf` p = + ((p ++ ":") `isPrefixOf` s) && (accountNameLevel s == (accountNameLevel p + 1)) + +subAccountNamesFrom :: [AccountName] -> AccountName -> [AccountName] +subAccountNamesFrom accts a = filter (`isSubAccountNameOf` a) accts + +matchAccountName :: String -> AccountName -> Bool +matchAccountName s a = + case matchRegex (mkRegex s) a of + Nothing -> False + otherwise -> True + +-- We need structures smart enough to eg display the account tree with +-- boring accounts elided. + +-- simple polymorphic tree. each node is a tuple of the node type and a +-- list of subtrees +newtype Tree a = Tree { unTree :: (a, [Tree a]) } deriving (Show,Eq) + +-- an Account has a name and a list of sub-accounts - ie a tree of +-- AccountNames. +type Account = Tree AccountName +atacct = fst . unTree +atsubs = snd . unTree +nullacct = Tree ("", []) + +accountFrom :: [AccountName] -> Account +accountFrom_props = + [ + accountFrom [] == nullacct, + accountFrom ["a"] == Tree ("", [Tree ("a",[])]), + accountFrom ["a","b"] == Tree ("", [Tree ("a", []), Tree ("b", [])]), + accountFrom ["a","a:b"] == Tree ("", [Tree ("a", [Tree ("a:b", [])])]), + accountFrom ["a:b"] == Tree ("", [Tree ("a", [Tree ("a:b", [])])]) + ] +accountFrom accts = + Tree ("top", accountsFrom (topAccountNames accts)) + where + accountsFrom :: [AccountName] -> [Account] + accountsFrom [] = [] + accountsFrom as = [Tree (a, accountsFrom $ subs a) | a <- as] + subs = (subAccountNamesFrom accts) + +showAccount :: Account -> String +showAccount at = showAccounts $ atsubs at + +showAccounts :: [Account] -> String +showAccounts ats = + concatMap showAccountBranch ats + where + showAccountBranch at = topacct ++ "\n" ++ subs + where + topacct = indentAccountName $ atacct at + subs = showAccounts $ atsubs at + +indentAccountName :: AccountName -> String +indentAccountName a = replicate (((accountNameLevel a) - 1) * 2) ' ' ++ (accountLeafName a) + + diff --git a/Models.hs b/Models.hs index 1cee3e484..058e040a5 100644 --- a/Models.hs +++ b/Models.hs @@ -2,17 +2,18 @@ module Models -- data types & behaviours where +import Debug.Trace import Text.Printf import Text.Regex import Data.List import Utils +import Account -- basic types type Date = String type Status = Bool -type Account = String -- amounts -- amount arithmetic currently ignores currency conversion @@ -98,15 +99,15 @@ autofillEntry e = -- transactions data Transaction = Transaction { - taccount :: Account, + taccount :: AccountName, tamount :: Amount } deriving (Eq,Ord) instance Show Transaction where show = showTransaction -showTransaction t = (showAccount $ taccount t) ++ " " ++ (showAmount $ tamount t) +showTransaction t = (showAccountName $ taccount t) ++ " " ++ (showAmount $ tamount t) showAmount amt = printf "%11s" (show amt) -showAccount s = printf "%-22s" (elideRight 22 s) +showAccountName s = printf "%-22s" (elideRight 22 s) elideRight width s = case length s > width of @@ -158,6 +159,10 @@ flattenEntry e = [(e,t) | t <- etransactions e] entryTransactionsFrom :: [Entry] -> [EntryTransaction] entryTransactionsFrom es = concat $ map flattenEntry es +sumEntryTransactions :: [EntryTransaction] -> Amount +sumEntryTransactions ets = + sumTransactions $ map transaction ets + matchTransactionAccount :: String -> EntryTransaction -> Bool matchTransactionAccount s t = case matchRegex (mkRegex s) (account t) of @@ -192,18 +197,127 @@ showTransactionAndBalance :: EntryTransaction -> Amount -> String showTransactionAndBalance t b = (replicate 32 ' ') ++ (showTransaction $ transaction t) ++ (showBalance b) +showBalance :: Amount -> String showBalance b = printf " %12s" (amountRoundedOrZero b) --- accounts +-- more account functions -accountsFromTransactions :: [EntryTransaction] -> [Account] -accountsFromTransactions ts = nub $ map account ts +accountNamesFromTransactions :: [EntryTransaction] -> [AccountName] +accountNamesFromTransactions ts = nub $ map account ts + +-- like expandAccountNames, but goes from the top down and elides accountNames +-- with only one child and no transactions. Returns accountNames paired with +-- the appropriate indented name. Eg +-- [("assets","assets"),("assets:cash:gifts"," cash:gifts"),("assets:checking"," checking")] +expandAccountNamesMostly :: Ledger -> [AccountName] -> [(AccountName, String)] +expandAccountNamesMostly l as = concat $ map (expandAccountNameMostly l) as + where + expandAccountNameMostly :: Ledger -> AccountName -> [(AccountName, String)] + expandAccountNameMostly l a = + [(acct, acctname)] ++ (concat $ map (expandAccountNameMostly l) subs) + where + subs = subAccountNames l a + txns = accountTransactionsNoSubs l a + (acct, acctname) = + case (length subs == 1) && (length txns == 0) of + False -> (a, indentAccountName a) + True -> (a, indentAccountName a ++ ":" ++ subname) + where + sub = head subs + subname = (reverse . takeWhile (/= ':') . reverse) sub + +subAccountNames :: Ledger -> AccountName -> [AccountName] +subAccountNames l a = [a' | a' <- ledgerAccountNames l, a `isSubAccountNameOf` a'] + +showAccountNamesWithBalances :: [(AccountName,String)] -> Ledger -> String +showAccountNamesWithBalances as l = + unlines $ map (showAccountNameAndBalance l) as + +showAccountNameAndBalance :: Ledger -> (AccountName, String) -> String +showAccountNameAndBalance l (a, adisplay) = + printf "%20s %s" (showBalance $ accountBalance l a) adisplay + +accountBalance :: Ledger -> AccountName -> Amount +accountBalance l a = + sumEntryTransactions (accountTransactions l a) + +accountTransactions :: Ledger -> AccountName -> [EntryTransaction] +accountTransactions l a = ledgerTransactionsMatching (["^" ++ a ++ "(:.+)?$"], []) l + +accountBalanceNoSubs :: Ledger -> AccountName -> Amount +accountBalanceNoSubs l a = + sumEntryTransactions (accountTransactionsNoSubs l a) + +accountTransactionsNoSubs :: Ledger -> AccountName -> [EntryTransaction] +accountTransactionsNoSubs l a = ledgerTransactionsMatching (["^" ++ a ++ "$"], []) l + +addDataToAccounts :: Ledger -> (Tree AccountName) -> (Tree AccountData) +addDataToAccounts l acct = + Tree (acctdata, map (addDataToAccounts l) (atsubs acct)) + where + aname = atacct acct + atxns = accountTransactionsNoSubs l aname + abal = accountBalance l aname + acctdata = (aname, atxns, abal) + +-- an AccountData tree adds some other things we want to cache for +-- convenience, like the account's balance and transactions. +type AccountData = (AccountName,[EntryTransaction],Amount) +type AccountDataTree = Tree AccountData +adtdata = fst . unTree +adtsubs = snd . unTree +nullad = Tree (("", [], 0), []) +adname (a,_,_) = a +adtxns (_,ts,_) = ts +adamt (_,_,amt) = amt + +-- a (2 txns) +-- b (boring acct - 0 txns, exactly 1 sub) +-- c (5 txns) +-- d +-- to: +-- a (2 txns) +-- b:c (5 txns) +-- d + +-- elideAccount adt = adt + +-- elideAccount :: Tree AccountData -> Tree AccountData +-- elideAccount adt = adt + + +-- a +-- b +-- c +-- d +-- to: +-- $7 a +-- $5 b +-- $5 c +-- $0 d +showAccountWithBalances :: Ledger -> (Tree AccountData) -> String +showAccountWithBalances l adt = (showAccountsWithBalance l) (adtsubs adt) + +showAccountsWithBalance :: Ledger -> [Tree AccountData] -> String +showAccountsWithBalance l adts = + concatMap showAccountDataBranch adts + where + showAccountDataBranch :: Tree AccountData -> String + showAccountDataBranch adt = + case boring of + True -> + False -> topacct ++ "\n" ++ subs + where + topacct = (showAmount abal) ++ " " ++ (indentAccountName aname) + showAmount amt = printf "%11s" (show amt) + aname = adname $ adtdata adt + atxns = adtxns $ adtdata adt + abal = adamt $ adtdata adt + subs = (showAccountsWithBalance l) $ adtsubs adt + boring = (length atxns == 0) && ((length subs) == 1) + + --- ["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') -- ledger @@ -223,12 +337,6 @@ instance Show Ledger where p = show $ length $ periodic_entries l e = show $ length $ entries l -ledgerAccountsUsed :: Ledger -> [Account] -ledgerAccountsUsed l = accountsFromTransactions $ entryTransactionsFrom $ entries l - -ledgerAccountTree :: Ledger -> [Account] -ledgerAccountTree = sort . expandAccounts . ledgerAccountsUsed - ledgerTransactions :: Ledger -> [EntryTransaction] ledgerTransactions l = entryTransactionsFrom $ entries l @@ -241,3 +349,28 @@ ledgerTransactionsMatching (acctregexps,descregexps) l = (concat [filter (matchTransactionAccount r) ts | r <- acctregexps]) (concat [filter (matchTransactionDescription r) ts | r <- descregexps]) where ts = ledgerTransactions l + +ledgerAccountNamesUsed :: Ledger -> [AccountName] +ledgerAccountNamesUsed l = accountNamesFromTransactions $ entryTransactionsFrom $ entries l + +ledgerAccountNames :: Ledger -> [AccountName] +ledgerAccountNames = sort . expandAccountNames . ledgerAccountNamesUsed + +ledgerTopAccountNames :: Ledger -> [AccountName] +ledgerTopAccountNames l = filter (notElem ':') (ledgerAccountNames l) + +ledgerAccountNamesMatching :: [String] -> Ledger -> [AccountName] +ledgerAccountNamesMatching [] l = ledgerAccountNamesMatching [".*"] l +ledgerAccountNamesMatching acctregexps l = + concat [filter (matchAccountName r) accountNames | r <- acctregexps] + where accountNames = ledgerTopAccountNames l + +ledgerAccounts :: Ledger -> Tree AccountName +ledgerAccounts l = accountFrom $ ledgerAccountNames l + +ledgerAccountsData :: Ledger -> Tree AccountData +ledgerAccountsData l = addDataToAccounts l (ledgerAccounts l) + +showLedgerAccountsWithBalances :: Ledger -> String +showLedgerAccountsWithBalances l = + showAccountWithBalances l (ledgerAccountsData l) diff --git a/Options.hs b/Options.hs index 9ef8bed70..6269f26a7 100644 --- a/Options.hs +++ b/Options.hs @@ -8,12 +8,14 @@ import System.Environment (getEnv) import Utils -data Flag = File String | Version deriving Show +data Flag = Version | File String | ShowSubs + deriving (Show,Eq) 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 ['v'] ["version"] (NoArg Version) "show version number" + , Option ['f'] ["file"] (OptArg inp "FILE") "ledger file, or - to read stdin" + , Option ['s'] ["subtotal"] (NoArg ShowSubs) "balance: show sub-accounts; other: show subtotals" ] inp :: Maybe String -> Flag diff --git a/TODO b/TODO index df089bd7c..f82ebadf3 100644 --- a/TODO +++ b/TODO @@ -1,13 +1,18 @@ -features +basic features balance - show top-level acct balances - show all account balances + show balances with new tree structures + elide empty accounts print entry -j and -J graph data output - svn-style elision !include read timelog files + +make it fast + profile + +more features + svn-style elision -p period expressions -d display expressions read gnucash files @@ -18,7 +23,7 @@ new features smart data entry tests - better use of quickcheck + better use of quickcheck/smallcheck ledger compatibility tests docs diff --git a/Tests.hs b/Tests.hs index 091139bed..81a80ae88 100644 --- a/Tests.hs +++ b/Tests.hs @@ -11,6 +11,7 @@ import Test.HUnit import Options import Models +import Account import Parse -- sample data @@ -203,8 +204,8 @@ 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 + , t "test_expandAccountNames" test_expandAccountNames + , t "test_ledgerAccountNames" test_ledgerAccountNames ] tests2 = Test.HUnit.test @@ -224,15 +225,15 @@ test_autofillEntry = (Amount "$" (-47.18)) (tamount $ last $ etransactions $ autofillEntry entry1) -test_expandAccounts = +test_expandAccountNames = assertEqual' ["assets","assets:cash","assets:checking","expenses","expenses:vacation"] - (expandAccounts ["assets:cash","assets:checking","expenses:vacation"]) + (expandAccountNames ["assets:cash","assets:checking","expenses:vacation"]) -test_accountTree = +test_ledgerAccountNames = assertEqual' ["assets","assets:cash","assets:checking","equity","equity:opening balances","expenses","expenses:vacation"] - (ledgerAccountTree ledger7) + (ledgerAccountNames ledger7) -- quickcheck properties @@ -241,7 +242,7 @@ props = parse' ledgertransaction transaction1_str `parseEquals` (Transaction "expenses:food:dining" (Amount "$" 10)) , - ledgerAccountTree ledger7 == + ledgerAccountNames ledger7 == ["assets","assets:cash","assets:checking","equity","equity:opening balances","expenses","expenses:vacation"] , ledgerPatternArgs [] == ([],[]) diff --git a/hledger.hs b/hledger.hs index c50b23703..288b8bda2 100644 --- a/hledger.hs +++ b/hledger.hs @@ -14,6 +14,7 @@ import Text.ParserCombinators.Parsec (parseFromFile, ParseError) import Options import Models +import Account import Parse import Tests @@ -21,11 +22,11 @@ main :: IO () main = do (opts, args) <- (getArgs >>= getOptions) if args == [] - then register [] + then register [] [] else let (command, args') = (head args, tail args) in - if "reg" `isPrefixOf` command then (register args') - else if "bal" `isPrefixOf` command then balance args' + if "reg" `isPrefixOf` command then (register opts args') + else if "bal" `isPrefixOf` command then balance opts args' else if "test" `isPrefixOf` command then test else error "could not recognise your command" @@ -35,19 +36,17 @@ test :: IO () test = do 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 - getLedgerFilePath >>= parseLedgerFile >>= doWithParsed (printRegister args) +register :: [Flag] -> [String] -> IO () +register opts args = do + getLedgerFilePath >>= parseLedgerFile >>= doWithParsed (printRegister opts args) -balance :: [String] -> IO () -balance args = - return () +balance :: [Flag] -> [String] -> IO () +balance opts args = do + getLedgerFilePath >>= parseLedgerFile >>= doWithParsed (printBalance opts args) -- utils @@ -55,13 +54,23 @@ balance args = -- getLedgerFilePath >>= parseLedgerFile >>= doWithParsed doWithParsed :: (a -> IO ()) -> (Either ParseError a) -> IO () -doWithParsed a p = +doWithParsed a p = do case p of Left e -> parseError e Right v -> a v -printRegister :: [String] -> Ledger -> IO () -printRegister args ledger = - putStr $ showTransactionsWithBalances - (ledgerTransactionsMatching (acctpats,descpats) ledger) - 0 - where (acctpats,descpats) = ledgerPatternArgs args +printRegister :: [Flag] -> [String] -> Ledger -> IO () +printRegister opts args ledger = do + putStr $ showTransactionsWithBalances + (ledgerTransactionsMatching (acctpats,descpats) ledger) + 0 + where (acctpats,descpats) = ledgerPatternArgs args + +printBalance :: [Flag] -> [String] -> Ledger -> IO () +printBalance opts args ledger = do + putStr $ showLedgerAccountsWithBalances ledger + where + (acctpats,_) = ledgerPatternArgs args + showsubs = (ShowSubs `elem` opts) + accounts = case showsubs of + True -> expandAccountNamesMostly ledger (ledgerTopAccountNames ledger) + False -> [(a,indentAccountName a) | a <- ledgerAccountNamesMatching acctpats ledger]