diff --git a/Account.hs b/Account.hs index 8cf0175f2..7d58fe33d 100644 --- a/Account.hs +++ b/Account.hs @@ -1,17 +1,11 @@ module Account where - -import Debug.Trace -import Text.Printf -import Text.Regex -import Data.List - import Utils +import BasicTypes -- 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. +-- the chart of accounts, which should be a simple hierarchy. type AccountName = String accountNameComponents :: AccountName -> [String] @@ -53,50 +47,43 @@ matchAccountName s a = 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) +-- We could almost get by with just the above, but we need smarter +-- structures to eg display the account tree with boring accounts elided. +-- first, here is a tree of AccountNames; Account and Account tree are +-- defined later. + +antacctname = fst . node +antsubs = snd . node + +accountNameTreeFrom_props = + [ + accountNameTreeFrom ["a"] == Tree ("top", [Tree ("a",[])]), + accountNameTreeFrom ["a","b"] == Tree ("top", [Tree ("a", []), Tree ("b", [])]), + accountNameTreeFrom ["a","a:b"] == Tree ("top", [Tree ("a", [Tree ("a:b", [])])]), + accountNameTreeFrom ["a:b"] == Tree ("top", [Tree ("a", [Tree ("a:b", [])])]) + ] +accountNameTreeFrom :: [AccountName] -> Tree AccountName +accountNameTreeFrom accts = + Tree ("top", accountsFrom (topAccountNames accts)) + where + accountsFrom :: [AccountName] -> [Tree AccountName] + accountsFrom [] = [] + accountsFrom as = [Tree (a, accountsFrom $ subs a) | a <- as] + subs = (subAccountNamesFrom accts) + +showAccountNameTree :: Tree AccountName -> String +showAccountNameTree at = showAccountNameTrees $ antsubs at + +showAccountNameTrees :: [Tree AccountName] -> String +showAccountNameTrees ats = + concatMap showAccountNameBranch ats + where + showAccountNameBranch at = topacct ++ "\n" ++ subs + where + topacct = indentAccountName $ antacctname at + subs = showAccountNameTrees $ antsubs at + diff --git a/BasicTypes.hs b/BasicTypes.hs index fecc11123..36154426e 100644 --- a/BasicTypes.hs +++ b/BasicTypes.hs @@ -1,12 +1,6 @@ module BasicTypes where - -import Debug.Trace -import Text.Printf -import Text.Regex -import Data.List - import Utils @@ -42,3 +36,8 @@ amountRoundedOrZero (Amount cur qty) = "-0.00" -> "0" otherwise -> cur ++ rounded +-- generic tree. each node is a tuple of the node type and a +-- list of subtrees +newtype Tree a = Tree { node :: (a, [Tree a]) } deriving (Show,Eq) +branches = snd . node + diff --git a/Entry.hs b/Entry.hs index 15561cb27..34474f47e 100644 --- a/Entry.hs +++ b/Entry.hs @@ -1,12 +1,6 @@ module Entry where - -import Debug.Trace -import Text.Printf -import Text.Regex -import Data.List - import Utils import BasicTypes import Transaction diff --git a/EntryTransaction.hs b/EntryTransaction.hs index cfbdf76a2..3f90b4c40 100644 --- a/EntryTransaction.hs +++ b/EntryTransaction.hs @@ -1,15 +1,8 @@ module EntryTransaction where - -import Debug.Trace -import Text.Printf -import Text.Regex -import Data.List - import Utils import BasicTypes -import Account import Entry import Transaction @@ -40,9 +33,6 @@ sumEntryTransactions :: [EntryTransaction] -> Amount sumEntryTransactions ets = sumTransactions $ map transaction ets -accountNamesFromTransactions :: [EntryTransaction] -> [AccountName] -accountNamesFromTransactions ts = nub $ map account ts - matchTransactionAccount :: String -> EntryTransaction -> Bool matchTransactionAccount s t = case matchRegex (mkRegex s) (account t) of diff --git a/Ledger.hs b/Ledger.hs index 640eb4a79..f6ab053fe 100644 --- a/Ledger.hs +++ b/Ledger.hs @@ -1,13 +1,8 @@ module Ledger where - -import Debug.Trace -import Text.Printf -import Text.Regex -import Data.List - import Utils import Account +import BasicTypes import Entry import EntryTransaction @@ -37,6 +32,9 @@ ledgerTransactionsMatching (acctregexps,descregexps) l = (concat [filter (matchTransactionDescription r) ts | r <- descregexps]) where ts = ledgerTransactions l +accountNamesFromTransactions :: [EntryTransaction] -> [AccountName] +accountNamesFromTransactions ts = nub $ map account ts + ledgerAccountNamesUsed :: Ledger -> [AccountName] ledgerAccountNamesUsed l = accountNamesFromTransactions $ entryTransactionsFrom $ entries l @@ -52,18 +50,8 @@ ledgerAccountNamesMatching acctregexps l = concat [filter (matchAccountName r) accountNames | r <- acctregexps] where accountNames = ledgerTopAccountNames l -ledgerAccounts :: Ledger -> Tree AccountName -ledgerAccounts l = accountFrom $ ledgerAccountNames l +ledgerAccountNameTree :: Ledger -> Tree AccountName +ledgerAccountNameTree l = accountNameTreeFrom $ ledgerAccountNames l -showLedgerAccounts :: Ledger -> [String] -> Int -> String -showLedgerAccounts l acctpats depth = - showAccountsWithBalances l accounts depth - where - accounts = ledgerAccountsMatching l acctpats -showAccountsWithBalances :: Ledger -> [Account] -> Int -> String -showAccountsWithBalances l accts depth = - "" -ledgerAccountsMatching :: Ledger -> [String] -> [Account] -ledgerAccountsMatching l acctpats = [] diff --git a/Models.hs b/Models.hs index 4e703f872..db0c64c03 100644 --- a/Models.hs +++ b/Models.hs @@ -9,12 +9,6 @@ module Models ( module BasicTypes, ) where - -import Debug.Trace -import Text.Printf -import Text.Regex -import Data.List - import Utils import BasicTypes import Account @@ -24,9 +18,30 @@ import EntryTransaction import Ledger --- any top-level stuff that mixed up the other types +-- top-level stuff that mixes types +-- an Account caches an account's name, balance and transactions for convenience +type Account = (AccountName,[EntryTransaction],Amount) +aname (a,_,_) = a +atxns (_,ts,_) = ts +abal (_,_,b) = b + +mkAccount :: Ledger -> AccountName -> Account +mkAccount l a = (a, accountNameTransactionsNoSubs l a, accountNameBalance l a) + +accountNameBalance :: Ledger -> AccountName -> Amount +accountNameBalance l a = sumEntryTransactions (accountNameTransactions l a) + +accountNameTransactions :: Ledger -> AccountName -> [EntryTransaction] +accountNameTransactions l a = ledgerTransactionsMatching (["^" ++ a ++ "(:.+)?$"], []) l + +accountNameBalanceNoSubs :: Ledger -> AccountName -> Amount +accountNameBalanceNoSubs l a = sumEntryTransactions (accountNameTransactionsNoSubs l a) + +accountNameTransactionsNoSubs :: Ledger -> AccountName -> [EntryTransaction] +accountNameTransactionsNoSubs l a = ledgerTransactionsMatching (["^" ++ a ++ "$"], []) l + -- showAccountNamesWithBalances :: [(AccountName,String)] -> Ledger -> String -- showAccountNamesWithBalances as l = -- unlines $ map (showAccountNameAndBalance l) as @@ -35,40 +50,42 @@ import Ledger -- 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 +-- a tree of Accounts -accountBalanceNoSubs :: Ledger -> AccountName -> Amount -accountBalanceNoSubs l a = - sumEntryTransactions (accountTransactionsNoSubs l a) +atacct = fst . node -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)) +addDataToAccountNameTree :: Ledger -> Tree AccountName -> Tree Account +addDataToAccountNameTree l ant = + Tree (mkAccount l aname, map (addDataToAccountNameTree l) (antsubs ant)) where - acctdata = (aname, atxns, abal) - aname = atacct acct - atxns = accountTransactionsNoSubs l aname - abal = accountBalance l aname + aname = antacctname ant --- 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 +showAccountTreeWithBalances :: Ledger -> Int -> Tree Account -> String +showAccountTreeWithBalances l depth at = (showAccountTreesWithBalances l depth) (branches at) +showAccountTreesWithBalances :: Ledger -> Int -> [Tree Account] -> String +showAccountTreesWithBalances _ 0 _ = "" +showAccountTreesWithBalances l depth ats = + concatMap showAccountBranch ats + where + showAccountBranch :: Tree Account -> String + showAccountBranch at = + topacct ++ "\n" ++ subaccts +-- case boring of +-- True -> +-- False -> + where + topacct = (showAmount bal) ++ " " ++ (indentAccountName name) + showAmount amt = printf "%20s" (show amt) + name = aname $ atacct at + txns = atxns $ atacct at + bal = abal $ atacct at + subaccts = (showAccountTreesWithBalances l (depth - 1)) $ branches at + boring = (length txns == 0) && ((length subaccts) == 1) + +-- we want to elide boring accounts in the account tree +-- -- a (2 txns) -- b (boring acct - 0 txns, exactly 1 sub) -- c (5 txns) @@ -78,46 +95,18 @@ adamt (_,_,amt) = amt -- b:c (5 txns) -- d --- elideAccount adt = adt +-- elideAccountTree at = at --- elideAccount :: Tree AccountData -> Tree AccountData --- elideAccount adt = adt - +elideAccountTree :: Tree Account -> Tree Account +elideAccountTree = id --- 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) +ledgerAccountTree :: Ledger -> Tree Account +ledgerAccountTree l = elideAccountTree $ addDataToAccountNameTree l (ledgerAccountNameTree l) -showAccountsWithBalance :: Ledger -> [Tree AccountData] -> String -showAccountsWithBalance l adts = - concatMap showAccountDataBranch adts - where - showAccountDataBranch :: Tree AccountData -> String - showAccountDataBranch adt = - topacct ++ "\n" ++ subs --- case boring of --- True -> --- False -> - 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) +ledgerAccountsMatching :: Ledger -> [String] -> [Account] +ledgerAccountsMatching l acctpats = undefined -ledgerAccountsData :: Ledger -> Tree AccountData -ledgerAccountsData l = addDataToAccounts l (ledgerAccounts l) +showLedgerAccounts :: Ledger -> Int -> String +showLedgerAccounts l depth = + showAccountTreeWithBalances l depth (ledgerAccountTree l) -showLedgerAccountsWithBalances :: Ledger -> Tree AccountData -> String -showLedgerAccountsWithBalances l adt = - showAccountWithBalances l adt diff --git a/Options.hs b/Options.hs index 17f77534b..3f6b58082 100644 --- a/Options.hs +++ b/Options.hs @@ -1,21 +1,21 @@ module Options (module Options, usageInfo) where - import System.Console.GetOpt -import Data.Maybe ( fromMaybe ) import System.Environment (getEnv) +import Data.Maybe (fromMaybe) import Utils -data Flag = Version | File String | ShowSubs + +data Flag = Version | File String | ShowSubs deriving (Show,Eq) options :: [OptDescr Flag] options = [ 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; register: show subtotals" + , Option ['s'] ["subtotal"] (NoArg ShowSubs) "balance: show sub-accounts" --; register: show subtotals" ] inp :: Maybe String -> Flag @@ -47,5 +47,8 @@ ledgerPatternArgs args = True -> ((takeWhile (/= "--") args), tail $ (dropWhile (/= "--") args)) False -> (args,[]) -depthOption :: [Flag] -> Int -depthOption opts = 1 +getDepth :: [Flag] -> Int +getDepth opts = + maximum $ [1] ++ map depthval opts where + depthval (ShowSubs) = 9999 + depthval _ = 1 diff --git a/Parse.hs b/Parse.hs index e4a59d1e6..d2a9da9d4 100644 --- a/Parse.hs +++ b/Parse.hs @@ -1,12 +1,11 @@ module Parse where - import Text.ParserCombinators.Parsec import Text.ParserCombinators.Parsec.Language import qualified Text.ParserCombinators.Parsec.Token as P -import Text.Printf +import Utils import Models {- diff --git a/TODO b/TODO index cdb09ea69..0c7b061ef 100644 --- a/TODO +++ b/TODO @@ -1,4 +1,6 @@ cleanup/reorganize + Entry/Transaction/EntryTransaction + hledger Options Tests @@ -14,8 +16,8 @@ hledger basic features balance - show balances with new tree structures - elide empty accounts + elide boring accounts + handle mixed amounts and currencies print entry -j and -J graph data output @@ -26,7 +28,7 @@ make it fast profile more features - svn-style elision + 3.0-style elision -p period expressions -d display expressions read gnucash files @@ -37,6 +39,7 @@ new features smart data entry incorporate timeclock features timelog simple amount entries + better layout tests better use of quickcheck/smallcheck diff --git a/Tests.hs b/Tests.hs index e2dc1dd2d..2f9533ad7 100644 --- a/Tests.hs +++ b/Tests.hs @@ -1,7 +1,6 @@ module Tests where - import Text.ParserCombinators.Parsec import Test.QuickCheck import Test.HUnit @@ -273,7 +272,9 @@ test_expandAccountNames = test_ledgerAccountNames = assertEqual' - ["assets","assets:cash","assets:checking","equity","equity:opening balances","expenses","expenses:vacation"] + ["assets","assets:cash","assets:checking","assets:saving","equity","equity:opening balances", + "expenses","expenses:food","expenses:food:dining","expenses:phone","expenses:vacation", + "liabilities","liabilities:credit cards","liabilities:credit cards:discover"] (ledgerAccountNames ledger7) -- quickcheck properties @@ -284,7 +285,10 @@ props = (Transaction "expenses:food:dining" (Amount "$" 10)) , ledgerAccountNames ledger7 == - ["assets","assets:cash","assets:checking","equity","equity:opening balances","expenses","expenses:vacation"] + ["assets","assets:cash","assets:checking","assets:saving","equity", + "equity:opening balances","expenses","expenses:food","expenses:food:dining", + "expenses:phone","expenses:vacation","liabilities","liabilities:credit cards", + "liabilities:credit cards:discover"] , ledgerPatternArgs [] == ([],[]) ,ledgerPatternArgs ["a"] == (["a"],[]) diff --git a/Transaction.hs b/Transaction.hs index 7e7558c64..bf0148718 100644 --- a/Transaction.hs +++ b/Transaction.hs @@ -1,12 +1,6 @@ module Transaction where - -import Debug.Trace -import Text.Printf -import Text.Regex -import Data.List - import Utils import BasicTypes import Account diff --git a/Utils.hs b/Utils.hs index f4705957d..50405c018 100644 --- a/Utils.hs +++ b/Utils.hs @@ -1,9 +1,19 @@ - -module Utils +module Utils ( + module Utils, + module Data.List, + module Debug.Trace, + module Text.Printf, + module Text.Regex, + quickCheck, + ) where - -import Data.List import System.Directory +import Data.List +import Debug.Trace +import Test.QuickCheck (quickCheck) +import Text.Printf +import Text.Regex + rhead = head . reverse rtail = reverse . tail . reverse diff --git a/hledger.hs b/hledger.hs index eb36d537d..18431fcee 100644 --- a/hledger.hs +++ b/hledger.hs @@ -1,22 +1,22 @@ #!/usr/bin/env runhaskell -- hledger - ledger-compatible money management utilities (& haskell study) -- GPLv3, (c) Simon Michael & contributors, --- John Wiegley's ledger is at http://newartisans.com/ledger.html . +-- John Wiegley's ledger is at http://newartisans.com/ledger.html -module Main -- application logic & most IO +-- application logic & most IO +module Main where - -import System.Environment (withArgs) -- for testing in old hugs import System -import Data.List +import System.Environment (withArgs) -- for testing in old hugs import Test.HUnit (runTestTT) import Test.QuickCheck (quickCheck) -import Text.ParserCombinators.Parsec (parseFromFile, ParseError) +import Text.ParserCombinators.Parsec (ParseError) import Options import Models import Parse import Tests +import Utils main :: IO () main = do @@ -67,13 +67,16 @@ printRegister opts args ledger = do printBalance :: [Flag] -> [String] -> Ledger -> IO () printBalance opts args ledger = do --- putStr $ showAccountWithBalances ledger (ledgerAccountsData l) - putStr $ showLedgerAccounts ledger acctpats depth - where - (acctpats,_) = ledgerPatternArgs args - depth = depthOption opts - +-- putStr $ showLedgerAccounts ledger acctpats depth +-- 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] +-- depth = case showsubs of +-- True -> 999 +-- False -> depthOption opts + putStr $ case showsubs of + True -> showLedgerAccounts ledger 999 + False -> showLedgerAccounts ledger (getDepth opts) + where + showsubs = (ShowSubs `elem` opts) + (acctpats,_) = ledgerPatternArgs args