slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

refactor, fix balance report

Browse Source
This commit is contained in:
Simon Michael 2007-02-16 11:51:30 +00:00
parent ba40fbf733
commit 1322bcb4a0
13 changed files with 166 additions and 203 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

89
Account.hs
View File

@ -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

11
BasicTypes.hs
View File

@ -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

6
Entry.hs
View File

@ -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

10
EntryTransaction.hs
View File

@ -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

24
Ledger.hs
View File

@ -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 = []

135
Models.hs
View File

@ -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
ledgerAccountTree :: Ledger -> Tree Account
ledgerAccountTree l = elideAccountTree $ addDataToAccountNameTree l (ledgerAccountNameTree l)
-- 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)
ledgerAccountsMatching :: Ledger -> [String] -> [Account]
ledgerAccountsMatching l acctpats = undefined
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)
showLedgerAccounts :: Ledger -> Int -> String
showLedgerAccounts l depth =
showAccountTreeWithBalances l depth (ledgerAccountTree l)
ledgerAccountsData :: Ledger -> Tree AccountData
ledgerAccountsData l = addDataToAccounts l (ledgerAccounts l)
showLedgerAccountsWithBalances :: Ledger -> Tree AccountData -> String
showLedgerAccountsWithBalances l adt =
showAccountWithBalances l adt

13
Options.hs
View File

@ -1,13 +1,13 @@
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
deriving (Show,Eq)
@ -15,7 +15,7 @@ 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

3
Parse.hs
View File

@ -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
{-

9
TODO
View File

@ -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

10
Tests.hs
View File

@ -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"],[])

6
Transaction.hs
View File

@ -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

18
Utils.hs
View File

@ -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

33
hledger.hs
View File

@ -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