mirror of
https://github.com/simonmichael/hledger.git
synced 2024-11-08 07:09:28 +03:00
237 lines
7.8 KiB
Haskell
237 lines
7.8 KiB
Haskell
module Ledger
|
|
where
|
|
import qualified Data.Map as Map
|
|
import Data.Map ((!))
|
|
import Utils
|
|
import Types
|
|
import Amount
|
|
import Account
|
|
import AccountName
|
|
import Transaction
|
|
import LedgerFile
|
|
|
|
|
|
rawLedgerTransactions :: LedgerFile -> [Transaction]
|
|
rawLedgerTransactions = txns . entries
|
|
where
|
|
txns :: [LedgerEntry] -> [Transaction]
|
|
txns es = concat $ map flattenEntry $ zip es (iterate (+1) 1)
|
|
|
|
rawLedgerAccountNamesUsed :: LedgerFile -> [AccountName]
|
|
rawLedgerAccountNamesUsed = accountNamesFromTransactions . rawLedgerTransactions
|
|
|
|
rawLedgerAccountNames :: LedgerFile -> [AccountName]
|
|
rawLedgerAccountNames = sort . expandAccountNames . rawLedgerAccountNamesUsed
|
|
|
|
rawLedgerAccountNameTree :: LedgerFile -> Tree AccountName
|
|
rawLedgerAccountNameTree l = accountNameTreeFrom $ rawLedgerAccountNames l
|
|
|
|
|
|
instance Show Ledger where
|
|
show l = printf "Ledger with %d entries, %d accounts"
|
|
((length $ entries $ rawledger l) +
|
|
(length $ modifier_entries $ rawledger l) +
|
|
(length $ periodic_entries $ rawledger l))
|
|
(length $ accountnames l)
|
|
|
|
-- at startup, to improve performance, we refine the parsed ledger entries:
|
|
-- 1. filter based on account/description patterns, if any
|
|
-- 2. cache per-account info
|
|
-- also, figure out the precision(s) to use
|
|
cacheLedger :: ([Regex],[Regex]) -> LedgerFile -> Ledger
|
|
cacheLedger pats l =
|
|
let
|
|
lprecision = maximum $ map (precision . amount) $ rawLedgerTransactions l
|
|
l' = filterLedgerEntries pats l
|
|
ant = rawLedgerAccountNameTree l'
|
|
ans = flatten ant
|
|
ts = rawLedgerTransactions l'
|
|
sortedts = sortBy (comparing account) ts
|
|
groupedts = groupBy (\t1 t2 -> account t1 == account t2) sortedts
|
|
tmap = Map.union
|
|
(Map.fromList [(account $ head g, g) | g <- groupedts])
|
|
(Map.fromList [(a,[]) | a <- ans])
|
|
txns = (tmap !)
|
|
subaccts a = filter (isAccountNamePrefixOf a) ans
|
|
subtxns a = concat [txns a | a <- [a] ++ subaccts a]
|
|
bmap = Map.union
|
|
(Map.fromList [(a, (sumTransactions $ subtxns a){precision=lprecision}) | a <- ans])
|
|
(Map.fromList [(a,nullamt) | a <- ans])
|
|
amap = Map.fromList [(a, Account a (tmap ! a) (bmap ! a)) | a <- ans]
|
|
in
|
|
Ledger l' ant amap lprecision
|
|
|
|
-- filter entries by descpats and by whether any transactions contain any acctpats
|
|
filterLedgerEntries1 :: ([Regex],[Regex]) -> LedgerFile -> LedgerFile
|
|
filterLedgerEntries1 (acctpats,descpats) (LedgerFile ms ps es) =
|
|
LedgerFile ms ps es'
|
|
where
|
|
es' = intersect
|
|
(concat [filter (matchacct r) es | r <- acctpats])
|
|
(concat [filter (matchdesc r) es | r <- descpats])
|
|
matchacct :: Regex -> LedgerEntry -> Bool
|
|
matchacct r e = any (matchtxn r) (etransactions e)
|
|
matchtxn :: Regex -> LedgerTransaction -> Bool
|
|
matchtxn r t = case matchRegex r (taccount t) of
|
|
Nothing -> False
|
|
otherwise -> True
|
|
matchdesc :: Regex -> LedgerEntry -> Bool
|
|
matchdesc r e = case matchRegex r (edescription e) of
|
|
Nothing -> False
|
|
otherwise -> True
|
|
|
|
-- filter txns in each entry by acctpats, then filter the modified entries by descpats
|
|
-- this seems aggressive, unbalancing entries, but so far so goo-
|
|
filterLedgerEntries :: ([Regex],[Regex]) -> LedgerFile -> LedgerFile
|
|
filterLedgerEntries (acctpats,descpats) (LedgerFile ms ps es) =
|
|
LedgerFile ms ps es'
|
|
where
|
|
es' = filter matchanydesc $ map filtertxns es
|
|
filtertxns :: LedgerEntry -> LedgerEntry
|
|
filtertxns (LedgerEntry d s cod desc com ts) = LedgerEntry d s cod desc com $ filter matchanyacct ts
|
|
matchanyacct :: LedgerTransaction -> Bool
|
|
matchanyacct t = any (matchtxn t) acctpats
|
|
matchtxn :: LedgerTransaction -> Regex -> Bool
|
|
matchtxn t r = case matchRegex r (taccount t) of
|
|
Nothing -> False
|
|
otherwise -> True
|
|
matchanydesc :: LedgerEntry -> Bool
|
|
matchanydesc e = any (matchdesc e) descpats
|
|
matchdesc :: LedgerEntry -> Regex -> Bool
|
|
matchdesc e r = case matchRegex r (edescription e) of
|
|
Nothing -> False
|
|
otherwise -> True
|
|
|
|
accountnames :: Ledger -> [AccountName]
|
|
accountnames l = flatten $ accountnametree l
|
|
|
|
ledgerAccount :: Ledger -> AccountName -> Account
|
|
ledgerAccount l a = (accounts l) ! a
|
|
|
|
-- This sets all amount precisions to that of the highest-precision
|
|
-- amount, to help with report output. It should perhaps be done in the
|
|
-- display functions, but those are far removed from the ledger. Keep in
|
|
-- mind if doing more arithmetic with these.
|
|
ledgerTransactions :: Ledger -> [Transaction]
|
|
ledgerTransactions l =
|
|
setprecisions $ rawLedgerTransactions $ rawledger l
|
|
where
|
|
setprecisions = map (transactionSetPrecision (lprecision l))
|
|
|
|
ledgerAccountTree :: Ledger -> Int -> Tree Account
|
|
ledgerAccountTree l depth =
|
|
addDataToAccountNameTree l $ treeprune depth $ accountnametree l
|
|
|
|
addDataToAccountNameTree :: Ledger -> Tree AccountName -> Tree Account
|
|
addDataToAccountNameTree = treemap . ledgerAccount
|
|
|
|
-- balance report support
|
|
--
|
|
-- examples: here is a sample account tree:
|
|
--
|
|
-- assets
|
|
-- cash
|
|
-- checking
|
|
-- saving
|
|
-- equity
|
|
-- expenses
|
|
-- food
|
|
-- shelter
|
|
-- income
|
|
-- salary
|
|
-- liabilities
|
|
-- debts
|
|
--
|
|
-- standard balance command shows all top-level accounts:
|
|
--
|
|
-- > ledger bal
|
|
-- $ assets
|
|
-- $ equity
|
|
-- $ expenses
|
|
-- $ income
|
|
-- $ liabilities
|
|
--
|
|
-- with an account pattern, show only the ones with matching names:
|
|
--
|
|
-- > ledger bal asset
|
|
-- $ assets
|
|
--
|
|
-- with -s, show all subaccounts of matched accounts:
|
|
--
|
|
-- > ledger -s bal asset
|
|
-- $ assets
|
|
-- $ cash
|
|
-- $ checking
|
|
-- $ saving
|
|
--
|
|
-- we elide boring accounts in two ways:
|
|
-- - leaf accounts and branches with 0 balance or 0 transactions are omitted
|
|
-- - inner accounts with 0 transactions and 1 subaccount are displayed inline
|
|
-- so this:
|
|
--
|
|
-- a (0 txns)
|
|
-- b (0 txns)
|
|
-- c
|
|
-- d
|
|
-- e (0 txns)
|
|
-- f
|
|
-- g
|
|
-- h (0 txns)
|
|
-- i (0 balance)
|
|
--
|
|
-- is displayed like:
|
|
--
|
|
-- a:b:c
|
|
-- d
|
|
-- e
|
|
-- f
|
|
-- g
|
|
|
|
showLedgerAccounts :: Ledger -> Int -> String
|
|
showLedgerAccounts l maxdepth =
|
|
concatMap
|
|
(showAccountTree l)
|
|
(branches $ ledgerAccountTree l maxdepth)
|
|
|
|
showAccountTree :: Ledger -> Tree Account -> String
|
|
showAccountTree l = showAccountTree' l 0 . pruneBoringBranches
|
|
|
|
showAccountTree' :: Ledger -> Int -> Tree Account -> String
|
|
showAccountTree' l indentlevel t
|
|
-- skip a boring inner account
|
|
| length subs > 0 && isBoringAccount l acct = subsindented 0
|
|
-- otherwise show normal indented account name with balance,
|
|
-- prefixing the names of any boring parents
|
|
| otherwise =
|
|
bal ++ " " ++ indent ++ prefix ++ leafname ++ "\n" ++ (subsindented 1)
|
|
where
|
|
acct = root t
|
|
subs = branches t
|
|
subsindented i = concatMap (showAccountTree' l (indentlevel+i)) subs
|
|
bal = printf "%20s" $ show $ abalance $ acct
|
|
indent = replicate (indentlevel * 2) ' '
|
|
prefix = concatMap (++ ":") $ map accountLeafName $ reverse boringparents
|
|
boringparents = takeWhile (isBoringAccountName l) $ parentAccountNames $ aname acct
|
|
leafname = accountLeafName $ aname acct
|
|
|
|
isBoringAccount :: Ledger -> Account -> Bool
|
|
isBoringAccount l a
|
|
| name == "top" = False
|
|
| (length txns == 0) && ((length subs) == 1) = True
|
|
| otherwise = False
|
|
where
|
|
name = aname a
|
|
txns = atransactions a
|
|
subs = subAccountNamesFrom (accountnames l) name
|
|
|
|
isBoringAccountName :: Ledger -> AccountName -> Bool
|
|
isBoringAccountName l = isBoringAccount l . ledgerAccount l
|
|
|
|
pruneBoringBranches :: Tree Account -> Tree Account
|
|
pruneBoringBranches =
|
|
treefilter hastxns . treefilter hasbalance
|
|
where
|
|
hasbalance = (/= 0) . abalance
|
|
hastxns = (> 0) . length . atransactions
|
|
|