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

track amount precision, and use the highest precision found for display; parsing fixes

Browse Source
This commit is contained in:
Simon Michael 2007-07-04 01:38:56 +00:00
parent b2b9aba791
commit f0ec7b08a3
10 changed files with 123 additions and 68 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

57
Amount.hs
View File

@ -35,26 +35,28 @@ arithmetic:
tests = runTestTT $ test [
show (dollars 1) ~?= "$1.00"
,
show (hours 1) ~?= "1h" -- currently h1.00
,
parseAmount "$1" ~?= dollars 1 -- currently 0
,show (hours 1) ~?= "1h" -- currently h1.00
,parseAmount "$1" ~?= dollars 1 -- currently 0
]
instance Show Amount where show = showAmountRoundedOrZero
nullamt = dollars 0
parseAmount :: String -> Amount
parseAmount s = nullamt
instance Show Amount where show = showAmountRounded
showAmountRounded :: Amount -> String
showAmountRounded (Amount c q p) =
(symbol c) ++ (punctuatethousands $ printf ("%."++show p++"f") q)
showAmountRoundedOrZero :: Amount -> String
showAmountRoundedOrZero (Amount cur qty) =
let rounded = punctuatethousands $ printf "%.2f" qty in
case rounded of
"0.00" -> "0"
"-0.00" -> "0"
otherwise -> (symbol cur) ++ rounded
showAmountRoundedOrZero a@(Amount c _ _) =
let s = showAmountRounded a
noncurrency = drop (length $ symbol c)
nonnulls = filter (flip notElem "-+,.0")
iszero = (nonnulls $ noncurrency s) == ""
in if iszero then "0" else s
punctuatethousands :: String -> String
punctuatethousands s =
@ -67,17 +69,26 @@ punctuatethousands s =
triples s = [take 3 s] ++ (triples $ drop 3 s)
instance Num Amount where
abs (Amount c q) = Amount c (abs q)
signum (Amount c q) = Amount c (signum q)
fromInteger i = Amount (getcurrency "$") (fromInteger i)
(+) = amountAdd
(-) = amountSub
(*) = amountMul
Amount ac aq `amountAdd` b = Amount ac (aq + (quantity $ toCurrency ac b))
Amount ac aq `amountSub` b = Amount ac (aq - (quantity $ toCurrency ac b))
Amount ac aq `amountMul` b = Amount ac (aq * (quantity $ toCurrency ac b))
abs (Amount c q p) = Amount c (abs q) p
signum (Amount c q p) = Amount c (signum q) p
fromInteger i = Amount (getcurrency "$") (fromInteger i) amtintprecision
(+) = amountop (+)
(-) = amountop (-)
(*) = amountop (*)
-- problem: when an integer is converted to an amount it must pick a
-- precision, which we specify here (should be infinite ?). This can
-- affect amount arithmetic, in particular the sum of a list of amounts.
-- So, we may need to adjust the precision after summing amounts.
amtintprecision = 2
-- apply op to two amounts, adopting a's currency and lowest precision
amountop :: (Double -> Double -> Double) -> Amount -> Amount -> Amount
amountop op (Amount ac aq ap) b@(Amount _ _ bp) =
Amount ac (aq `op` (quantity $ toCurrency ac b)) (min ap bp)
toCurrency :: Currency -> Amount -> Amount
toCurrency newc (Amount oldc q) =
Amount newc (q * (conversionRate oldc newc))
toCurrency newc (Amount oldc q p) =
Amount newc (q * (conversionRate oldc newc)) p

10
Currency.hs
View File

@ -19,9 +19,9 @@ conversionRate :: Currency -> Currency -> Double
conversionRate oldc newc = (rate newc) / (rate oldc)
-- convenient amount constructors
dollars = Amount $ getcurrency "$"
euro = Amount $ getcurrency "EUR"
pounds = Amount $ getcurrency "£"
hours = Amount $ getcurrency "h"
minutes = Amount $ getcurrency "m"
dollars n = Amount (getcurrency "$") n 2
euro n = Amount (getcurrency "EUR") n 2
pounds n = Amount (getcurrency "£") n 2
hours n = Amount (getcurrency "h") n 2
minutes n = Amount (getcurrency "m") n 2

4
EntryTransaction.hs
View File

@ -1,4 +1,3 @@
module EntryTransaction
where
import Utils
@ -22,6 +21,9 @@ amount (e,t) = tamount t
flattenEntry :: Entry -> [EntryTransaction]
flattenEntry e = [(e,t) | t <- etransactions e]
entryTransactionSetPrecision :: Int -> EntryTransaction -> EntryTransaction
entryTransactionSetPrecision p (e, Transaction a amt) = (e, Transaction a amt{precision=p})
accountNamesFromTransactions :: [EntryTransaction] -> [AccountName]
accountNamesFromTransactions ts = nub $ map account ts

14
Ledger.hs
View File

@ -33,12 +33,13 @@ cacheLedger l =
txns a = tmap ! a
subaccts a = filter (isAccountNamePrefixOf a) ans
subtxns a = concat [txns a | a <- [a] ++ subaccts a]
lprecision = maximum $ map (precision . tamount . transaction) ts
bmap = Map.union
(Map.fromList [(a, sumEntryTransactions $ subtxns a) | a <- ans])
(Map.fromList [(a, (sumEntryTransactions $ 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
Ledger l ant amap lprecision
accountnames :: Ledger -> [AccountName]
accountnames l = flatten $ accountnametree l
@ -46,8 +47,15 @@ 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 -> [EntryTransaction]
ledgerTransactions l = concatMap atransactions $ Map.elems $ accounts l
ledgerTransactions l =
setprecisions $ rawLedgerTransactions $ rawledger l
where
setprecisions = map (entryTransactionSetPrecision (lprecision l))
ledgerTransactionsMatching :: ([String],[String]) -> Ledger -> [EntryTransaction]
ledgerTransactionsMatching ([],[]) l = ledgerTransactionsMatching ([".*"],[".*"]) l

12
NOTES
View File

@ -2,10 +2,11 @@ hledger project notes
* TO DO
** bugs
*** unclear parse error when only one space before amount
unexpected "$"
expecting letter or digit, ":", "/", "_", amount, comment or new-line
*** handle unknown currencies
** compatibility
*** use greatest precision in register
*** abbreviate 0
*** don't combine entries so much in register
** basic features
*** print
*** !include
@ -13,7 +14,7 @@ hledger project notes
** advanced features
*** handle mixed amounts
*** 3.0-style elision
*** ledger 3.0-style elision
*** -p period expressions
*** -d display expressions
*** read gnucash files
@ -48,6 +49,9 @@ hledger project notes
** documentation
*** literate docs
*** better use of haddock
*** differences
**** ledger shows comments after descriptions as part of description
**** ledger does not sort register by date
** marketing
*** set up as a cabal/hackage project following wiki howto
http://en.wikibooks.org/wiki/Haskell/Packaging

21
Parse.hs
View File

@ -222,18 +222,23 @@ ledgeraccount :: Parser String
ledgeraccount = many1 (alphaNum <|> char ':' <|> char '/' <|> char '_' <|> try (do {spacenonewline; do {notFollowedBy spacenonewline; return ' '}}))
ledgeramount :: Parser Amount
ledgeramount = try (do
ledgeramount =
try (do
many1 spacenonewline
currency <- many (noneOf "-.0123456789;\n") <?> "currency"
quantity <- many1 (oneOf "-.,0123456789") <?> "quantity"
return (Amount (getcurrency currency) (read $ stripcommas quantity))
) <|>
return (Amount (Currency "AUTO" 0) 0)
c <- many (noneOf "-.0123456789;\n") <?> "currency"
q <- many1 (oneOf "-.,0123456789") <?> "quantity"
let q' = stripcommas $ striptrailingpoint q
let (int,frac) = break (=='.') q'
let precision = length $ dropWhile (=='.') frac
return (Amount (getcurrency c) (read q') precision)
)
<|> return (Amount (Currency "AUTO" 0) 0 0)
where
stripcommas = filter (',' /=)
striptrailingpoint = reverse . dropWhile (=='.') . reverse
ledgereol :: Parser String
ledgereol = ledgercomment <|> do {newline; return []} -- XXX problem, a transaction comment containing a digit fails
ledgereol = ledgercomment <|> do {newline; return []}
spacenonewline :: Parser Char
spacenonewline = satisfy (\c -> c `elem` " \v\f\t")

53
Tests.hs
View File

@ -75,8 +75,8 @@ entry1_str = "\
entry1 =
(Entry "2007/01/28" False "" "coopportunity"
[Transaction "expenses:food:groceries" (Amount (getcurrency "$") 47.18),
Transaction "assets:checking" (Amount (getcurrency "$") (-47.18))])
[Transaction "expenses:food:groceries" (Amount (getcurrency "$") 47.18 2),
Transaction "assets:checking" (Amount (getcurrency "$") (-47.18) 2)])
entry2_str = "\
\2007/01/27 * joes diner\n\
@ -214,9 +214,9 @@ ledger7 = RawLedger
edate="2007/01/01", estatus=False, ecode="*", edescription="opening balance",
etransactions=[
Transaction {taccount="assets:cash",
tamount=Amount {currency=(getcurrency "$"), quantity=4.82}},
tamount=Amount {currency=(getcurrency "$"), quantity=4.82, precision=2}},
Transaction {taccount="equity:opening balances",
tamount=Amount {currency=(getcurrency "$"), quantity=(-4.82)}}
tamount=Amount {currency=(getcurrency "$"), quantity=(-4.82), precision=2}}
]
}
,
@ -224,9 +224,9 @@ ledger7 = RawLedger
edate="2007/02/01", estatus=False, ecode="*", edescription="ayres suites",
etransactions=[
Transaction {taccount="expenses:vacation",
tamount=Amount {currency=(getcurrency "$"), quantity=179.92}},
tamount=Amount {currency=(getcurrency "$"), quantity=179.92, precision=2}},
Transaction {taccount="assets:checking",
tamount=Amount {currency=(getcurrency "$"), quantity=(-179.92)}}
tamount=Amount {currency=(getcurrency "$"), quantity=(-179.92), precision=2}}
]
}
,
@ -234,9 +234,9 @@ ledger7 = RawLedger
edate="2007/01/02", estatus=False, ecode="*", edescription="auto transfer to savings",
etransactions=[
Transaction {taccount="assets:saving",
tamount=Amount {currency=(getcurrency "$"), quantity=200}},
tamount=Amount {currency=(getcurrency "$"), quantity=200, precision=2}},
Transaction {taccount="assets:checking",
tamount=Amount {currency=(getcurrency "$"), quantity=(-200)}}
tamount=Amount {currency=(getcurrency "$"), quantity=(-200), precision=2}}
]
}
,
@ -244,9 +244,9 @@ ledger7 = RawLedger
edate="2007/01/03", estatus=False, ecode="*", edescription="poquito mas",
etransactions=[
Transaction {taccount="expenses:food:dining",
tamount=Amount {currency=(getcurrency "$"), quantity=4.82}},
tamount=Amount {currency=(getcurrency "$"), quantity=4.82, precision=2}},
Transaction {taccount="assets:cash",
tamount=Amount {currency=(getcurrency "$"), quantity=(-4.82)}}
tamount=Amount {currency=(getcurrency "$"), quantity=(-4.82), precision=2}}
]
}
,
@ -254,9 +254,9 @@ ledger7 = RawLedger
edate="2007/01/03", estatus=False, ecode="*", edescription="verizon",
etransactions=[
Transaction {taccount="expenses:phone",
tamount=Amount {currency=(getcurrency "$"), quantity=95.11}},
tamount=Amount {currency=(getcurrency "$"), quantity=95.11, precision=2}},
Transaction {taccount="assets:checking",
tamount=Amount {currency=(getcurrency "$"), quantity=(-95.11)}}
tamount=Amount {currency=(getcurrency "$"), quantity=(-95.11), precision=2}}
]
}
,
@ -264,9 +264,9 @@ ledger7 = RawLedger
edate="2007/01/03", estatus=False, ecode="*", edescription="discover",
etransactions=[
Transaction {taccount="liabilities:credit cards:discover",
tamount=Amount {currency=(getcurrency "$"), quantity=80}},
tamount=Amount {currency=(getcurrency "$"), quantity=80, precision=2}},
Transaction {taccount="assets:checking",
tamount=Amount {currency=(getcurrency "$"), quantity=(-80)}}
tamount=Amount {currency=(getcurrency "$"), quantity=(-80), precision=2}}
]
}
]
@ -313,9 +313,30 @@ hunit = runTestTT $ "hunit" ~: test ([
,"" ~: test_ledgerAccountNames
,"" ~: test_cacheLedger
,"" ~: test_showLedgerAccounts
,"" ~: test_Amount
] :: [Test])
test_ledgertransaction :: Assertion
test_ledgeramount :: Assertion
test_ledgeramount = do
assertParseEqual (Amount (getcurrency "$") 47.18 2)
(parse' ledgeramount " $47.18")
assertParseEqual (Amount (getcurrency "$") 1 0)
(parse' ledgeramount " $1.")
test_Amount = do
-- precision subtleties
let a1 = Amount (getcurrency "$") 1.23 1
let a2 = Amount (getcurrency "$") (-1.23) 2
let a3 = Amount (getcurrency "$") (-1.23) 3
assertEqual "1" (Amount (getcurrency "$") 0 1) (a1 + a2)
assertEqual "2" (Amount (getcurrency "$") 0 1) (a1 + a3)
assertEqual "3" (Amount (getcurrency "$") (-2.46) 2) (a2 + a3)
assertEqual "4" (Amount (getcurrency "$") (-2.46) 3) (a3 + a3)
-- sum adds 0, with Amount fromIntegral's default precision of 2
assertEqual "5" (Amount (getcurrency "$") 0 1) (sum [a1,a2])
assertEqual "6" (Amount (getcurrency "$") (-2.46) 2) (sum [a2,a3])
assertEqual "7" (Amount (getcurrency "$") (-2.46) 2) (sum [a3,a3])
test_ledgertransaction =
assertParseEqual transaction1 (parse' ledgertransaction transaction1_str)
@ -324,7 +345,7 @@ test_ledgerentry =
test_autofillEntry =
assertEqual'
(Amount (getcurrency "$") (-47.18))
(Amount (getcurrency "$") (-47.18) 2)
(tamount $ last $ etransactions $ autofillEntry entry1)
test_timelogentry = do

8
Transaction.hs
View File

@ -9,9 +9,11 @@ import Amount
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)
showTransaction :: Transaction -> String
showTransaction t = (showaccountname $ taccount t) ++ " " ++ (showamount $ tamount t)
where
showaccountname = printf "%-22s" . elideRight 22
showamount = printf "%11s" . showAmountRoundedOrZero
elideRight width s =
case length s > width of

6
Types.hs
View File

@ -43,7 +43,8 @@ data Currency = Currency {
-- some amount of money, time, stock, oranges, etc.
data Amount = Amount {
currency :: Currency,
quantity :: Double
quantity :: Double,
precision :: Int -- number of significant decimal places
} deriving (Eq)
-- AccountNames are strings like "assets:cash:petty"; from these we build
@ -115,6 +116,7 @@ data Account = Account {
data Ledger = Ledger {
rawledger :: RawLedger,
accountnametree :: Tree AccountName,
accounts :: Map.Map AccountName Account
accounts :: Map.Map AccountName Account,
lprecision :: Int
}

2
hledger.hs
View File

@ -46,7 +46,7 @@ register opts acctpats descpats = do
printRegister l =
putStr $ showTransactionsWithBalances
(sortBy (comparing date) (ledgerTransactionsMatching (acctpats,descpats) l))
0
nullamt{precision=lprecision l}
balance :: [Flag] -> [String] -> [String] -> IO ()
balance opts acctpats _ = do