balance report, refactoring .. not finished but feeling paranoid about systems today\!
This commit is contained in:
Simon Michael
parent
c45ad065d8
commit
7b32caa0aa
102
Account.hs
Normal file
102
Account.hs
Normal file
@ -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)
|
||||
|
||||
|
||||
169
Models.hs
169
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)
|
||||
|
||||
@ -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
|
||||
|
||||
15
TODO
15
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
|
||||
|
||||
15
Tests.hs
15
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 [] == ([],[])
|
||||
|
||||
45
hledger.hs
45
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]
|
||||
|
||||
Loading…
Reference in New Issue
Block a user