377 lines
13 KiB
Haskell
377 lines
13 KiB
Haskell
|
|
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
|
|
|
|
-- amounts
|
|
-- amount arithmetic currently ignores currency conversion
|
|
|
|
data Amount = Amount {
|
|
currency :: String,
|
|
quantity :: Double
|
|
} deriving (Eq,Ord)
|
|
|
|
instance Num Amount where
|
|
abs (Amount c q) = Amount c (abs q)
|
|
signum (Amount c q) = Amount c (signum q)
|
|
fromInteger i = Amount "$" (fromInteger i)
|
|
(+) = amountAdd
|
|
(-) = amountSub
|
|
(*) = amountMult
|
|
Amount ca qa `amountAdd` Amount cb qb = Amount ca (qa + qb)
|
|
Amount ca qa `amountSub` Amount cb qb = Amount ca (qa - qb)
|
|
Amount ca qa `amountMult` Amount cb qb = Amount ca (qa * qb)
|
|
|
|
instance Show Amount where show = amountRoundedOrZero
|
|
|
|
amountRoundedOrZero :: Amount -> String
|
|
amountRoundedOrZero (Amount cur qty) =
|
|
let rounded = printf "%.2f" qty in
|
|
case rounded of
|
|
"0.00" -> "0"
|
|
"-0.00" -> "0"
|
|
otherwise -> cur ++ rounded
|
|
|
|
-- modifier & periodic entries
|
|
|
|
data ModifierEntry = ModifierEntry { -- aka "automated entry"
|
|
valueexpr :: String,
|
|
m_transactions :: [Transaction]
|
|
} deriving (Eq)
|
|
|
|
instance Show ModifierEntry where
|
|
show e = "= " ++ (valueexpr e) ++ "\n" ++ unlines (map show (m_transactions e))
|
|
|
|
data PeriodicEntry = PeriodicEntry {
|
|
periodexpr :: String,
|
|
p_transactions :: [Transaction]
|
|
} deriving (Eq)
|
|
|
|
instance Show PeriodicEntry where
|
|
show e = "~ " ++ (periodexpr e) ++ "\n" ++ unlines (map show (p_transactions e))
|
|
|
|
-- entries
|
|
-- a register entry is displayed as two or more lines like this:
|
|
-- date description account amount balance
|
|
-- DDDDDDDDDD dddddddddddddddddddd aaaaaaaaaaaaaaaaaaaaaa AAAAAAAAAAA AAAAAAAAAAAA
|
|
-- aaaaaaaaaaaaaaaaaaaaaa AAAAAAAAAAA AAAAAAAAAAAA
|
|
-- ... ... ...
|
|
-- dateWidth = 10
|
|
-- descWidth = 20
|
|
-- acctWidth = 22
|
|
-- amtWidth = 11
|
|
-- balWidth = 12
|
|
|
|
data Entry = Entry {
|
|
edate :: Date,
|
|
estatus :: Status,
|
|
ecode :: String,
|
|
edescription :: String,
|
|
etransactions :: [Transaction]
|
|
} deriving (Eq,Ord)
|
|
|
|
instance Show Entry where show = showEntry
|
|
|
|
showEntry e = (showDate $ edate e) ++ " " ++ (showDescription $ edescription e) ++ " "
|
|
showDate d = printf "%-10s" d
|
|
showDescription s = printf "%-20s" (elideRight 20 s)
|
|
|
|
isEntryBalanced :: Entry -> Bool
|
|
isEntryBalanced e = (sumTransactions . etransactions) e == 0
|
|
|
|
autofillEntry :: Entry -> Entry
|
|
autofillEntry e =
|
|
Entry (edate e) (estatus e) (ecode e) (edescription e)
|
|
(autofillTransactions (etransactions e))
|
|
|
|
-- transactions
|
|
|
|
data Transaction = Transaction {
|
|
taccount :: AccountName,
|
|
tamount :: Amount
|
|
} deriving (Eq,Ord)
|
|
|
|
instance Show Transaction where show = showTransaction
|
|
|
|
showTransaction t = (showAccountName $ taccount t) ++ " " ++ (showAmount $ tamount t)
|
|
showAmount amt = printf "%11s" (show amt)
|
|
showAccountName s = printf "%-22s" (elideRight 22 s)
|
|
|
|
elideRight width s =
|
|
case length s > width of
|
|
True -> take (width - 2) s ++ ".."
|
|
False -> s
|
|
|
|
-- elideAccountRight width abbrevlen a =
|
|
-- case length a > width of
|
|
-- False -> a
|
|
-- True -> abbreviateAccountComponent abbrevlen a
|
|
|
|
-- abbreviateAccountComponent abbrevlen a =
|
|
-- let components = splitAtElement ':' a in
|
|
-- case
|
|
|
|
autofillTransactions :: [Transaction] -> [Transaction]
|
|
autofillTransactions ts =
|
|
let (ns, as) = partition isNormal ts
|
|
where isNormal t = (currency $ tamount t) /= "AUTO" in
|
|
case (length as) of
|
|
0 -> ns
|
|
1 -> ns ++ [balanceTransaction $ head as]
|
|
where balanceTransaction t = t{tamount = -(sumTransactions ns)}
|
|
otherwise -> error "too many blank transactions in this entry"
|
|
|
|
sumTransactions :: [Transaction] -> Amount
|
|
sumTransactions ts = sum [tamount t | t <- ts]
|
|
|
|
-- entrytransactions
|
|
-- We parse Entries containing Transactions and flatten them into
|
|
-- (entry,transaction) pairs (entrytransactions, hereafter referred to as
|
|
-- "transactions") for easier processing. (So far, these types have
|
|
-- morphed through E->T; (T,E); ET; E<->T; (E,T)).
|
|
|
|
type EntryTransaction = (Entry,Transaction)
|
|
|
|
entry (e,t) = e
|
|
transaction (e,t) = t
|
|
date (e,t) = edate e
|
|
status (e,t) = estatus e
|
|
code (e,t) = ecode e
|
|
description (e,t) = edescription e
|
|
account (e,t) = taccount t
|
|
amount (e,t) = tamount t
|
|
|
|
flattenEntry :: Entry -> [EntryTransaction]
|
|
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
|
|
Nothing -> False
|
|
otherwise -> True
|
|
|
|
matchTransactionDescription :: String -> EntryTransaction -> Bool
|
|
matchTransactionDescription s t =
|
|
case matchRegex (mkRegex s) (description t) of
|
|
Nothing -> False
|
|
otherwise -> True
|
|
|
|
showTransactionsWithBalances :: [EntryTransaction] -> Amount -> String
|
|
showTransactionsWithBalances [] _ = []
|
|
showTransactionsWithBalances ts b =
|
|
unlines $ showTransactionsWithBalances' ts dummyt b
|
|
where
|
|
dummyt = (Entry "" False "" "" [], Transaction "" (Amount "" 0))
|
|
showTransactionsWithBalances' [] _ _ = []
|
|
showTransactionsWithBalances' (t:ts) tprev b =
|
|
(if (entry t /= (entry tprev))
|
|
then [showTransactionDescriptionAndBalance t b']
|
|
else [showTransactionAndBalance t b'])
|
|
++ (showTransactionsWithBalances' ts t b')
|
|
where b' = b + (amount t)
|
|
|
|
showTransactionDescriptionAndBalance :: EntryTransaction -> Amount -> String
|
|
showTransactionDescriptionAndBalance t b =
|
|
(showEntry $ entry t) ++ (showTransaction $ transaction t) ++ (showBalance b)
|
|
|
|
showTransactionAndBalance :: EntryTransaction -> Amount -> String
|
|
showTransactionAndBalance t b =
|
|
(replicate 32 ' ') ++ (showTransaction $ transaction t) ++ (showBalance b)
|
|
|
|
showBalance :: Amount -> String
|
|
showBalance b = printf " %12s" (amountRoundedOrZero b)
|
|
|
|
-- more account functions
|
|
|
|
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)
|
|
|
|
|
|
|
|
|
|
-- ledger
|
|
|
|
data Ledger = Ledger {
|
|
modifier_entries :: [ModifierEntry],
|
|
periodic_entries :: [PeriodicEntry],
|
|
entries :: [Entry]
|
|
} deriving (Eq)
|
|
|
|
instance Show Ledger where
|
|
show l = "Ledger with " ++ m ++ " modifier, " ++ p ++ " periodic, " ++ e ++ " normal entries:\n"
|
|
++ (concat $ map show (modifier_entries l))
|
|
++ (concat $ map show (periodic_entries l))
|
|
++ (concat $ map show (entries l))
|
|
where
|
|
m = show $ length $ modifier_entries l
|
|
p = show $ length $ periodic_entries l
|
|
e = show $ length $ entries l
|
|
|
|
ledgerTransactions :: Ledger -> [EntryTransaction]
|
|
ledgerTransactions l = entryTransactionsFrom $ entries l
|
|
|
|
ledgerTransactionsMatching :: ([String],[String]) -> Ledger -> [EntryTransaction]
|
|
ledgerTransactionsMatching ([],[]) l = ledgerTransactionsMatching ([".*"],[".*"]) l
|
|
ledgerTransactionsMatching (rs,[]) l = ledgerTransactionsMatching (rs,[".*"]) l
|
|
ledgerTransactionsMatching ([],rs) l = ledgerTransactionsMatching ([".*"],rs) l
|
|
ledgerTransactionsMatching (acctregexps,descregexps) l =
|
|
intersect
|
|
(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)
|