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

refactor: move amount display settings out of commodity, simplify amount construction

Browse Source
This commit is contained in:
Simon Michael 2012-11-19 21:20:10 +00:00
parent ae74983436
commit 4567e91409
14 changed files with 502 additions and 486 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

297
hledger-lib/Hledger/Data/Amount.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving, RecordWildCards #-}
{-| {-|
A simple 'Amount' is some quantity of money, shares, or anything else. A simple 'Amount' is some quantity of money, shares, or anything else.
It has a (possibly null) 'Commodity' and a numeric quantity: It has a (possibly null) 'Commodity' and a numeric quantity:
@ -43,30 +43,38 @@ exchange rates.
module Hledger.Data.Amount ( module Hledger.Data.Amount (
-- * Amount -- * Amount
amount,
nullamt, nullamt,
missingamt, missingamt,
amt,
usd,
eur,
gbp,
hrs,
at,
(@@),
amountWithCommodity, amountWithCommodity,
canonicaliseAmountCommodity,
setAmountPrecision,
-- ** arithmetic -- ** arithmetic
costOfAmount, costOfAmount,
divideAmount, divideAmount,
sumAmounts, sumAmounts,
-- ** rendering -- ** rendering
amountstyle,
showAmount, showAmount,
showAmountDebug, showAmountDebug,
showAmountWithoutPrice, showAmountWithoutPrice,
maxprecision, maxprecision,
maxprecisionwithpoint, maxprecisionwithpoint,
setAmountPrecision,
withPrecision,
canonicaliseAmount,
canonicalStyles,
-- * MixedAmount -- * MixedAmount
nullmixedamt, nullmixedamt,
missingmixedamt, missingmixedamt,
amounts, amounts,
normaliseMixedAmountPreservingFirstPrice, normaliseMixedAmountPreservingFirstPrice,
normaliseMixedAmountPreservingPrices, normaliseMixedAmountPreservingPrices,
canonicaliseMixedAmountCommodity,
mixedAmountWithCommodity,
setMixedAmountPrecision,
-- ** arithmetic -- ** arithmetic
costOfMixedAmount, costOfMixedAmount,
divideMixedAmount, divideMixedAmount,
@ -78,6 +86,8 @@ module Hledger.Data.Amount (
showMixedAmountDebug, showMixedAmountDebug,
showMixedAmountWithoutPrice, showMixedAmountWithoutPrice,
showMixedAmountWithPrecision, showMixedAmountWithPrecision,
setMixedAmountPrecision,
canonicaliseMixedAmount,
-- * misc. -- * misc.
ltraceamount, ltraceamount,
tests_Hledger_Data_Amount tests_Hledger_Data_Amount
@ -86,9 +96,10 @@ module Hledger.Data.Amount (
import Data.Char (isDigit) import Data.Char (isDigit)
import Data.List import Data.List
import Data.Map (findWithDefault) import Data.Map (findWithDefault)
import Data.Ord (comparing)
import Test.HUnit import Test.HUnit
import Text.Printf import Text.Printf
import qualified Data.Map as Map import qualified Data.Map as M
import Hledger.Data.Types import Hledger.Data.Types
import Hledger.Data.Commodity import Hledger.Data.Commodity
@ -97,52 +108,75 @@ import Hledger.Utils
deriving instance Show HistoricalPrice deriving instance Show HistoricalPrice
amountstyle = AmountStyle L False 0 '.' ',' []
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- Amount -- Amount
instance Show Amount where show = showAmountDebug instance Show Amount where show = showAmountDebug
instance Num Amount where instance Num Amount where
abs (Amount c q p) = Amount c (abs q) p abs a@Amount{aquantity=q} = a{aquantity=abs q}
signum (Amount c q p) = Amount c (signum q) p signum a@Amount{aquantity=q} = a{aquantity=signum q}
fromInteger i = Amount (comm "") (fromInteger i) Nothing fromInteger i = nullamt{aquantity=fromInteger i}
negate a@Amount{quantity=q} = a{quantity=(-q)} negate a@Amount{aquantity=q} = a{aquantity=(-q)}
(+) = similarAmountsOp (+) (+) = similarAmountsOp (+)
(-) = similarAmountsOp (-) (-) = similarAmountsOp (-)
(*) = similarAmountsOp (*) (*) = similarAmountsOp (*)
-- | The empty simple amount. -- | The empty simple amount.
nullamt :: Amount amount :: Amount
nullamt = Amount unknown 0 Nothing amount = Amount{acommodity="", aquantity=0, aprice=Nothing, astyle=amountstyle}
nullamt = amount
-- | Apply a binary arithmetic operator to two amounts, ignoring and -- handy amount constructors for tests
-- discarding any assigned prices, and converting the first to the amt n = amount{acommodity="", aquantity=n}
-- commodity of the second in a simplistic way (1-1 exchange rate). usd n = amount{acommodity="$", aquantity=n, astyle=amountstyle{asprecision=2}}
-- The highest precision of either amount is preserved in the result. eur n = amount{acommodity="€", aquantity=n, astyle=amountstyle{asprecision=2}}
gbp n = amount{acommodity="£", aquantity=n, astyle=amountstyle{asprecision=2}}
hrs n = amount{acommodity="h", aquantity=n, astyle=amountstyle{asprecision=1, ascommodityside=R}}
-- | Apply a binary arithmetic operator to two amounts in the same
-- commodity. Warning, as a kludge to support folds (eg sum) we assign
-- the second's commodity to the first so the same commodity requirement
-- is not checked. The highest precision of either amount is preserved in
-- the result. Any prices are currently ignored and discarded. The display
-- style is that of the first amount, with precision set to the highest of
-- either amount.
similarAmountsOp :: (Double -> Double -> Double) -> Amount -> Amount -> Amount similarAmountsOp :: (Double -> Double -> Double) -> Amount -> Amount -> Amount
similarAmountsOp op a@(Amount Commodity{precision=ap} _ _) (Amount bc@Commodity{precision=bp} bq _) = similarAmountsOp op Amount{acommodity=_, aquantity=aq, astyle=AmountStyle{asprecision=ap}}
Amount bc{precision=max ap bp} (quantity (amountWithCommodity bc a) `op` bq) Nothing Amount{acommodity=bc, aquantity=bq, astyle=bs@AmountStyle{asprecision=bp}} =
-- trace ("a:"++showAmount a) $ trace ("b:"++showAmount b++"\n") $ tracewith (("=:"++).showAmount)
amount{acommodity=bc, aquantity=aq `op` bq, astyle=bs{asprecision=max ap bp}}
-- | ac==bc = amount{acommodity=ac, aquantity=aq `op` bq, astyle=as{asprecision=max ap bp}}
-- | otherwise = error "tried to do simple arithmetic with amounts in different commodities"
-- | Convert an amount to the specified commodity, ignoring and discarding -- | Convert an amount to the specified commodity, ignoring and discarding
-- any assigned prices and assuming an exchange rate of 1. -- any assigned prices and assuming an exchange rate of 1.
amountWithCommodity :: Commodity -> Amount -> Amount amountWithCommodity :: Commodity -> Amount -> Amount
amountWithCommodity c (Amount _ q _) = Amount c q Nothing amountWithCommodity c a = a{acommodity=c, aprice=Nothing}
-- | A more complete amount adding operation. -- | A more complete amount adding operation.
sumAmounts :: [Amount] -> MixedAmount sumAmounts :: [Amount] -> MixedAmount
sumAmounts = normaliseMixedAmountPreservingPrices . Mixed sumAmounts = normaliseMixedAmountPreservingPrices . Mixed
-- | Set an amount's unit price.
at :: Amount -> Amount -> Amount
amt `at` priceamt = amt{aprice=Just $ UnitPrice $ Mixed [priceamt]}
-- | Set an amount's total price.
(@@) :: Amount -> Amount -> Amount
amt @@ priceamt = amt{aprice=Just $ TotalPrice $ Mixed [priceamt]}
tests_sumAmounts = [ tests_sumAmounts = [
"sumAmounts" ~: do "sumAmounts" ~: do
-- when adding, we don't convert to the price commodity - just -- when adding, we don't convert to the price commodity - just
-- combine what amounts we can. -- combine what amounts we can.
-- amounts with same unit price -- amounts with same unit price
(sumAmounts [(Amount dollar 1 (Just $ UnitPrice $ Mixed [euros 1])), (Amount dollar 1 (Just $ UnitPrice $ Mixed [euros 1]))]) sumAmounts [usd 1 `at` eur 1, usd 1 `at` eur 1] `is` Mixed [usd 2 `at` eur 1]
`is` (Mixed [Amount dollar 2 (Just $ UnitPrice $ Mixed [euros 1])])
-- amounts with different unit prices -- amounts with different unit prices
-- amounts with total prices -- amounts with total prices
(sumAmounts [(Amount dollar 1 (Just $ TotalPrice $ Mixed [euros 1])), (Amount dollar 1 (Just $ TotalPrice $ Mixed [euros 1]))]) sumAmounts [usd 1 @@ eur 1, usd 1 @@ eur 1] `is` Mixed [usd 1 @@ eur 1, usd 1 @@ eur 1]
`is` (Mixed [(Amount dollar 1 (Just $ TotalPrice $ Mixed [euros 1])), (Amount dollar 1 (Just $ TotalPrice $ Mixed [euros 1]))])
-- amounts with no, unit, and/or total prices -- amounts with no, unit, and/or total prices
] ]
@ -152,20 +186,20 @@ tests_sumAmounts = [
-- --
-- - price amounts should be positive, though this is not currently enforced -- - price amounts should be positive, though this is not currently enforced
costOfAmount :: Amount -> Amount costOfAmount :: Amount -> Amount
costOfAmount a@(Amount _ q price) = costOfAmount a@Amount{aquantity=q, aprice=price} =
case price of case price of
Nothing -> a Nothing -> a
Just (UnitPrice (Mixed [Amount pc pq Nothing])) -> Amount pc (pq*q) Nothing Just (UnitPrice (Mixed [p@Amount{aquantity=pq}])) -> p{aquantity=pq * q}
Just (TotalPrice (Mixed [Amount pc pq Nothing])) -> Amount pc (pq*signum q) Nothing Just (TotalPrice (Mixed [p@Amount{aquantity=pq}])) -> p{aquantity=pq * signum q}
_ -> error' "costOfAmount: Malformed price encountered, programmer error" _ -> error' "costOfAmount: Malformed price encountered, programmer error"
-- | Divide an amount's quantity by a constant. -- | Divide an amount's quantity by a constant.
divideAmount :: Amount -> Double -> Amount divideAmount :: Amount -> Double -> Amount
divideAmount a@Amount{quantity=q} d = a{quantity=q/d} divideAmount a@Amount{aquantity=q} d = a{aquantity=q/d}
-- | Is this amount negative ? The price is ignored. -- | Is this amount negative ? The price is ignored.
isNegativeAmount :: Amount -> Bool isNegativeAmount :: Amount -> Bool
isNegativeAmount Amount{quantity=q} = q < 0 isNegativeAmount Amount{aquantity=q} = q < 0
digits = "123456789" :: String digits = "123456789" :: String
@ -178,7 +212,7 @@ isZeroAmount a -- a==missingamt = False
-- Since we are using floating point, for now just test to some high precision. -- Since we are using floating point, for now just test to some high precision.
isReallyZeroAmount :: Amount -> Bool isReallyZeroAmount :: Amount -> Bool
isReallyZeroAmount a -- a==missingamt = False isReallyZeroAmount a -- a==missingamt = False
| otherwise = (null . filter (`elem` digits) . printf ("%."++show zeroprecision++"f") . quantity) a | otherwise = (null . filter (`elem` digits) . printf ("%."++show zeroprecision++"f") . aquantity) a
where zeroprecision = 8 where zeroprecision = 8
-- | Get the string representation of an amount, based on its commodity's -- | Get the string representation of an amount, based on its commodity's
@ -186,23 +220,27 @@ isReallyZeroAmount a -- a==missingamt = False
showAmountWithPrecision :: Int -> Amount -> String showAmountWithPrecision :: Int -> Amount -> String
showAmountWithPrecision p = showAmount . setAmountPrecision p showAmountWithPrecision p = showAmount . setAmountPrecision p
-- | Set the display precision in the amount's commodity. -- | Set an amount's display precision.
setAmountPrecision :: Int -> Amount -> Amount setAmountPrecision :: Int -> Amount -> Amount
setAmountPrecision p a@Amount{commodity=c} = a{commodity=c{precision=p}} setAmountPrecision p a@Amount{astyle=s} = a{astyle=s{asprecision=p}}
-- | Set an amount's display precision, flipped.
withPrecision :: Amount -> Int -> Amount
withPrecision = flip setAmountPrecision
-- | Get the unambiguous string representation of an amount, for debugging. -- | Get the unambiguous string representation of an amount, for debugging.
showAmountDebug :: Amount -> String showAmountDebug :: Amount -> String
showAmountDebug (Amount (Commodity {symbol="AUTO"}) _ _) = "(missing)" showAmountDebug Amount{acommodity="AUTO"} = "(missing)"
showAmountDebug (Amount c q pri) = printf "Amount {commodity = %s, quantity = %s, price = %s}" showAmountDebug Amount{..} = printf "Amount {acommodity=%s, aquantity=%s, aprice=%s, astyle=%s}"
(show c) (show q) (maybe "Nothing" showPriceDebug pri) (show acommodity) (show aquantity) (maybe "Nothing" showPriceDebug aprice) (show astyle)
-- | Get the string representation of an amount, without any \@ price. -- | Get the string representation of an amount, without any \@ price.
showAmountWithoutPrice :: Amount -> String showAmountWithoutPrice :: Amount -> String
showAmountWithoutPrice a = showAmount a{price=Nothing} showAmountWithoutPrice a = showAmount a{aprice=Nothing}
-- | Get the string representation of an amount, without any price or commodity symbol. -- | Get the string representation of an amount, without any price or commodity symbol.
showAmountWithoutPriceOrCommodity :: Amount -> String showAmountWithoutPriceOrCommodity :: Amount -> String
showAmountWithoutPriceOrCommodity a@Amount{commodity=c} = showAmount a{commodity=c{symbol=""}, price=Nothing} showAmountWithoutPriceOrCommodity a = showAmount a{acommodity="", aprice=Nothing}
showPrice :: Price -> String showPrice :: Price -> String
showPrice (UnitPrice pa) = " @ " ++ showMixedAmount pa showPrice (UnitPrice pa) = " @ " ++ showMixedAmount pa
@ -216,23 +254,23 @@ showPriceDebug (TotalPrice pa) = " @@ " ++ showMixedAmountDebug pa
-- display settings. String representations equivalent to zero are -- display settings. String representations equivalent to zero are
-- converted to just \"0\". -- converted to just \"0\".
showAmount :: Amount -> String showAmount :: Amount -> String
showAmount (Amount (Commodity {symbol="AUTO"}) _ _) = "" showAmount Amount{acommodity="AUTO"} = ""
showAmount a@(Amount (Commodity {symbol=sym,side=side,spaced=spaced}) _ pri) = showAmount a@(Amount{acommodity=c, aprice=p, astyle=AmountStyle{..}}) =
case side of case ascommodityside of
L -> printf "%s%s%s%s" sym' space quantity' price L -> printf "%s%s%s%s" c' space quantity' price
R -> printf "%s%s%s%s" quantity' space sym' price R -> printf "%s%s%s%s" quantity' space c' price
where where
quantity = showamountquantity a quantity = showamountquantity a
displayingzero = null $ filter (`elem` digits) $ quantity displayingzero = null $ filter (`elem` digits) $ quantity
(quantity',sym') | displayingzero = ("0","") (quantity',c') | displayingzero = ("0","")
| otherwise = (quantity,quoteCommoditySymbolIfNeeded sym) | otherwise = (quantity, quoteCommoditySymbolIfNeeded c)
space = if (not (null sym') && spaced) then " " else "" :: String space = if (not (null c') && ascommodityspaced) then " " else "" :: String
price = maybe "" showPrice pri price = maybe "" showPrice p
-- | Get the string representation of the number part of of an amount, -- | Get the string representation of the number part of of an amount,
-- using the display settings from its commodity. -- using the display settings from its commodity.
showamountquantity :: Amount -> String showamountquantity :: Amount -> String
showamountquantity (Amount (Commodity {decimalpoint=d,precision=p,separator=s,separatorpositions=spos}) q _) = showamountquantity Amount{aquantity=q, astyle=AmountStyle{asprecision=p, asdecimalpoint=d, asseparator=s, asseparatorpositions=spos}} =
punctuatenumber d s spos $ qstr punctuatenumber d s spos $ qstr
where where
-- isint n = fromIntegral (round n) == n -- isint n = fromIntegral (round n) == n
@ -242,7 +280,8 @@ showamountquantity (Amount (Commodity {decimalpoint=d,precision=p,separator=s,se
| otherwise = printf ("%."++show p++"f") q | otherwise = printf ("%."++show p++"f") q
-- | Replace a number string's decimal point with the specified character, -- | Replace a number string's decimal point with the specified character,
-- and add the specified digit group separators. -- and add the specified digit group separators. The last digit group will
-- be repeated as needed.
punctuatenumber :: Char -> Char -> [Int] -> String -> String punctuatenumber :: Char -> Char -> [Int] -> String -> String
punctuatenumber dec sep grps str = sign ++ reverse (addseps sep (extend grps) (reverse int)) ++ frac'' punctuatenumber dec sep grps str = sign ++ reverse (addseps sep (extend grps) (reverse int)) ++ frac''
where where
@ -271,15 +310,12 @@ maxprecision = 999998
maxprecisionwithpoint :: Int maxprecisionwithpoint :: Int
maxprecisionwithpoint = 999999 maxprecisionwithpoint = 999999
-- | Replace an amount's commodity with the canonicalised version from
-- the provided commodity map.
canonicaliseAmountCommodity :: Maybe (Map.Map String Commodity) -> Amount -> Amount
canonicaliseAmountCommodity Nothing = id
canonicaliseAmountCommodity (Just canonicalcommoditymap) = fixamount
where
-- like journalCanonicaliseAmounts -- like journalCanonicaliseAmounts
fixamount a@Amount{commodity=c} = a{commodity=fixcommodity c} -- | Canonicalise an amount's display style using the provided commodity style map.
fixcommodity c@Commodity{symbol=s} = findWithDefault c s canonicalcommoditymap canonicaliseAmount :: M.Map Commodity AmountStyle -> Amount -> Amount
canonicaliseAmount styles a@Amount{acommodity=c, astyle=s} = a{astyle=s'}
where
s' = findWithDefault s c styles
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- MixedAmount -- MixedAmount
@ -287,7 +323,7 @@ canonicaliseAmountCommodity (Just canonicalcommoditymap) = fixamount
instance Show MixedAmount where show = showMixedAmountDebug instance Show MixedAmount where show = showMixedAmountDebug
instance Num MixedAmount where instance Num MixedAmount where
fromInteger i = Mixed [Amount (comm "") (fromInteger i) Nothing] fromInteger i = Mixed [fromInteger i]
negate (Mixed as) = Mixed $ map negate as negate (Mixed as) = Mixed $ map negate as
(+) (Mixed as) (Mixed bs) = normaliseMixedAmountPreservingPrices $ Mixed $ as ++ bs (+) (Mixed as) (Mixed bs) = normaliseMixedAmountPreservingPrices $ Mixed $ as ++ bs
(*) = error' "programming error, mixed amounts do not support multiplication" (*) = error' "programming error, mixed amounts do not support multiplication"
@ -300,7 +336,7 @@ nullmixedamt = Mixed []
-- | A temporary value for parsed transactions which had no amount specified. -- | A temporary value for parsed transactions which had no amount specified.
missingamt :: Amount missingamt :: Amount
missingamt = Amount unknown{symbol="AUTO"} 0 Nothing missingamt = amount{acommodity="AUTO"}
missingmixedamt :: MixedAmount missingmixedamt :: MixedAmount
missingmixedamt = Mixed [missingamt] missingmixedamt = Mixed [missingamt]
@ -312,30 +348,29 @@ normaliseMixedAmountPreservingPrices :: MixedAmount -> MixedAmount
normaliseMixedAmountPreservingPrices (Mixed as) = Mixed as'' normaliseMixedAmountPreservingPrices (Mixed as) = Mixed as''
where where
as'' = if null nonzeros then [nullamt] else nonzeros as'' = if null nonzeros then [nullamt] else nonzeros
(_,nonzeros) = partition isReallyZeroAmount $ filter (/= missingamt) as' (_,nonzeros) = partition isReallyZeroAmount as'
as' = map sumAmountsUsingFirstPrice $ group $ sort as as' = map sumAmountsUsingFirstPrice $ group $ sort $ filter (/= missingamt) as
sort = sortBy (\a1 a2 -> compare (sym a1,price a1) (sym a2,price a2)) sort = sortBy (\a1 a2 -> compare (acommodity a1, aprice a1) (acommodity a2, aprice a2))
sym = symbol . commodity group = groupBy (\a1 a2 -> acommodity a1 == acommodity a2 && sameunitprice a1 a2)
group = groupBy (\a1 a2 -> sym a1 == sym a2 && sameunitprice a1 a2)
where where
sameunitprice a1 a2 = sameunitprice a1 a2 =
case (price a1, price a2) of case (aprice a1, aprice a2) of
(Nothing, Nothing) -> True (Nothing, Nothing) -> True
(Just (UnitPrice p1), Just (UnitPrice p2)) -> p1 == p2 (Just (UnitPrice p1), Just (UnitPrice p2)) -> p1 == p2
_ -> False _ -> False
tests_normaliseMixedAmountPreservingPrices = [ tests_normaliseMixedAmountPreservingPrices = [
"normaliseMixedAmountPreservingPrices" ~: do "normaliseMixedAmountPreservingPrices" ~: do
assertEqual "discard missing amount" (Mixed [nullamt]) (normaliseMixedAmountPreservingPrices $ Mixed [dollars 0, missingamt]) assertEqual "discard missing amount" (Mixed [nullamt]) (normaliseMixedAmountPreservingPrices $ Mixed [usd 0, missingamt])
assertEqual "combine unpriced same-commodity amounts" (Mixed [dollars 2]) (normaliseMixedAmountPreservingPrices $ Mixed [dollars 0, dollars 2]) assertEqual "combine unpriced same-commodity amounts" (Mixed [usd 2]) (normaliseMixedAmountPreservingPrices $ Mixed [usd 0, usd 2])
assertEqual "don't combine total-priced amounts" assertEqual "don't combine total-priced amounts"
(Mixed (Mixed
[Amount dollar 1 (Just $ TotalPrice $ Mixed [euros 1]) [usd 1 @@ eur 1
,Amount dollar (-2) (Just $ TotalPrice $ Mixed [euros 1]) ,usd (-2) @@ eur 1
]) ])
(normaliseMixedAmountPreservingPrices $ Mixed (normaliseMixedAmountPreservingPrices $ Mixed
[Amount dollar 1 (Just $ TotalPrice $ Mixed [euros 1]) [usd 1 @@ eur 1
,Amount dollar (-2) (Just $ TotalPrice $ Mixed [euros 1]) ,usd (-2) @@ eur 1
]) ])
] ]
@ -351,9 +386,8 @@ normaliseMixedAmountPreservingFirstPrice (Mixed as) = Mixed as''
as'' = if null nonzeros then [nullamt] else nonzeros as'' = if null nonzeros then [nullamt] else nonzeros
(_,nonzeros) = partition (\a -> isReallyZeroAmount a && a /= missingamt) as' (_,nonzeros) = partition (\a -> isReallyZeroAmount a && a /= missingamt) as'
as' = map sumAmountsUsingFirstPrice $ group $ sort as as' = map sumAmountsUsingFirstPrice $ group $ sort as
sort = sortBy (\a1 a2 -> compare (sym a1) (sym a2)) sort = sortBy (\a1 a2 -> compare (acommodity a1) (acommodity a2))
group = groupBy (\a1 a2 -> sym a1 == sym a2) group = groupBy (\a1 a2 -> acommodity a1 == acommodity a2)
sym = symbol . commodity
-- discardPrice :: Amount -> Amount -- discardPrice :: Amount -> Amount
-- discardPrice a = a{price=Nothing} -- discardPrice a = a{price=Nothing}
@ -362,7 +396,7 @@ normaliseMixedAmountPreservingFirstPrice (Mixed as) = Mixed as''
-- discardPrices (Mixed as) = Mixed $ map discardPrice as -- discardPrices (Mixed as) = Mixed $ map discardPrice as
sumAmountsUsingFirstPrice [] = nullamt sumAmountsUsingFirstPrice [] = nullamt
sumAmountsUsingFirstPrice as = (sum as){price=price $ head as} sumAmountsUsingFirstPrice as = (sum as){aprice=aprice $ head as}
-- | Get a mixed amount's component amounts. -- | Get a mixed amount's component amounts.
amounts :: MixedAmount -> [Amount] amounts :: MixedAmount -> [Amount]
@ -396,12 +430,6 @@ isReallyZeroMixedAmount = all isReallyZeroAmount . amounts . normaliseMixedAmoun
isReallyZeroMixedAmountCost :: MixedAmount -> Bool isReallyZeroMixedAmountCost :: MixedAmount -> Bool
isReallyZeroMixedAmountCost = isReallyZeroMixedAmount . costOfMixedAmount isReallyZeroMixedAmountCost = isReallyZeroMixedAmount . costOfMixedAmount
-- -- | Convert a mixed amount to the specified commodity, assuming an exchange rate of 1.
mixedAmountWithCommodity :: Commodity -> MixedAmount -> Amount
mixedAmountWithCommodity c (Mixed as) = Amount c total Nothing
where
total = sum $ map (quantity . amountWithCommodity c) as
-- -- | MixedAmount derived Eq instance in Types.hs doesn't know that we -- -- | MixedAmount derived Eq instance in Types.hs doesn't know that we
-- -- want $0 = EUR0 = 0. Yet we don't want to drag all this code over there. -- -- want $0 = EUR0 = 0. Yet we don't want to drag all this code over there.
-- -- For now, use this when cross-commodity zero equality is important. -- -- For now, use this when cross-commodity zero equality is important.
@ -443,14 +471,30 @@ showMixedAmountWithoutPrice :: MixedAmount -> String
showMixedAmountWithoutPrice m = concat $ intersperse "\n" $ map showfixedwidth as showMixedAmountWithoutPrice m = concat $ intersperse "\n" $ map showfixedwidth as
where where
(Mixed as) = normaliseMixedAmountPreservingFirstPrice $ stripPrices m (Mixed as) = normaliseMixedAmountPreservingFirstPrice $ stripPrices m
stripPrices (Mixed as) = Mixed $ map stripprice as where stripprice a = a{price=Nothing} stripPrices (Mixed as) = Mixed $ map stripprice as where stripprice a = a{aprice=Nothing}
width = maximum $ map (length . showAmount) as width = maximum $ map (length . showAmount) as
showfixedwidth = printf (printf "%%%ds" width) . showAmountWithoutPrice showfixedwidth = printf (printf "%%%ds" width) . showAmountWithoutPrice
-- | Replace a mixed amount's commodity with the canonicalised version from -- | Canonicalise a mixed amount's display styles using the provided commodity style map.
-- the provided commodity map. canonicaliseMixedAmount :: M.Map Commodity AmountStyle -> MixedAmount -> MixedAmount
canonicaliseMixedAmountCommodity :: Maybe (Map.Map String Commodity) -> MixedAmount -> MixedAmount canonicaliseMixedAmount styles (Mixed as) = Mixed $ map (canonicaliseAmount styles) as
canonicaliseMixedAmountCommodity canonicalcommoditymap (Mixed as) = Mixed $ map (canonicaliseAmountCommodity canonicalcommoditymap) as
-- | Given a list of amounts in parse order, build a map from commodities
-- to canonical display styles for amounts in that commodity.
canonicalStyles :: [Amount] -> M.Map Commodity AmountStyle
canonicalStyles amts = M.fromList commstyles
where
samecomm = \a1 a2 -> acommodity a1 == acommodity a2
commamts = [(acommodity $ head as, as) | as <- groupBy samecomm $ sortBy (comparing acommodity) amts]
commstyles = [(c, s)
| (c,as) <- commamts
, let styles = map astyle as
, let maxprec = maximum $ map asprecision styles
, let s = (head styles){asprecision=maxprec}
]
-- lookupStyle :: M.Map Commodity AmountStyle -> Commodity -> AmountStyle
-- lookupStyle
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- misc -- misc
@ -463,77 +507,78 @@ tests_Hledger_Data_Amount = TestList $
-- Amount -- Amount
"costOfAmount" ~: do "costOfAmount" ~: do
costOfAmount (euros 1) `is` euros 1 costOfAmount (eur 1) `is` eur 1
costOfAmount (euros 2){price=Just $ UnitPrice $ Mixed [dollars 2]} `is` dollars 4 costOfAmount (eur 2){aprice=Just $ UnitPrice $ Mixed [usd 2]} `is` usd 4
costOfAmount (euros 1){price=Just $ TotalPrice $ Mixed [dollars 2]} `is` dollars 2 costOfAmount (eur 1){aprice=Just $ TotalPrice $ Mixed [usd 2]} `is` usd 2
costOfAmount (euros (-1)){price=Just $ TotalPrice $ Mixed [dollars 2]} `is` dollars (-2) costOfAmount (eur (-1)){aprice=Just $ TotalPrice $ Mixed [usd 2]} `is` usd (-2)
,"isZeroAmount" ~: do ,"isZeroAmount" ~: do
assertBool "" $ isZeroAmount $ Amount unknown 0 Nothing assertBool "" $ isZeroAmount $ amount
assertBool "" $ isZeroAmount $ dollars 0 assertBool "" $ isZeroAmount $ usd 0
,"negating amounts" ~: do ,"negating amounts" ~: do
let a = dollars 1 let a = usd 1
negate a `is` a{quantity=(-1)} negate a `is` a{aquantity=(-1)}
let b = (dollars 1){price=Just $ UnitPrice $ Mixed [euros 2]} let b = (usd 1){aprice=Just $ UnitPrice $ Mixed [eur 2]}
negate b `is` b{quantity=(-1)} negate b `is` b{aquantity=(-1)}
,"adding amounts without prices" ~: do ,"adding amounts without prices" ~: do
let a1 = dollars 1.23 let a1 = usd 1.23
let a2 = dollars (-1.23) let a2 = usd (-1.23)
let a3 = dollars (-1.23) let a3 = usd (-1.23)
(a1 + a2) `is` Amount (comm "$") 0 Nothing (a1 + a2) `is` usd 0
(a1 + a3) `is` Amount (comm "$") 0 Nothing (a1 + a3) `is` usd 0
(a2 + a3) `is` Amount (comm "$") (-2.46) Nothing (a2 + a3) `is` usd (-2.46)
(a3 + a3) `is` Amount (comm "$") (-2.46) Nothing (a3 + a3) `is` usd (-2.46)
sum [a1,a2,a3,-a3] `is` Amount (comm "$") 0 Nothing sum [a1,a2,a3,-a3] `is` usd 0
-- highest precision is preserved -- highest precision is preserved
let ap1 = (dollars 1){commodity=dollar{precision=1}} let ap1 = setAmountPrecision 1 $ usd 1
ap3 = (dollars 1){commodity=dollar{precision=3}} ap3 = setAmountPrecision 3 $ usd 1
(sum [ap1,ap3]) `is` ap3{quantity=2} (asprecision $ astyle $ sum [ap1,ap3]) `is` 3
(sum [ap3,ap1]) `is` ap3{quantity=2} (asprecision $ astyle $ sum [ap3,ap1]) `is` 3
-- adding different commodities assumes conversion rate 1 -- adding different commodities assumes conversion rate 1
assertBool "" $ isZeroAmount (a1 - euros 1.23) assertBool "" $ isZeroAmount (a1 - eur 1.23)
,"showAmount" ~: do ,"showAmount" ~: do
showAmount (dollars 0 + pounds 0) `is` "0" showAmount (usd 0 + gbp 0) `is` "0"
-- MixedAmount -- MixedAmount
,"normaliseMixedAmountPreservingFirstPrice" ~: do ,"normaliseMixedAmountPreservingFirstPrice" ~: do
normaliseMixedAmountPreservingFirstPrice (Mixed []) `is` Mixed [nullamt] normaliseMixedAmountPreservingFirstPrice (Mixed []) `is` Mixed [nullamt]
assertBool "" $ isZeroMixedAmount $ normaliseMixedAmountPreservingFirstPrice (Mixed [Amount {commodity=dollar, quantity=10, price=Nothing} assertBool "" $ isZeroMixedAmount $ normaliseMixedAmountPreservingFirstPrice
,Amount {commodity=dollar, quantity=10, price=Just (TotalPrice (Mixed [Amount {commodity=euro, quantity=7, price=Nothing}]))} (Mixed [usd 10
,Amount {commodity=dollar, quantity=(-10), price=Nothing} ,usd 10 @@ eur 7
,Amount {commodity=dollar, quantity=(-10), price=Just (TotalPrice (Mixed [Amount {commodity=euro, quantity=7, price=Nothing}]))} ,usd (-10)
,usd (-10) @@ eur 7
]) ])
,"adding mixed amounts" ~: do ,"adding mixed amounts" ~: do
let dollar0 = dollar{precision=0}
(sum $ map (Mixed . (\a -> [a])) (sum $ map (Mixed . (\a -> [a]))
[Amount dollar 1.25 Nothing, [usd 1.25
Amount dollar0 (-1) Nothing, ,setAmountPrecision 0 $ usd (-1)
Amount dollar (-0.25) Nothing]) ,usd (-0.25)
`is` Mixed [Amount unknown 0 Nothing] ])
`is` Mixed [amount{aquantity=0}]
,"adding mixed amounts with total prices" ~: do ,"adding mixed amounts with total prices" ~: do
(sum $ map (Mixed . (\a -> [a])) (sum $ map (Mixed . (\a -> [a]))
[Amount dollar 1 (Just $ TotalPrice $ Mixed [euros 1]) [usd 1 @@ eur 1
,Amount dollar (-2) (Just $ TotalPrice $ Mixed [euros 1]) ,usd (-2) @@ eur 1
]) ])
`is` (Mixed [Amount dollar 1 (Just $ TotalPrice $ Mixed [euros 1]) `is` (Mixed [usd 1 @@ eur 1
,Amount dollar (-2) (Just $ TotalPrice $ Mixed [euros 1]) ,usd (-2) @@ eur 1
]) ])
,"showMixedAmount" ~: do ,"showMixedAmount" ~: do
showMixedAmount (Mixed [dollars 1]) `is` "$1.00" showMixedAmount (Mixed [usd 1]) `is` "$1.00"
showMixedAmount (Mixed [(dollars 1){price=Just $ UnitPrice $ Mixed [euros 2]}]) `is` "$1.00 @ €2.00" showMixedAmount (Mixed [usd 1 `at` eur 2]) `is` "$1.00 @ €2.00"
showMixedAmount (Mixed [dollars 0]) `is` "0" showMixedAmount (Mixed [usd 0]) `is` "0"
showMixedAmount (Mixed []) `is` "0" showMixedAmount (Mixed []) `is` "0"
showMixedAmount missingmixedamt `is` "" showMixedAmount missingmixedamt `is` ""
,"showMixedAmountWithoutPrice" ~: do ,"showMixedAmountWithoutPrice" ~: do
let a = (dollars 1){price=Just $ UnitPrice $ Mixed [euros 2]} let a = usd 1 `at` eur 2
showMixedAmountWithoutPrice (Mixed [a]) `is` "$1.00" showMixedAmountWithoutPrice (Mixed [a]) `is` "$1.00"
showMixedAmountWithoutPrice (Mixed [a, (-a)]) `is` "0" showMixedAmountWithoutPrice (Mixed [a, (-a)]) `is` "0"

64
hledger-lib/Hledger/Data/Commodity.hs
View File

@ -9,10 +9,9 @@ are thousands separated by comma, significant decimal places and so on.
module Hledger.Data.Commodity module Hledger.Data.Commodity
where where
import Data.List import Data.List
import Data.Map ((!)) import Data.Maybe (fromMaybe)
import Data.Maybe
import Test.HUnit import Test.HUnit
import qualified Data.Map as Map -- import qualified Data.Map as M
import Hledger.Data.Types import Hledger.Data.Types
import Hledger.Utils import Hledger.Utils
@ -24,44 +23,47 @@ nonsimplecommoditychars = "0123456789-.@;\n \"{}" :: String
quoteCommoditySymbolIfNeeded s | any (`elem` nonsimplecommoditychars) s = "\"" ++ s ++ "\"" quoteCommoditySymbolIfNeeded s | any (`elem` nonsimplecommoditychars) s = "\"" ++ s ++ "\""
| otherwise = s | otherwise = s
-- convenient amount and commodity constructors, for tests etc. commodity = ""
unknown = Commodity {symbol="", side=L,spaced=False,decimalpoint='.',precision=0,separator=',',separatorpositions=[]} -- handy constructors for tests
dollar = Commodity {symbol="$",side=L,spaced=False,decimalpoint='.',precision=2,separator=',',separatorpositions=[]} -- unknown = commodity
euro = Commodity {symbol="€",side=L,spaced=False,decimalpoint='.',precision=2,separator=',',separatorpositions=[]} -- usd = "$"
pound = Commodity {symbol="£",side=L,spaced=False,decimalpoint='.',precision=2,separator=',',separatorpositions=[]} -- eur = "€"
hour = Commodity {symbol="h",side=R,spaced=False,decimalpoint='.',precision=1,separator=',',separatorpositions=[]} -- gbp = "£"
-- hour = "h"
dollars n = Amount dollar n Nothing -- Some sample commodity' names and symbols, for use in tests..
euros n = Amount euro n Nothing commoditysymbols =
pounds n = Amount pound n Nothing [("unknown","")
hours n = Amount hour n Nothing ,("usd","$")
,("eur","€")
,("gbp","£")
,("hour","h")
]
defaultcommodities = [dollar, euro, pound, hour, unknown] -- | Look up one of the sample commodities' symbol by name.
-- | Look up one of the hard-coded default commodities. For use in tests.
comm :: String -> Commodity comm :: String -> Commodity
comm sym = fromMaybe comm name = snd $ fromMaybe
(error' "commodity lookup failed") (error' "commodity lookup failed")
$ find (\(Commodity{symbol=s}) -> s==sym) defaultcommodities (find (\n -> fst n == name) commoditysymbols)
-- | Find the conversion rate between two commodities. Currently returns 1. -- | Find the conversion rate between two commodities. Currently returns 1.
conversionRate :: Commodity -> Commodity -> Double conversionRate :: Commodity -> Commodity -> Double
conversionRate _ _ = 1 conversionRate _ _ = 1
-- | Convert a list of commodities to a map from commodity symbols to -- -- | Convert a list of commodities to a map from commodity symbols to
-- unique, display-preference-canonicalised commodities. -- -- unique, display-preference-canonicalised commodities.
canonicaliseCommodities :: [Commodity] -> Map.Map String Commodity -- canonicaliseCommodities :: [Commodity] -> Map.Map String Commodity
canonicaliseCommodities cs = -- canonicaliseCommodities cs =
Map.fromList [(s,firstc{precision=maxp}) | s <- symbols, -- Map.fromList [(s,firstc{precision=maxp}) | s <- symbols,
let cs = commoditymap ! s, -- let cs = commoditymap ! s,
let firstc = head cs, -- let firstc = head cs,
let maxp = maximum $ map precision cs -- let maxp = maximum $ map precision cs
] -- ]
where -- where
commoditymap = Map.fromList [(s, commoditieswithsymbol s) | s <- symbols] -- commoditymap = Map.fromList [(s, commoditieswithsymbol s) | s <- symbols]
commoditieswithsymbol s = filter ((s==) . symbol) cs -- commoditieswithsymbol s = filter ((s==) . symbol) cs
symbols = nub $ map symbol cs -- symbols = nub $ map symbol cs
tests_Hledger_Data_Commodity = TestList [ tests_Hledger_Data_Commodity = TestList [
] ]

108
hledger-lib/Hledger/Data/Journal.hs
View File

@ -25,9 +25,9 @@ module Hledger.Data.Journal (
-- * Querying -- * Querying
journalAccountNames, journalAccountNames,
journalAccountNamesUsed, journalAccountNamesUsed,
journalAmountAndPriceCommodities, -- journalAmountAndPriceCommodities,
journalAmounts, journalAmounts,
journalCanonicalCommodities, -- journalCanonicalCommodities,
journalDateSpan, journalDateSpan,
journalFilePath, journalFilePath,
journalFilePaths, journalFilePaths,
@ -51,7 +51,7 @@ module Hledger.Data.Journal (
) )
where where
import Data.List import Data.List
import Data.Map (findWithDefault) -- import Data.Map (findWithDefault)
import Data.Ord import Data.Ord
import Data.Time.Calendar import Data.Time.Calendar
import Data.Time.LocalTime import Data.Time.LocalTime
@ -60,13 +60,13 @@ import Safe (headDef)
import System.Time (ClockTime(TOD)) import System.Time (ClockTime(TOD))
import Test.HUnit import Test.HUnit
import Text.Printf import Text.Printf
import qualified Data.Map as Map import qualified Data.Map as M
import Hledger.Utils import Hledger.Utils
import Hledger.Data.Types import Hledger.Data.Types
import Hledger.Data.AccountName import Hledger.Data.AccountName
import Hledger.Data.Amount import Hledger.Data.Amount
import Hledger.Data.Commodity -- import Hledger.Data.Commodity
import Hledger.Data.Dates import Hledger.Data.Dates
import Hledger.Data.Transaction import Hledger.Data.Transaction
import Hledger.Data.Posting import Hledger.Data.Posting
@ -75,13 +75,14 @@ import Hledger.Query
instance Show Journal where instance Show Journal where
show j = printf "Journal %s with %d transactions, %d accounts: %s" show j = printf "Journal %s with %d transactions, %d accounts: %s, commodity styles: %s"
(journalFilePath j) (journalFilePath j)
(length (jtxns j) + (length (jtxns j) +
length (jmodifiertxns j) + length (jmodifiertxns j) +
length (jperiodictxns j)) length (jperiodictxns j))
(length accounts) (length accounts)
(show accounts) (show accounts)
(show $ jcommoditystyles j)
-- ++ (show $ journalTransactions l) -- ++ (show $ journalTransactions l)
where accounts = flatten $ journalAccountNameTree j where accounts = flatten $ journalAccountNameTree j
@ -107,10 +108,11 @@ nulljournal = Journal { jmodifiertxns = []
, jContext = nullctx , jContext = nullctx
, files = [] , files = []
, filereadtime = TOD 0 0 , filereadtime = TOD 0 0
, jcommoditystyles = M.fromList []
} }
nullctx :: JournalContext nullctx :: JournalContext
nullctx = Ctx { ctxYear = Nothing, ctxCommodity = Nothing, ctxAccount = [], ctxAliases = [] } nullctx = Ctx { ctxYear = Nothing, ctxCommodityAndStyle = Nothing, ctxAccount = [], ctxAliases = [] }
journalFilePath :: Journal -> FilePath journalFilePath :: Journal -> FilePath
journalFilePath = fst . mainfile journalFilePath = fst . mainfile
@ -369,24 +371,28 @@ journalFinalise tclock tlocal path txt ctx j@Journal{files=fs} =
-- amounts and working out the canonical commodities, since balancing -- amounts and working out the canonical commodities, since balancing
-- depends on display precision. Reports only the first error encountered. -- depends on display precision. Reports only the first error encountered.
journalBalanceTransactions :: Journal -> Either String Journal journalBalanceTransactions :: Journal -> Either String Journal
journalBalanceTransactions j@Journal{jtxns=ts} = journalBalanceTransactions j@Journal{jtxns=ts, jcommoditystyles=ss} =
case sequence $ map balance ts of Right ts' -> Right j{jtxns=ts'} case sequence $ map balance ts of Right ts' -> Right j{jtxns=ts'}
Left e -> Left e Left e -> Left e
where balance = balanceTransaction (Just $ journalCanonicalCommodities j) where balance = balanceTransaction (Just ss)
-- | Convert all the journal's posting amounts (not price amounts) to -- | Convert all the journal's posting amounts (not price amounts) to
-- their canonical display settings. Ie, all amounts in a given -- their canonical display settings. Ie, all amounts in a given
-- commodity will use (a) the display settings of the first, and (b) -- commodity will use (a) the display settings of the first, and (b)
-- the greatest precision, of the posting amounts in that commodity. -- the greatest precision, of the posting amounts in that commodity.
journalCanonicaliseAmounts :: Journal -> Journal journalCanonicaliseAmounts :: Journal -> Journal
journalCanonicaliseAmounts j@Journal{jtxns=ts} = j{jtxns=map fixtransaction ts} journalCanonicaliseAmounts j@Journal{jtxns=ts} = j''
where where
j'' = j'{jtxns=map fixtransaction ts}
j' = j{jcommoditystyles = canonicalStyles $ journalAmounts j}
fixtransaction t@Transaction{tpostings=ps} = t{tpostings=map fixposting ps} fixtransaction t@Transaction{tpostings=ps} = t{tpostings=map fixposting ps}
fixposting p@Posting{pamount=a} = p{pamount=fixmixedamount a} fixposting p@Posting{pamount=a} = p{pamount=fixmixedamount a}
fixmixedamount (Mixed as) = Mixed $ map fixamount as fixmixedamount (Mixed as) = Mixed $ map fixamount as
fixamount a@Amount{commodity=c} = a{commodity=fixcommodity c} fixamount a@Amount{acommodity=c} = a{astyle=journalCommodityStyle j' c}
fixcommodity c@Commodity{symbol=s} = findWithDefault c s canonicalcommoditymap
canonicalcommoditymap = journalCanonicalCommodities j -- | Get this journal's canonical amount style for the given commodity, or the null style.
journalCommodityStyle :: Journal -> Commodity -> AmountStyle
journalCommodityStyle j c = M.findWithDefault amountstyle c $ jcommoditystyles j
-- -- | Apply this journal's historical price records to unpriced amounts where possible. -- -- | Apply this journal's historical price records to unpriced amounts where possible.
-- journalApplyHistoricalPrices :: Journal -> Journal -- journalApplyHistoricalPrices :: Journal -> Journal
@ -421,30 +427,34 @@ journalConvertAmountsToCost j@Journal{jtxns=ts} = j{jtxns=map fixtransaction ts}
fixtransaction t@Transaction{tpostings=ps} = t{tpostings=map fixposting ps} fixtransaction t@Transaction{tpostings=ps} = t{tpostings=map fixposting ps}
fixposting p@Posting{pamount=a} = p{pamount=fixmixedamount a} fixposting p@Posting{pamount=a} = p{pamount=fixmixedamount a}
fixmixedamount (Mixed as) = Mixed $ map fixamount as fixmixedamount (Mixed as) = Mixed $ map fixamount as
fixamount = canonicaliseAmountCommodity (Just $ journalCanonicalCommodities j) . costOfAmount fixamount = canonicaliseAmount (jcommoditystyles j) . costOfAmount
-- | Get this journal's unique, display-preference-canonicalised commodities, by symbol. -- -- | Get this journal's unique, display-preference-canonicalised commodities, by symbol.
journalCanonicalCommodities :: Journal -> Map.Map String Commodity -- journalCanonicalCommodities :: Journal -> M.Map String Commodity
journalCanonicalCommodities j = canonicaliseCommodities $ journalAmountCommodities j -- journalCanonicalCommodities j = canonicaliseCommodities $ journalAmountCommodities j
-- | Get all this journal's amounts' commodities, in the order parsed. -- -- | Get all this journal's amounts' commodities, in the order parsed.
journalAmountCommodities :: Journal -> [Commodity] -- journalAmountCommodities :: Journal -> [Commodity]
journalAmountCommodities = map commodity . concatMap amounts . journalAmounts -- journalAmountCommodities = map acommodity . concatMap amounts . journalAmounts
-- | Get all this journal's amount and price commodities, in the order parsed. -- -- | Get all this journal's amount and price commodities, in the order parsed.
journalAmountAndPriceCommodities :: Journal -> [Commodity] -- journalAmountAndPriceCommodities :: Journal -> [Commodity]
journalAmountAndPriceCommodities = concatMap amountCommodities . concatMap amounts . journalAmounts -- journalAmountAndPriceCommodities = concatMap amountCommodities . concatMap amounts . journalAmounts
-- | Get this amount's commodity and any commodities referenced in its price. -- -- | Get this amount's commodity and any commodities referenced in its price.
amountCommodities :: Amount -> [Commodity] -- amountCommodities :: Amount -> [Commodity]
amountCommodities Amount{commodity=c,price=p} = -- amountCommodities Amount{acommodity=c,aprice=p} =
case p of Nothing -> [c] -- case p of Nothing -> [c]
Just (UnitPrice ma) -> c:(concatMap amountCommodities $ amounts ma) -- Just (UnitPrice ma) -> c:(concatMap amountCommodities $ amounts ma)
Just (TotalPrice ma) -> c:(concatMap amountCommodities $ amounts ma) -- Just (TotalPrice ma) -> c:(concatMap amountCommodities $ amounts ma)
-- | Get all this journal's amounts, in the order parsed. -- | Get all this journal's (mixed) amounts, in the order parsed.
journalAmounts :: Journal -> [MixedAmount] journalMixedAmounts :: Journal -> [MixedAmount]
journalAmounts = map pamount . journalPostings journalMixedAmounts = map pamount . journalPostings
-- | Get all this journal's component amounts, roughly in the order parsed.
journalAmounts :: Journal -> [Amount]
journalAmounts = concatMap flatten . journalMixedAmounts where flatten (Mixed as) = as
-- | The (fully specified) date span containing this journal's transactions, -- | The (fully specified) date span containing this journal's transactions,
-- or DateSpan Nothing Nothing if there are none. -- or DateSpan Nothing Nothing if there are none.
@ -475,8 +485,8 @@ isnegativepat = (negateprefix `isPrefixOf`)
abspat pat = if isnegativepat pat then drop (length negateprefix) pat else pat abspat pat = if isnegativepat pat then drop (length negateprefix) pat else pat
-- debug helpers -- debug helpers
-- traceAmountPrecision a = trace (show $ map (precision . commodity) $ amounts a) a -- traceAmountPrecision a = trace (show $ map (precision . acommodity) $ amounts a) a
-- tracePostingsCommodities ps = trace (show $ map ((map (precision . commodity) . amounts) . pamount) ps) ps -- tracePostingsCommodities ps = trace (show $ map ((map (precision . acommodity) . amounts) . pamount) ps) ps
-- tests -- tests
@ -503,10 +513,9 @@ abspat pat = if isnegativepat pat then drop (length negateprefix) pat else pat
-- liabilities:debts $1 -- liabilities:debts $1
-- assets:bank:checking -- assets:bank:checking
-- --
Right samplejournal = journalBalanceTransactions $ Journal Right samplejournal = journalBalanceTransactions $
[] nulljournal
[] {jtxns = [
[
txnTieKnot $ Transaction { txnTieKnot $ Transaction {
tdate=parsedate "2008/01/01", tdate=parsedate "2008/01/01",
teffectivedate=Nothing, teffectivedate=Nothing,
@ -519,7 +528,7 @@ Right samplejournal = journalBalanceTransactions $ Journal
Posting { Posting {
pstatus=False, pstatus=False,
paccount="assets:bank:checking", paccount="assets:bank:checking",
pamount=(Mixed [dollars 1]), pamount=(Mixed [usd 1]),
pcomment="", pcomment="",
ptype=RegularPosting, ptype=RegularPosting,
ptags=[], ptags=[],
@ -550,7 +559,7 @@ Right samplejournal = journalBalanceTransactions $ Journal
Posting { Posting {
pstatus=False, pstatus=False,
paccount="assets:bank:checking", paccount="assets:bank:checking",
pamount=(Mixed [dollars 1]), pamount=(Mixed [usd 1]),
pcomment="", pcomment="",
ptype=RegularPosting, ptype=RegularPosting,
ptags=[], ptags=[],
@ -581,7 +590,7 @@ Right samplejournal = journalBalanceTransactions $ Journal
Posting { Posting {
pstatus=False, pstatus=False,
paccount="assets:bank:saving", paccount="assets:bank:saving",
pamount=(Mixed [dollars 1]), pamount=(Mixed [usd 1]),
pcomment="", pcomment="",
ptype=RegularPosting, ptype=RegularPosting,
ptags=[], ptags=[],
@ -590,7 +599,7 @@ Right samplejournal = journalBalanceTransactions $ Journal
Posting { Posting {
pstatus=False, pstatus=False,
paccount="assets:bank:checking", paccount="assets:bank:checking",
pamount=(Mixed [dollars (-1)]), pamount=(Mixed [usd (-1)]),
pcomment="", pcomment="",
ptype=RegularPosting, ptype=RegularPosting,
ptags=[], ptags=[],
@ -612,7 +621,7 @@ Right samplejournal = journalBalanceTransactions $ Journal
Posting { Posting {
pstatus=False, pstatus=False,
paccount="expenses:food", paccount="expenses:food",
pamount=(Mixed [dollars 1]), pamount=(Mixed [usd 1]),
pcomment="", pcomment="",
ptype=RegularPosting, ptype=RegularPosting,
ptags=[], ptags=[],
@ -621,7 +630,7 @@ Right samplejournal = journalBalanceTransactions $ Journal
Posting { Posting {
pstatus=False, pstatus=False,
paccount="expenses:supplies", paccount="expenses:supplies",
pamount=(Mixed [dollars 1]), pamount=(Mixed [usd 1]),
pcomment="", pcomment="",
ptype=RegularPosting, ptype=RegularPosting,
ptags=[], ptags=[],
@ -652,7 +661,7 @@ Right samplejournal = journalBalanceTransactions $ Journal
Posting { Posting {
pstatus=False, pstatus=False,
paccount="liabilities:debts", paccount="liabilities:debts",
pamount=(Mixed [dollars 1]), pamount=(Mixed [usd 1]),
pcomment="", pcomment="",
ptype=RegularPosting, ptype=RegularPosting,
ptags=[], ptags=[],
@ -661,7 +670,7 @@ Right samplejournal = journalBalanceTransactions $ Journal
Posting { Posting {
pstatus=False, pstatus=False,
paccount="assets:bank:checking", paccount="assets:bank:checking",
pamount=(Mixed [dollars (-1)]), pamount=(Mixed [usd (-1)]),
pcomment="", pcomment="",
ptype=RegularPosting, ptype=RegularPosting,
ptags=[], ptags=[],
@ -671,12 +680,7 @@ Right samplejournal = journalBalanceTransactions $ Journal
tpreceding_comment_lines="" tpreceding_comment_lines=""
} }
] ]
[] }
[]
""
nullctx
[]
(TOD 0 0)
tests_Hledger_Data_Journal = TestList $ tests_Hledger_Data_Journal = TestList $
[ [

6
hledger-lib/Hledger/Data/Ledger.hs
View File

@ -82,9 +82,9 @@ ledgerPostings = journalPostings . ljournal
ledgerDateSpan :: Ledger -> DateSpan ledgerDateSpan :: Ledger -> DateSpan
ledgerDateSpan = postingsDateSpan . ledgerPostings ledgerDateSpan = postingsDateSpan . ledgerPostings
-- | All commodities used in this ledger, as a map keyed by symbol. -- | All commodities used in this ledger.
ledgerCommodities :: Ledger -> M.Map String Commodity ledgerCommodities :: Ledger -> [Commodity]
ledgerCommodities = journalCanonicalCommodities . ljournal ledgerCommodities = M.keys . jcommoditystyles . ljournal
tests_ledgerFromJournal = [ tests_ledgerFromJournal = [

6
hledger-lib/Hledger/Data/TimeLog.hs
View File

@ -20,7 +20,7 @@ import Text.Printf
import Hledger.Utils import Hledger.Utils
import Hledger.Data.Types import Hledger.Data.Types
import Hledger.Data.Dates import Hledger.Data.Dates
import Hledger.Data.Commodity import Hledger.Data.Amount
import Hledger.Data.Transaction import Hledger.Data.Transaction
instance Show TimeLogEntry where instance Show TimeLogEntry where
@ -92,8 +92,8 @@ entryFromTimeLogInOut i o
itod = localTimeOfDay itime itod = localTimeOfDay itime
otod = localTimeOfDay otime otod = localTimeOfDay otime
idate = localDay itime idate = localDay itime
hrs = elapsedSeconds (toutc otime) (toutc itime) / 3600 where toutc = localTimeToUTC utc hours = elapsedSeconds (toutc otime) (toutc itime) / 3600 where toutc = localTimeToUTC utc
amount = Mixed [hours hrs] amount = Mixed [hrs hours]
ps = [Posting{pstatus=False,paccount=acctname,pamount=amount, ps = [Posting{pstatus=False,paccount=acctname,pamount=amount,
pcomment="",ptype=VirtualPosting,ptags=[],ptransaction=Just t}] pcomment="",ptype=VirtualPosting,ptags=[],ptransaction=Just t}]

130
hledger-lib/Hledger/Data/Transaction.hs
View File

@ -47,7 +47,6 @@ import Hledger.Data.Types
import Hledger.Data.Dates import Hledger.Data.Dates
import Hledger.Data.Posting import Hledger.Data.Posting
import Hledger.Data.Amount import Hledger.Data.Amount
import Hledger.Data.Commodity
instance Show Transaction where show = showTransactionUnelided instance Show Transaction where show = showTransactionUnelided
@ -108,7 +107,7 @@ tests_showTransactionUnelided = [
nullposting{ nullposting{
pstatus=True, pstatus=True,
paccount="a", paccount="a",
pamount=Mixed [dollars 1, hours 2], pamount=Mixed [usd 1, hrs 2],
pcomment="pcomment1\npcomment2\n", pcomment="pcomment1\npcomment2\n",
ptype=RegularPosting, ptype=RegularPosting,
ptags=[("ptag1","val1"),("ptag2","val2")] ptags=[("ptag1","val1"),("ptag2","val2")]
@ -183,7 +182,7 @@ tests_postingAsLines = [
nullposting{ nullposting{
pstatus=True, pstatus=True,
paccount="a", paccount="a",
pamount=Mixed [dollars 1, hours 2], pamount=Mixed [usd 1, hrs 2],
pcomment="pcomment1\npcomment2\n", pcomment="pcomment1\npcomment2\n",
ptype=RegularPosting, ptype=RegularPosting,
ptags=[("ptag1","val1"),("ptag2","val2")] ptags=[("ptag1","val1"),("ptag2","val2")]
@ -236,14 +235,15 @@ transactionPostingBalances t = (sumPostings $ realPostings t
-- | Is this transaction balanced ? A balanced transaction's real -- | Is this transaction balanced ? A balanced transaction's real
-- (non-virtual) postings sum to 0, and any balanced virtual postings -- (non-virtual) postings sum to 0, and any balanced virtual postings
-- also sum to 0. -- also sum to 0.
isTransactionBalanced :: Maybe (Map.Map String Commodity) -> Transaction -> Bool isTransactionBalanced :: Maybe (Map.Map Commodity AmountStyle) -> Transaction -> Bool
isTransactionBalanced canonicalcommoditymap t = isTransactionBalanced styles t =
-- isReallyZeroMixedAmountCost rsum && isReallyZeroMixedAmountCost bvsum -- isReallyZeroMixedAmountCost rsum && isReallyZeroMixedAmountCost bvsum
isZeroMixedAmount rsum' && isZeroMixedAmount bvsum' isZeroMixedAmount rsum' && isZeroMixedAmount bvsum'
where where
(rsum, _, bvsum) = transactionPostingBalances t (rsum, _, bvsum) = transactionPostingBalances t
rsum' = canonicaliseMixedAmountCommodity canonicalcommoditymap $ costOfMixedAmount rsum rsum' = canonicalise $ costOfMixedAmount rsum
bvsum' = canonicaliseMixedAmountCommodity canonicalcommoditymap $ costOfMixedAmount bvsum bvsum' = canonicalise $ costOfMixedAmount bvsum
canonicalise = maybe id canonicaliseMixedAmount styles
-- | Ensure this transaction is balanced, possibly inferring a missing -- | Ensure this transaction is balanced, possibly inferring a missing
-- amount or conversion price, or return an error message. -- amount or conversion price, or return an error message.
@ -260,11 +260,11 @@ isTransactionBalanced canonicalcommoditymap t =
-- and the sum of real postings' amounts is exactly two -- and the sum of real postings' amounts is exactly two
-- non-explicitly-priced amounts in different commodities (likewise -- non-explicitly-priced amounts in different commodities (likewise
-- for balanced virtual postings). -- for balanced virtual postings).
balanceTransaction :: Maybe (Map.Map String Commodity) -> Transaction -> Either String Transaction balanceTransaction :: Maybe (Map.Map Commodity AmountStyle) -> Transaction -> Either String Transaction
balanceTransaction canonicalcommoditymap t@Transaction{tpostings=ps} balanceTransaction styles t@Transaction{tpostings=ps}
| length rwithoutamounts > 1 || length bvwithoutamounts > 1 | length rwithoutamounts > 1 || length bvwithoutamounts > 1
= Left $ printerr "could not balance this transaction (too many missing amounts)" = Left $ printerr "could not balance this transaction (too many missing amounts)"
| not $ isTransactionBalanced canonicalcommoditymap t''' = Left $ printerr $ nonzerobalanceerror t''' | not $ isTransactionBalanced styles t''' = Left $ printerr $ nonzerobalanceerror t'''
| otherwise = Right t''' | otherwise = Right t'''
where where
-- maybe infer missing amounts -- maybe infer missing amounts
@ -281,53 +281,53 @@ balanceTransaction canonicalcommoditymap t@Transaction{tpostings=ps}
-- maybe infer conversion prices, for real postings -- maybe infer conversion prices, for real postings
rmixedamountsinorder = map pamount $ realPostings t' rmixedamountsinorder = map pamount $ realPostings t'
ramountsinorder = concatMap amounts rmixedamountsinorder ramountsinorder = concatMap amounts rmixedamountsinorder
rcommoditiesinorder = map commodity ramountsinorder rcommoditiesinorder = map acommodity ramountsinorder
rsumamounts = amounts $ sum rmixedamountsinorder rsumamounts = amounts $ sum rmixedamountsinorder
-- assumption: the sum of mixed amounts is normalised (one simple amount per commodity) -- assumption: the sum of mixed amounts is normalised (one simple amount per commodity)
t'' = if length rsumamounts == 2 && all (isNothing.price) rsumamounts && t'==t t'' = if length rsumamounts == 2 && all (isNothing.aprice) rsumamounts && t'==t
then t'{tpostings=map inferprice ps} then t'{tpostings=map inferprice ps}
else t' else t'
where where
-- assumption: a posting's mixed amount contains one simple amount -- assumption: a posting's mixed amount contains one simple amount
inferprice p@Posting{pamount=Mixed [a@Amount{commodity=c,price=Nothing}], ptype=RegularPosting} inferprice p@Posting{pamount=Mixed [a@Amount{acommodity=c,aprice=Nothing}], ptype=RegularPosting}
= p{pamount=Mixed [a{price=conversionprice c}]} = p{pamount=Mixed [a{aprice=conversionprice c}]}
where where
conversionprice c | c == unpricedcommodity conversionprice c | c == unpricedcommodity
-- assign a balancing price. Use @@ for more exact output when possible. -- assign a balancing price. Use @@ for more exact output when possible.
-- invariant: prices should always be positive. Enforced with "abs" -- invariant: prices should always be positive. Enforced with "abs"
= if length ramountsinunpricedcommodity == 1 = if length ramountsinunpricedcommodity == 1
then Just $ TotalPrice $ Mixed [setAmountPrecision maxprecision $ abs $ targetcommodityamount] then Just $ TotalPrice $ Mixed [setAmountPrecision maxprecision $ abs $ targetcommodityamount]
else Just $ UnitPrice $ Mixed [setAmountPrecision maxprecision $ abs $ targetcommodityamount `divideAmount` (quantity unpricedamount)] else Just $ UnitPrice $ Mixed [setAmountPrecision maxprecision $ abs $ targetcommodityamount `divideAmount` (aquantity unpricedamount)]
| otherwise = Nothing | otherwise = Nothing
where where
unpricedcommodity = head $ filter (`elem` (map commodity rsumamounts)) rcommoditiesinorder unpricedcommodity = head $ filter (`elem` (map acommodity rsumamounts)) rcommoditiesinorder
unpricedamount = head $ filter ((==unpricedcommodity).commodity) rsumamounts unpricedamount = head $ filter ((==unpricedcommodity).acommodity) rsumamounts
targetcommodityamount = head $ filter ((/=unpricedcommodity).commodity) rsumamounts targetcommodityamount = head $ filter ((/=unpricedcommodity).acommodity) rsumamounts
ramountsinunpricedcommodity = filter ((==unpricedcommodity).commodity) ramountsinorder ramountsinunpricedcommodity = filter ((==unpricedcommodity).acommodity) ramountsinorder
inferprice p = p inferprice p = p
-- maybe infer prices for balanced virtual postings. Just duplicates the above for now. -- maybe infer prices for balanced virtual postings. Just duplicates the above for now.
bvmixedamountsinorder = map pamount $ balancedVirtualPostings t'' bvmixedamountsinorder = map pamount $ balancedVirtualPostings t''
bvamountsinorder = concatMap amounts bvmixedamountsinorder bvamountsinorder = concatMap amounts bvmixedamountsinorder
bvcommoditiesinorder = map commodity bvamountsinorder bvcommoditiesinorder = map acommodity bvamountsinorder
bvsumamounts = amounts $ sum bvmixedamountsinorder bvsumamounts = amounts $ sum bvmixedamountsinorder
t''' = if length bvsumamounts == 2 && all (isNothing.price) bvsumamounts && t'==t -- XXX could check specifically for bv amount inferring t''' = if length bvsumamounts == 2 && all (isNothing.aprice) bvsumamounts && t'==t -- XXX could check specifically for bv amount inferring
then t''{tpostings=map inferprice ps} then t''{tpostings=map inferprice ps}
else t'' else t''
where where
inferprice p@Posting{pamount=Mixed [a@Amount{commodity=c,price=Nothing}], ptype=BalancedVirtualPosting} inferprice p@Posting{pamount=Mixed [a@Amount{acommodity=c,aprice=Nothing}], ptype=BalancedVirtualPosting}
= p{pamount=Mixed [a{price=conversionprice c}]} = p{pamount=Mixed [a{aprice=conversionprice c}]}
where where
conversionprice c | c == unpricedcommodity conversionprice c | c == unpricedcommodity
= if length bvamountsinunpricedcommodity == 1 = if length bvamountsinunpricedcommodity == 1
then Just $ TotalPrice $ Mixed [setAmountPrecision maxprecision $ abs $ targetcommodityamount] then Just $ TotalPrice $ Mixed [setAmountPrecision maxprecision $ abs $ targetcommodityamount]
else Just $ UnitPrice $ Mixed [setAmountPrecision maxprecision $ abs $ targetcommodityamount `divideAmount` (quantity unpricedamount)] else Just $ UnitPrice $ Mixed [setAmountPrecision maxprecision $ abs $ targetcommodityamount `divideAmount` (aquantity unpricedamount)]
| otherwise = Nothing | otherwise = Nothing
where where
unpricedcommodity = head $ filter (`elem` (map commodity bvsumamounts)) bvcommoditiesinorder unpricedcommodity = head $ filter (`elem` (map acommodity bvsumamounts)) bvcommoditiesinorder
unpricedamount = head $ filter ((==unpricedcommodity).commodity) bvsumamounts unpricedamount = head $ filter ((==unpricedcommodity).acommodity) bvsumamounts
targetcommodityamount = head $ filter ((/=unpricedcommodity).commodity) bvsumamounts targetcommodityamount = head $ filter ((/=unpricedcommodity).acommodity) bvsumamounts
bvamountsinunpricedcommodity = filter ((==unpricedcommodity).commodity) bvamountsinorder bvamountsinunpricedcommodity = filter ((==unpricedcommodity).acommodity) bvamountsinorder
inferprice p = p inferprice p = p
printerr s = intercalate "\n" [s, showTransactionUnelided t] printerr s = intercalate "\n" [s, showTransactionUnelided t]
@ -376,8 +376,8 @@ tests_Hledger_Data_Transaction = TestList $ concat [
,"" ,""
]) ])
(let t = Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" [] (let t = Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" []
[Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting [] (Just t) [Posting False "expenses:food:groceries" (Mixed [usd 47.18]) "" RegularPosting [] (Just t)
,Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting [] (Just t) ,Posting False "assets:checking" (Mixed [usd (-47.18)]) "" RegularPosting [] (Just t)
] "" ] ""
in showTransaction t) in showTransaction t)
@ -390,8 +390,8 @@ tests_Hledger_Data_Transaction = TestList $ concat [
,"" ,""
]) ])
(let t = Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" [] (let t = Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" []
[Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting [] (Just t) [Posting False "expenses:food:groceries" (Mixed [usd 47.18]) "" RegularPosting [] (Just t)
,Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting [] (Just t) ,Posting False "assets:checking" (Mixed [usd (-47.18)]) "" RegularPosting [] (Just t)
] "" ] ""
in showTransactionUnelided t) in showTransactionUnelided t)
@ -406,8 +406,8 @@ tests_Hledger_Data_Transaction = TestList $ concat [
]) ])
(showTransaction (showTransaction
(txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" [] (txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" []
[Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting [] Nothing [Posting False "expenses:food:groceries" (Mixed [usd 47.18]) "" RegularPosting [] Nothing
,Posting False "assets:checking" (Mixed [dollars (-47.19)]) "" RegularPosting [] Nothing ,Posting False "assets:checking" (Mixed [usd (-47.19)]) "" RegularPosting [] Nothing
] "")) ] ""))
,"showTransaction" ~: do ,"showTransaction" ~: do
@ -419,7 +419,7 @@ tests_Hledger_Data_Transaction = TestList $ concat [
]) ])
(showTransaction (showTransaction
(txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" [] (txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" []
[Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting [] Nothing [Posting False "expenses:food:groceries" (Mixed [usd 47.18]) "" RegularPosting [] Nothing
] "")) ] ""))
,"showTransaction" ~: do ,"showTransaction" ~: do
@ -444,7 +444,7 @@ tests_Hledger_Data_Transaction = TestList $ concat [
]) ])
(showTransaction (showTransaction
(txnTieKnot $ Transaction (parsedate "2010/01/01") Nothing False "" "x" "" [] (txnTieKnot $ Transaction (parsedate "2010/01/01") Nothing False "" "x" "" []
[Posting False "a" (Mixed [Amount unknown 1 (Just $ UnitPrice $ Mixed [Amount dollar{precision=0} 2 Nothing])]) "" RegularPosting [] Nothing [Posting False "a" (Mixed [amt 1 `at` (setAmountPrecision 0 $ usd 2)]) "" RegularPosting [] Nothing
,Posting False "b" missingmixedamt "" RegularPosting [] Nothing ,Posting False "b" missingmixedamt "" RegularPosting [] Nothing
] "")) ] ""))
@ -452,8 +452,8 @@ tests_Hledger_Data_Transaction = TestList $ concat [
assertBool "detect unbalanced entry, sign error" assertBool "detect unbalanced entry, sign error"
(isLeft $ balanceTransaction Nothing (isLeft $ balanceTransaction Nothing
(Transaction (parsedate "2007/01/28") Nothing False "" "test" "" [] (Transaction (parsedate "2007/01/28") Nothing False "" "test" "" []
[Posting False "a" (Mixed [dollars 1]) "" RegularPosting [] Nothing, [Posting False "a" (Mixed [usd 1]) "" RegularPosting [] Nothing,
Posting False "b" (Mixed [dollars 1]) "" RegularPosting [] Nothing Posting False "b" (Mixed [usd 1]) "" RegularPosting [] Nothing
] "")) ] ""))
assertBool "detect unbalanced entry, multiple missing amounts" assertBool "detect unbalanced entry, multiple missing amounts"
@ -464,79 +464,75 @@ tests_Hledger_Data_Transaction = TestList $ concat [
] "")) ] ""))
let e = balanceTransaction Nothing (Transaction (parsedate "2007/01/28") Nothing False "" "" "" [] let e = balanceTransaction Nothing (Transaction (parsedate "2007/01/28") Nothing False "" "" "" []
[Posting False "a" (Mixed [dollars 1]) "" RegularPosting [] Nothing, [Posting False "a" (Mixed [usd 1]) "" RegularPosting [] Nothing,
Posting False "b" missingmixedamt "" RegularPosting [] Nothing Posting False "b" missingmixedamt "" RegularPosting [] Nothing
] "") ] "")
assertBool "balanceTransaction allows one missing amount" (isRight e) assertBool "balanceTransaction allows one missing amount" (isRight e)
assertEqual "balancing amount is inferred" assertEqual "balancing amount is inferred"
(Mixed [dollars (-1)]) (Mixed [usd (-1)])
(case e of (case e of
Right e' -> (pamount $ last $ tpostings e') Right e' -> (pamount $ last $ tpostings e')
Left _ -> error' "should not happen") Left _ -> error' "should not happen")
let e = balanceTransaction Nothing (Transaction (parsedate "2011/01/01") Nothing False "" "" "" [] let e = balanceTransaction Nothing (Transaction (parsedate "2011/01/01") Nothing False "" "" "" []
[Posting False "a" (Mixed [dollars 1.35]) "" RegularPosting [] Nothing, [Posting False "a" (Mixed [usd 1.35]) "" RegularPosting [] Nothing,
Posting False "b" (Mixed [euros (-1)]) "" RegularPosting [] Nothing Posting False "b" (Mixed [eur (-1)]) "" RegularPosting [] Nothing
] "") ] "")
assertBool "balanceTransaction can infer conversion price" (isRight e) assertBool "balanceTransaction can infer conversion price" (isRight e)
assertEqual "balancing conversion price is inferred" assertEqual "balancing conversion price is inferred"
(Mixed [Amount{commodity=dollar{precision=2}, (Mixed [usd 1.35 @@ (setAmountPrecision maxprecision $ eur 1)])
quantity=1.35,
price=(Just $ TotalPrice $ Mixed [Amount{commodity=euro{precision=maxprecision},
quantity=1,
price=Nothing}])}])
(case e of (case e of
Right e' -> (pamount $ head $ tpostings e') Right e' -> (pamount $ head $ tpostings e')
Left _ -> error' "should not happen") Left _ -> error' "should not happen")
assertBool "balanceTransaction balances based on cost if there are unit prices" (isRight $ assertBool "balanceTransaction balances based on cost if there are unit prices" (isRight $
balanceTransaction Nothing (Transaction (parsedate "2011/01/01") Nothing False "" "" "" [] balanceTransaction Nothing (Transaction (parsedate "2011/01/01") Nothing False "" "" "" []
[Posting False "a" (Mixed [Amount dollar 1 (Just $ UnitPrice $ Mixed [euros 2])]) "" RegularPosting [] Nothing [Posting False "a" (Mixed [usd 1 `at` eur 2]) "" RegularPosting [] Nothing
,Posting False "a" (Mixed [Amount dollar (-2) (Just $ UnitPrice $ Mixed [euros 1])]) "" RegularPosting [] Nothing ,Posting False "a" (Mixed [usd (-2) `at` eur 1]) "" RegularPosting [] Nothing
] "")) ] ""))
assertBool "balanceTransaction balances based on cost if there are total prices" (isRight $ assertBool "balanceTransaction balances based on cost if there are total prices" (isRight $
balanceTransaction Nothing (Transaction (parsedate "2011/01/01") Nothing False "" "" "" [] balanceTransaction Nothing (Transaction (parsedate "2011/01/01") Nothing False "" "" "" []
[Posting False "a" (Mixed [Amount dollar 1 (Just $ TotalPrice $ Mixed [euros 1])]) "" RegularPosting [] Nothing [Posting False "a" (Mixed [usd 1 @@ eur 1]) "" RegularPosting [] Nothing
,Posting False "a" (Mixed [Amount dollar (-2) (Just $ TotalPrice $ Mixed [euros 1])]) "" RegularPosting [] Nothing ,Posting False "a" (Mixed [usd (-2) @@ eur 1]) "" RegularPosting [] Nothing
] "")) ] ""))
,"isTransactionBalanced" ~: do ,"isTransactionBalanced" ~: do
let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" [] let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" []
[Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting [] (Just t) [Posting False "b" (Mixed [usd 1.00]) "" RegularPosting [] (Just t)
,Posting False "c" (Mixed [dollars (-1.00)]) "" RegularPosting [] (Just t) ,Posting False "c" (Mixed [usd (-1.00)]) "" RegularPosting [] (Just t)
] "" ] ""
assertBool "detect balanced" (isTransactionBalanced Nothing t) assertBool "detect balanced" (isTransactionBalanced Nothing t)
let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" [] let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" []
[Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting [] (Just t) [Posting False "b" (Mixed [usd 1.00]) "" RegularPosting [] (Just t)
,Posting False "c" (Mixed [dollars (-1.01)]) "" RegularPosting [] (Just t) ,Posting False "c" (Mixed [usd (-1.01)]) "" RegularPosting [] (Just t)
] "" ] ""
assertBool "detect unbalanced" (not $ isTransactionBalanced Nothing t) assertBool "detect unbalanced" (not $ isTransactionBalanced Nothing t)
let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" [] let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" []
[Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting [] (Just t) [Posting False "b" (Mixed [usd 1.00]) "" RegularPosting [] (Just t)
] "" ] ""
assertBool "detect unbalanced, one posting" (not $ isTransactionBalanced Nothing t) assertBool "detect unbalanced, one posting" (not $ isTransactionBalanced Nothing t)
let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" [] let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" []
[Posting False "b" (Mixed [dollars 0]) "" RegularPosting [] (Just t) [Posting False "b" (Mixed [usd 0]) "" RegularPosting [] (Just t)
] "" ] ""
assertBool "one zero posting is considered balanced for now" (isTransactionBalanced Nothing t) assertBool "one zero posting is considered balanced for now" (isTransactionBalanced Nothing t)
let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" [] let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" []
[Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting [] (Just t) [Posting False "b" (Mixed [usd 1.00]) "" RegularPosting [] (Just t)
,Posting False "c" (Mixed [dollars (-1.00)]) "" RegularPosting [] (Just t) ,Posting False "c" (Mixed [usd (-1.00)]) "" RegularPosting [] (Just t)
,Posting False "d" (Mixed [dollars 100]) "" VirtualPosting [] (Just t) ,Posting False "d" (Mixed [usd 100]) "" VirtualPosting [] (Just t)
] "" ] ""
assertBool "virtual postings don't need to balance" (isTransactionBalanced Nothing t) assertBool "virtual postings don't need to balance" (isTransactionBalanced Nothing t)
let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" [] let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" []
[Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting [] (Just t) [Posting False "b" (Mixed [usd 1.00]) "" RegularPosting [] (Just t)
,Posting False "c" (Mixed [dollars (-1.00)]) "" RegularPosting [] (Just t) ,Posting False "c" (Mixed [usd (-1.00)]) "" RegularPosting [] (Just t)
,Posting False "d" (Mixed [dollars 100]) "" BalancedVirtualPosting [] (Just t) ,Posting False "d" (Mixed [usd 100]) "" BalancedVirtualPosting [] (Just t)
] "" ] ""
assertBool "balanced virtual postings need to balance among themselves" (not $ isTransactionBalanced Nothing t) assertBool "balanced virtual postings need to balance among themselves" (not $ isTransactionBalanced Nothing t)
let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" [] let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" []
[Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting [] (Just t) [Posting False "b" (Mixed [usd 1.00]) "" RegularPosting [] (Just t)
,Posting False "c" (Mixed [dollars (-1.00)]) "" RegularPosting [] (Just t) ,Posting False "c" (Mixed [usd (-1.00)]) "" RegularPosting [] (Just t)
,Posting False "d" (Mixed [dollars 100]) "" BalancedVirtualPosting [] (Just t) ,Posting False "d" (Mixed [usd 100]) "" BalancedVirtualPosting [] (Just t)
,Posting False "e" (Mixed [dollars (-100)]) "" BalancedVirtualPosting [] (Just t) ,Posting False "e" (Mixed [usd (-100)]) "" BalancedVirtualPosting [] (Just t)
] "" ] ""
assertBool "balanced virtual postings need to balance among themselves (2)" (isTransactionBalanced Nothing t) assertBool "balanced virtual postings need to balance among themselves (2)" (isTransactionBalanced Nothing t)

38
hledger-lib/Hledger/Data/Types.hs
View File

@ -20,6 +20,7 @@ For more detailed documentation on each type, see the corresponding modules.
module Hledger.Data.Types module Hledger.Data.Types
where where
import Control.Monad.Error (ErrorT) import Control.Monad.Error (ErrorT)
import qualified Data.Map as M
import Data.Time.Calendar import Data.Time.Calendar
import Data.Time.LocalTime import Data.Time.LocalTime
import Data.Typeable import Data.Typeable
@ -42,17 +43,7 @@ type AccountName = String
data Side = L | R deriving (Eq,Show,Read,Ord) data Side = L | R deriving (Eq,Show,Read,Ord)
data Commodity = Commodity { type Commodity = String
symbol :: String, -- ^ the commodity's symbol
-- display preferences for amounts of this commodity
side :: Side, -- ^ should the symbol appear on the left or the right
spaced :: Bool, -- ^ should there be a space between symbol and quantity
precision :: Int, -- ^ number of decimal places to display
-- XXX these three might be better belonging to Journal
decimalpoint :: Char, -- ^ character to use as decimal point
separator :: Char, -- ^ character to use for separating digit groups (eg thousands)
separatorpositions :: [Int] -- ^ positions of separators, counting leftward from decimal point
} deriving (Eq,Ord,Show,Read)
type Quantity = Double type Quantity = Double
@ -60,13 +51,24 @@ type Quantity = Double
-- price or \@\@ total price. Note although a MixedAmount is used, it -- price or \@\@ total price. Note although a MixedAmount is used, it
-- should be in a single commodity, also the amount should be positive; -- should be in a single commodity, also the amount should be positive;
-- these are not enforced currently. -- these are not enforced currently.
data Price = UnitPrice MixedAmount | TotalPrice MixedAmount data Price = {- NoPrice | -} UnitPrice MixedAmount | TotalPrice MixedAmount
deriving (Eq,Ord) deriving (Eq,Ord)
-- | Display style for an amount.
data AmountStyle = AmountStyle {
ascommodityside :: Side, -- ^ does the symbol appear on the left or the right ?
ascommodityspaced :: Bool, -- ^ space between symbol and quantity ?
asprecision :: Int, -- ^ number of digits displayed after the decimal point
asdecimalpoint :: Char, -- ^ character used as decimal point
asseparator :: Char, -- ^ character used for separating digit groups (eg thousands)
asseparatorpositions :: [Int] -- ^ positions of digit group separators, counting leftward from decimal point
} deriving (Eq,Ord,Show,Read)
data Amount = Amount { data Amount = Amount {
commodity :: Commodity, acommodity :: Commodity,
quantity :: Quantity, aquantity :: Quantity,
price :: Maybe Price -- ^ the price for this amount at posting time aprice :: Maybe Price, -- ^ the price for this amount, fixed at posting time
astyle :: AmountStyle
} deriving (Eq,Ord) } deriving (Eq,Ord)
newtype MixedAmount = Mixed [Amount] deriving (Eq,Ord) newtype MixedAmount = Mixed [Amount] deriving (Eq,Ord)
@ -136,7 +138,7 @@ type Year = Integer
-- is saved for later use by eg the add command. -- is saved for later use by eg the add command.
data JournalContext = Ctx { data JournalContext = Ctx {
ctxYear :: !(Maybe Year) -- ^ the default year most recently specified with Y ctxYear :: !(Maybe Year) -- ^ the default year most recently specified with Y
, ctxCommodity :: !(Maybe Commodity) -- ^ the default commodity most recently specified with D , ctxCommodityAndStyle :: !(Maybe (Commodity,AmountStyle)) -- ^ the default commodity and amount style most recently specified with D
, ctxAccount :: ![AccountName] -- ^ the current stack of parent accounts/account name components , ctxAccount :: ![AccountName] -- ^ the current stack of parent accounts/account name components
-- specified with "account" directive(s). Concatenated, these -- specified with "account" directive(s). Concatenated, these
-- are the account prefix prepended to parsed account names. -- are the account prefix prepended to parsed account names.
@ -155,7 +157,8 @@ data Journal = Journal {
-- any included journal files. The main file is -- any included journal files. The main file is
-- first followed by any included files in the -- first followed by any included files in the
-- order encountered (XXX reversed, cf journalAddFile). -- order encountered (XXX reversed, cf journalAddFile).
filereadtime :: ClockTime -- ^ when this journal was last read from its file(s) filereadtime :: ClockTime, -- ^ when this journal was last read from its file(s)
jcommoditystyles :: M.Map Commodity AmountStyle -- ^ how to display amounts in each commodity
} deriving (Eq, Typeable) } deriving (Eq, Typeable)
-- | A JournalUpdate is some transformation of a Journal. It can do I/O or -- | A JournalUpdate is some transformation of a Journal. It can do I/O or
@ -239,6 +242,7 @@ data Account = Account {
aname :: AccountName, -- ^ this account's full name aname :: AccountName, -- ^ this account's full name
aebalance :: MixedAmount, -- ^ this account's balance, excluding subaccounts aebalance :: MixedAmount, -- ^ this account's balance, excluding subaccounts
asubs :: [Account], -- ^ sub-accounts asubs :: [Account], -- ^ sub-accounts
-- anumpostings :: Int -- ^ number of postings to this account
-- derived from the above: -- derived from the above:
aibalance :: MixedAmount, -- ^ this account's balance, including subaccounts aibalance :: MixedAmount, -- ^ this account's balance, including subaccounts
aparent :: Maybe Account, -- ^ parent account aparent :: Maybe Account, -- ^ parent account

4
hledger-lib/Hledger/Read.hs
View File

@ -19,8 +19,8 @@ module Hledger.Read (
ensureJournalFileExists, ensureJournalFileExists,
-- * Parsers used elsewhere -- * Parsers used elsewhere
accountname, accountname,
amount, amountp,
amount', amountp',
-- * Tests -- * Tests
samplejournal, samplejournal,
tests_Hledger_Read, tests_Hledger_Read,

4
hledger-lib/Hledger/Read/CsvReader.hs
View File

@ -61,7 +61,7 @@ import Prelude hiding (getContents)
import Hledger.Utils.UTF8IOCompat (getContents) import Hledger.Utils.UTF8IOCompat (getContents)
import Hledger.Utils import Hledger.Utils
import Hledger.Data.FormatStrings as FormatStrings import Hledger.Data.FormatStrings as FormatStrings
import Hledger.Read.JournalReader (accountname, amount) import Hledger.Read.JournalReader (accountname, amountp)
reader :: Reader reader :: Reader
@ -426,7 +426,7 @@ transactionFromCsvRecord rules fields =
strnegate s = '-':s strnegate s = '-':s
currency = maybe (fromMaybe "" $ baseCurrency rules) (atDef "" fields) (currencyField rules) currency = maybe (fromMaybe "" $ baseCurrency rules) (atDef "" fields) (currencyField rules)
amountstr'' = currency ++ amountstr' amountstr'' = currency ++ amountstr'
amountparse = runParser amount nullctx "" amountstr'' amountparse = runParser amountp nullctx "" amountstr''
a = either (const nullmixedamt) id amountparse a = either (const nullmixedamt) id amountparse
-- Using costOfMixedAmount here to allow complex costs like "10 GBP @@ 15 USD". -- Using costOfMixedAmount here to allow complex costs like "10 GBP @@ 15 USD".
-- Aim is to have "10 GBP @@ 15 USD" applied to account "acct", but have "-15USD" applied to "baseacct" -- Aim is to have "10 GBP @@ 15 USD" applied to account "acct", but have "-15USD" applied to "baseacct"

125
hledger-lib/Hledger/Read/JournalReader.hs
View File

@ -27,8 +27,8 @@ module Hledger.Read.JournalReader (
historicalpricedirective, historicalpricedirective,
datetime, datetime,
accountname, accountname,
amount, amountp,
amount', amountp',
emptyline, emptyline,
-- * Tests -- * Tests
tests_Hledger_Read_JournalReader tests_Hledger_Read_JournalReader
@ -102,11 +102,11 @@ setYear y = updateState (\ctx -> ctx{ctxYear=Just y})
getYear :: GenParser tok JournalContext (Maybe Integer) getYear :: GenParser tok JournalContext (Maybe Integer)
getYear = liftM ctxYear getState getYear = liftM ctxYear getState
setCommodity :: Commodity -> GenParser tok JournalContext () setCommodityAndStyle :: (Commodity,AmountStyle) -> GenParser tok JournalContext ()
setCommodity c = updateState (\ctx -> ctx{ctxCommodity=Just c}) setCommodityAndStyle cs = updateState (\ctx -> ctx{ctxCommodityAndStyle=Just cs})
getCommodity :: GenParser tok JournalContext (Maybe Commodity) getCommodityAndStyle :: GenParser tok JournalContext (Maybe (Commodity,AmountStyle))
getCommodity = liftM ctxCommodity getState getCommodityAndStyle = ctxCommodityAndStyle `fmap` getState
pushParentAccount :: String -> GenParser tok JournalContext () pushParentAccount :: String -> GenParser tok JournalContext ()
pushParentAccount parent = updateState addParentAccount pushParentAccount parent = updateState addParentAccount
@ -254,10 +254,11 @@ defaultcommoditydirective :: GenParser Char JournalContext JournalUpdate
defaultcommoditydirective = do defaultcommoditydirective = do
char 'D' <?> "default commodity" char 'D' <?> "default commodity"
many1 spacenonewline many1 spacenonewline
a <- amount a <- amountp
-- amount always returns a MixedAmount containing one Amount, but let's be safe -- amount always returns a MixedAmount containing one Amount, but let's be safe
let as = amounts a let as = amounts a
when (not $ null as) $ setCommodity $ commodity $ head as when (not $ null as) $
let Amount{..} = head as in setCommodityAndStyle (acommodity, astyle)
restofline restofline
return $ return id return $ return id
@ -269,7 +270,7 @@ historicalpricedirective = do
many1 spacenonewline many1 spacenonewline
symbol <- commoditysymbol symbol <- commoditysymbol
many spacenonewline many spacenonewline
price <- amount price <- amountp
restofline restofline
return $ HistoricalPrice date symbol price return $ HistoricalPrice date symbol price
@ -285,11 +286,11 @@ commodityconversiondirective :: GenParser Char JournalContext JournalUpdate
commodityconversiondirective = do commodityconversiondirective = do
char 'C' <?> "commodity conversion" char 'C' <?> "commodity conversion"
many1 spacenonewline many1 spacenonewline
amount amountp
many spacenonewline many spacenonewline
char '=' char '='
many spacenonewline many spacenonewline
amount amountp
restofline restofline
return $ return id return $ return id
@ -370,7 +371,7 @@ tests_transaction = [
nullposting{ nullposting{
pstatus=True, pstatus=True,
paccount="a", paccount="a",
pamount=Mixed [dollars 1], pamount=Mixed [usd 1],
pcomment="pcomment1\npcomment2\n", pcomment="pcomment1\npcomment2\n",
ptype=RegularPosting, ptype=RegularPosting,
ptags=[("ptag1","val1"),("ptag2","val2")], ptags=[("ptag1","val1"),("ptag2","val2")],
@ -514,7 +515,7 @@ tests_posting = [
same ptransaction same ptransaction
" expenses:food:dining $10.00 ; a: a a \n ; b: b b \n" " expenses:food:dining $10.00 ; a: a a \n ; b: b b \n"
`gives` `gives`
(Posting False "expenses:food:dining" (Mixed [dollars 10]) "" RegularPosting [("a","a a"), ("b","b b")] Nothing) (Posting False "expenses:food:dining" (Mixed [usd 10]) "" RegularPosting [("a","a a"), ("b","b b")] Nothing)
assertBool "posting parses a quoted commodity with numbers" assertBool "posting parses a quoted commodity with numbers"
(isRight $ parseWithCtx nullctx posting " a 1 \"DE123\"\n") (isRight $ parseWithCtx nullctx posting " a 1 \"DE123\"\n")
@ -558,12 +559,12 @@ spaceandamountormissing :: GenParser Char JournalContext MixedAmount
spaceandamountormissing = spaceandamountormissing =
try (do try (do
many1 spacenonewline many1 spacenonewline
amount <|> return missingmixedamt amountp <|> return missingmixedamt
) <|> return missingmixedamt ) <|> return missingmixedamt
tests_spaceandamountormissing = [ tests_spaceandamountormissing = [
"spaceandamountormissing" ~: do "spaceandamountormissing" ~: do
assertParseEqual (parseWithCtx nullctx spaceandamountormissing " $47.18") (Mixed [dollars 47.18]) assertParseEqual (parseWithCtx nullctx spaceandamountormissing " $47.18") (Mixed [usd 47.18])
assertParseEqual (parseWithCtx nullctx spaceandamountormissing "$47.18") missingmixedamt assertParseEqual (parseWithCtx nullctx spaceandamountormissing "$47.18") missingmixedamt
assertParseEqual (parseWithCtx nullctx spaceandamountormissing " ") missingmixedamt assertParseEqual (parseWithCtx nullctx spaceandamountormissing " ") missingmixedamt
assertParseEqual (parseWithCtx nullctx spaceandamountormissing "") missingmixedamt assertParseEqual (parseWithCtx nullctx spaceandamountormissing "") missingmixedamt
@ -571,65 +572,58 @@ tests_spaceandamountormissing = [
-- | Parse an amount, optionally with a left or right currency symbol, -- | Parse an amount, optionally with a left or right currency symbol,
-- price, and/or (ignored) ledger-style balance assertion. -- price, and/or (ignored) ledger-style balance assertion.
amount :: GenParser Char JournalContext MixedAmount amountp :: GenParser Char JournalContext MixedAmount
amount = try leftsymbolamount <|> try rightsymbolamount <|> nosymbolamount amountp = try leftsymbolamount <|> try rightsymbolamount <|> nosymbolamount
tests_amount = [ tests_amountp = [
"amount" ~: do "amountp" ~: do
assertParseEqual (parseWithCtx nullctx amount "$47.18") (Mixed [dollars 47.18]) assertParseEqual (parseWithCtx nullctx amountp "$47.18") (Mixed [usd 47.18])
assertParseEqual (parseWithCtx nullctx amount "$1.") assertParseEqual (parseWithCtx nullctx amountp "$1.") (Mixed [setAmountPrecision 0 $ usd 1])
(Mixed [Amount Commodity {symbol="$",side=L,spaced=False,decimalpoint='.',precision=0,separator=',',separatorpositions=[]} 1 Nothing])
,"amount with unit price" ~: do ,"amount with unit price" ~: do
assertParseEqual assertParseEqual
(parseWithCtx nullctx amount "$10 @ €0.5") (parseWithCtx nullctx amountp "$10 @ €0.5")
(Mixed [Amount{commodity=dollar{precision=0}, (Mixed [usd 10 `withPrecision` 0 `at` (eur 0.5 `withPrecision` 1)])
quantity=10,
price=(Just $ UnitPrice $ Mixed [Amount{commodity=euro{precision=1},
quantity=0.5,
price=Nothing}])}])
,"amount with total price" ~: do ,"amount with total price" ~: do
assertParseEqual assertParseEqual
(parseWithCtx nullctx amount "$10 @@ €5") (parseWithCtx nullctx amountp "$10 @@ €5")
(Mixed [Amount{commodity=dollar{precision=0}, (Mixed [usd 10 `withPrecision` 0 @@ (eur 5 `withPrecision` 0)])
quantity=10,
price=(Just $ TotalPrice $ Mixed [Amount{commodity=euro{precision=0},
quantity=5,
price=Nothing}])}])
] ]
-- | Run the amount parser on a string to get the result or an error. -- | Run the amount parser on a string to get the result or an error.
amount' :: String -> MixedAmount amountp' :: String -> MixedAmount
amount' s = either (error' . show) id $ parseWithCtx nullctx amount s amountp' s = either (error' . show) id $ parseWithCtx nullctx amountp s
leftsymbolamount :: GenParser Char JournalContext MixedAmount leftsymbolamount :: GenParser Char JournalContext MixedAmount
leftsymbolamount = do leftsymbolamount = do
sign <- optionMaybe $ string "-" sign <- optionMaybe $ string "-"
let applysign = if isJust sign then negate else id let applysign = if isJust sign then negate else id
sym <- commoditysymbol c <- commoditysymbol
sp <- many spacenonewline sp <- many spacenonewline
(q,p,d,s,spos) <- number (q,prec,dec,sep,seppos) <- number
pri <- priceamount let s = amountstyle{ascommodityside=L, ascommodityspaced=not $ null sp, asdecimalpoint=dec, asprecision=prec, asseparator=sep, asseparatorpositions=seppos}
let c = Commodity {symbol=sym,side=L,spaced=not $ null sp,decimalpoint=d,precision=p,separator=s,separatorpositions=spos} p <- priceamount
return $ applysign $ Mixed [Amount c q pri] return $ applysign $ Mixed [Amount c q p s]
<?> "left-symbol amount" <?> "left-symbol amount"
rightsymbolamount :: GenParser Char JournalContext MixedAmount rightsymbolamount :: GenParser Char JournalContext MixedAmount
rightsymbolamount = do rightsymbolamount = do
(q,p,d,s,spos) <- number (q,prec,dec,sep,seppos) <- number
sp <- many spacenonewline sp <- many spacenonewline
sym <- commoditysymbol c <- commoditysymbol
pri <- priceamount p <- priceamount
let c = Commodity {symbol=sym,side=R,spaced=not $ null sp,decimalpoint=d,precision=p,separator=s,separatorpositions=spos} let s = amountstyle{ascommodityside=R, ascommodityspaced=not $ null sp, asdecimalpoint=dec, asprecision=prec, asseparator=sep, asseparatorpositions=seppos}
return $ Mixed [Amount c q pri] return $ Mixed [Amount c q p s]
<?> "right-symbol amount" <?> "right-symbol amount"
nosymbolamount :: GenParser Char JournalContext MixedAmount nosymbolamount :: GenParser Char JournalContext MixedAmount
nosymbolamount = do nosymbolamount = do
(q,p,d,s,spos) <- number (q,prec,dec,sep,seppos) <- number
pri <- priceamount p <- priceamount
defc <- getCommodity defcs <- getCommodityAndStyle
let c = fromMaybe Commodity{symbol="",side=L,spaced=False,decimalpoint=d,precision=p,separator=s,separatorpositions=spos} defc let (c,s) = case defcs of
return $ Mixed [Amount c q pri] Just (c',s') -> (c',s')
Nothing -> ("", amountstyle{asdecimalpoint=dec, asprecision=prec, asseparator=sep, asseparatorpositions=seppos})
return $ Mixed [Amount c q p s]
<?> "no-symbol amount" <?> "no-symbol amount"
commoditysymbol :: GenParser Char JournalContext String commoditysymbol :: GenParser Char JournalContext String
@ -653,11 +647,11 @@ priceamount =
try (do try (do
char '@' char '@'
many spacenonewline many spacenonewline
a <- amount -- XXX can parse more prices ad infinitum, shouldn't a <- amountp -- XXX can parse more prices ad infinitum, shouldn't
return $ Just $ TotalPrice a) return $ Just $ TotalPrice a)
<|> (do <|> (do
many spacenonewline many spacenonewline
a <- amount -- XXX can parse more prices ad infinitum, shouldn't a <- amountp -- XXX can parse more prices ad infinitum, shouldn't
return $ Just $ UnitPrice a)) return $ Just $ UnitPrice a))
<|> return Nothing <|> return Nothing
@ -667,7 +661,7 @@ balanceassertion =
many spacenonewline many spacenonewline
char '=' char '='
many spacenonewline many spacenonewline
a <- amount -- XXX should restrict to a simple amount a <- amountp -- XXX should restrict to a simple amount
return $ Just a) return $ Just a)
<|> return Nothing <|> return Nothing
@ -680,7 +674,7 @@ fixedlotprice =
many spacenonewline many spacenonewline
char '=' char '='
many spacenonewline many spacenonewline
a <- amount -- XXX should restrict to a simple amount a <- amountp -- XXX should restrict to a simple amount
many spacenonewline many spacenonewline
char '}' char '}'
return $ Just a) return $ Just a)
@ -841,7 +835,7 @@ tests_tagcomment = [
tests_Hledger_Read_JournalReader = TestList $ concat [ tests_Hledger_Read_JournalReader = TestList $ concat [
tests_number, tests_number,
tests_amount, tests_amountp,
tests_spaceandamountormissing, tests_spaceandamountormissing,
tests_tagcomment, tests_tagcomment,
tests_inlinecomment, tests_inlinecomment,
@ -891,7 +885,7 @@ tests_Hledger_Read_JournalReader = TestList $ concat [
assertParse (parseWithCtx nullctx defaultyeardirective "Y 10001\n") assertParse (parseWithCtx nullctx defaultyeardirective "Y 10001\n")
,"historicalpricedirective" ~: ,"historicalpricedirective" ~:
assertParseEqual (parseWithCtx nullctx historicalpricedirective "P 2004/05/01 XYZ $55.00\n") (HistoricalPrice (parsedate "2004/05/01") "XYZ" $ Mixed [dollars 55]) assertParseEqual (parseWithCtx nullctx historicalpricedirective "P 2004/05/01 XYZ $55.00\n") (HistoricalPrice (parsedate "2004/05/01") "XYZ" $ Mixed [usd 55])
,"ignoredpricecommoditydirective" ~: do ,"ignoredpricecommoditydirective" ~: do
assertParse (parseWithCtx nullctx ignoredpricecommoditydirective "N $\n") assertParse (parseWithCtx nullctx ignoredpricecommoditydirective "N $\n")
@ -916,19 +910,16 @@ tests_Hledger_Read_JournalReader = TestList $ concat [
assertBool "accountname rejects an empty trailing component" (isLeft $ parsewith accountname "a:b:") assertBool "accountname rejects an empty trailing component" (isLeft $ parsewith accountname "a:b:")
,"leftsymbolamount" ~: do ,"leftsymbolamount" ~: do
assertParseEqual (parseWithCtx nullctx leftsymbolamount "$1") assertParseEqual (parseWithCtx nullctx leftsymbolamount "$1") (Mixed [usd 1 `withPrecision` 0])
(Mixed [Amount Commodity {symbol="$",side=L,spaced=False,decimalpoint='.',precision=0,separator=',',separatorpositions=[]} 1 Nothing]) assertParseEqual (parseWithCtx nullctx leftsymbolamount "$-1") (Mixed [usd (-1) `withPrecision` 0])
assertParseEqual (parseWithCtx nullctx leftsymbolamount "$-1") assertParseEqual (parseWithCtx nullctx leftsymbolamount "-$1") (Mixed [usd (-1) `withPrecision` 0])
(Mixed [Amount Commodity {symbol="$",side=L,spaced=False,decimalpoint='.',precision=0,separator=',',separatorpositions=[]} (-1) Nothing])
assertParseEqual (parseWithCtx nullctx leftsymbolamount "-$1")
(Mixed [Amount Commodity {symbol="$",side=L,spaced=False,decimalpoint='.',precision=0,separator=',',separatorpositions=[]} (-1) Nothing])
,"amount" ~: do ,"amount" ~: do
let -- | compare a parse result with a MixedAmount, showing the debug representation for clarity let -- | compare a parse result with a MixedAmount, showing the debug representation for clarity
assertMixedAmountParse parseresult mixedamount = assertMixedAmountParse parseresult mixedamount =
(either (const "parse error") showMixedAmountDebug parseresult) ~?= (showMixedAmountDebug mixedamount) (either (const "parse error") showMixedAmountDebug parseresult) ~?= (showMixedAmountDebug mixedamount)
assertMixedAmountParse (parseWithCtx nullctx amount "1 @ $2") assertMixedAmountParse (parseWithCtx nullctx amountp "1 @ $2")
(Mixed [Amount unknown 1 (Just $ UnitPrice $ Mixed [Amount dollar{precision=0} 2 Nothing])]) (Mixed [amt 1 `withPrecision` 0 `at` (usd 2 `withPrecision` 0)])
]] ]]
@ -941,6 +932,6 @@ entry1_str = unlines
entry1 = entry1 =
txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" [] txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" []
[Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting [] Nothing, [Posting False "expenses:food:groceries" (Mixed [usd 47.18]) "" RegularPosting [] Nothing,
Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting [] Nothing] "" Posting False "assets:checking" (Mixed [usd (-47.18)]) "" RegularPosting [] Nothing] ""

103
hledger-lib/Hledger/Reports.hs
View File

@ -56,13 +56,12 @@ import Data.Time.Calendar
-- import Data.Tree -- import Data.Tree
import Safe (headMay, lastMay) import Safe (headMay, lastMay)
import System.Console.CmdArgs -- for defaults support import System.Console.CmdArgs -- for defaults support
import System.Time (ClockTime(TOD))
import Test.HUnit import Test.HUnit
import Text.ParserCombinators.Parsec import Text.ParserCombinators.Parsec
import Text.Printf import Text.Printf
import Hledger.Data import Hledger.Data
import Hledger.Read (amount') import Hledger.Read (amountp')
import Hledger.Query import Hledger.Query
import Hledger.Utils import Hledger.Utils
@ -425,7 +424,7 @@ type TransactionsReportItem = (Transaction -- the corresponding transaction
triDate (t,_,_,_,_,_) = tdate t triDate (t,_,_,_,_,_) = tdate t
triBalance (_,_,_,_,_,Mixed a) = case a of [] -> "0" triBalance (_,_,_,_,_,Mixed a) = case a of [] -> "0"
(Amount{quantity=q}):_ -> show q (Amount{aquantity=q}):_ -> show q
-- | Select transactions from the whole journal for a transactions report, -- | Select transactions from the whole journal for a transactions report,
-- with no \"current\" account. The end result is similar to -- with no \"current\" account. The end result is similar to
@ -760,36 +759,36 @@ tests_accountsReport =
,"accountsReport with no args on sample journal" ~: do ,"accountsReport with no args on sample journal" ~: do
(defreportopts, samplejournal) `gives` (defreportopts, samplejournal) `gives`
([ ([
("assets","assets",0, amount' "$-1.00") ("assets","assets",0, amountp' "$-1.00")
,("assets:bank:saving","bank:saving",1, amount' "$1.00") ,("assets:bank:saving","bank:saving",1, amountp' "$1.00")
,("assets:cash","cash",1, amount' "$-2.00") ,("assets:cash","cash",1, amountp' "$-2.00")
,("expenses","expenses",0, amount' "$2.00") ,("expenses","expenses",0, amountp' "$2.00")
,("expenses:food","food",1, amount' "$1.00") ,("expenses:food","food",1, amountp' "$1.00")
,("expenses:supplies","supplies",1, amount' "$1.00") ,("expenses:supplies","supplies",1, amountp' "$1.00")
,("income","income",0, amount' "$-2.00") ,("income","income",0, amountp' "$-2.00")
,("income:gifts","gifts",1, amount' "$-1.00") ,("income:gifts","gifts",1, amountp' "$-1.00")
,("income:salary","salary",1, amount' "$-1.00") ,("income:salary","salary",1, amountp' "$-1.00")
,("liabilities:debts","liabilities:debts",0, amount' "$1.00") ,("liabilities:debts","liabilities:debts",0, amountp' "$1.00")
], ],
Mixed [nullamt]) Mixed [nullamt])
,"accountsReport with --depth=N" ~: do ,"accountsReport with --depth=N" ~: do
(defreportopts{depth_=Just 1}, samplejournal) `gives` (defreportopts{depth_=Just 1}, samplejournal) `gives`
([ ([
("assets", "assets", 0, amount' "$-1.00") ("assets", "assets", 0, amountp' "$-1.00")
,("expenses", "expenses", 0, amount' "$2.00") ,("expenses", "expenses", 0, amountp' "$2.00")
,("income", "income", 0, amount' "$-2.00") ,("income", "income", 0, amountp' "$-2.00")
,("liabilities", "liabilities", 0, amount' "$1.00") ,("liabilities", "liabilities", 0, amountp' "$1.00")
], ],
Mixed [nullamt]) Mixed [nullamt])
,"accountsReport with depth:N" ~: do ,"accountsReport with depth:N" ~: do
(defreportopts{query_="depth:1"}, samplejournal) `gives` (defreportopts{query_="depth:1"}, samplejournal) `gives`
([ ([
("assets", "assets", 0, amount' "$-1.00") ("assets", "assets", 0, amountp' "$-1.00")
,("expenses", "expenses", 0, amount' "$2.00") ,("expenses", "expenses", 0, amountp' "$2.00")
,("income", "income", 0, amount' "$-2.00") ,("income", "income", 0, amountp' "$-2.00")
,("liabilities", "liabilities", 0, amount' "$1.00") ,("liabilities", "liabilities", 0, amountp' "$1.00")
], ],
Mixed [nullamt]) Mixed [nullamt])
@ -799,32 +798,32 @@ tests_accountsReport =
Mixed [nullamt]) Mixed [nullamt])
(defreportopts{query_="edate:'in 2009'"}, samplejournal2) `gives` (defreportopts{query_="edate:'in 2009'"}, samplejournal2) `gives`
([ ([
("assets:bank:checking","assets:bank:checking",0,amount' "$1.00") ("assets:bank:checking","assets:bank:checking",0,amountp' "$1.00")
,("income:salary","income:salary",0,amount' "$-1.00") ,("income:salary","income:salary",0,amountp' "$-1.00")
], ],
Mixed [nullamt]) Mixed [nullamt])
,"accountsReport with desc:" ~: do ,"accountsReport with desc:" ~: do
(defreportopts{query_="desc:income"}, samplejournal) `gives` (defreportopts{query_="desc:income"}, samplejournal) `gives`
([ ([
("assets:bank:checking","assets:bank:checking",0,amount' "$1.00") ("assets:bank:checking","assets:bank:checking",0,amountp' "$1.00")
,("income:salary","income:salary",0, amount' "$-1.00") ,("income:salary","income:salary",0, amountp' "$-1.00")
], ],
Mixed [nullamt]) Mixed [nullamt])
,"accountsReport with not:desc:" ~: do ,"accountsReport with not:desc:" ~: do
(defreportopts{query_="not:desc:income"}, samplejournal) `gives` (defreportopts{query_="not:desc:income"}, samplejournal) `gives`
([ ([
("assets","assets",0, amount' "$-2.00") ("assets","assets",0, amountp' "$-2.00")
,("assets:bank","bank",1, Mixed [nullamt]) ,("assets:bank","bank",1, Mixed [nullamt])
,("assets:bank:checking","checking",2,amount' "$-1.00") ,("assets:bank:checking","checking",2,amountp' "$-1.00")
,("assets:bank:saving","saving",2, amount' "$1.00") ,("assets:bank:saving","saving",2, amountp' "$1.00")
,("assets:cash","cash",1, amount' "$-2.00") ,("assets:cash","cash",1, amountp' "$-2.00")
,("expenses","expenses",0, amount' "$2.00") ,("expenses","expenses",0, amountp' "$2.00")
,("expenses:food","food",1, amount' "$1.00") ,("expenses:food","food",1, amountp' "$1.00")
,("expenses:supplies","supplies",1, amount' "$1.00") ,("expenses:supplies","supplies",1, amountp' "$1.00")
,("income:gifts","income:gifts",0, amount' "$-1.00") ,("income:gifts","income:gifts",0, amountp' "$-1.00")
,("liabilities:debts","liabilities:debts",0, amount' "$1.00") ,("liabilities:debts","liabilities:debts",0, amountp' "$1.00")
], ],
Mixed [nullamt]) Mixed [nullamt])
@ -945,10 +944,9 @@ tests_accountsReport =
-} -}
] ]
Right samplejournal2 = journalBalanceTransactions $ Journal Right samplejournal2 = journalBalanceTransactions $
[] nulljournal
[] {jtxns = [
[
txnTieKnot $ Transaction { txnTieKnot $ Transaction {
tdate=parsedate "2008/01/01", tdate=parsedate "2008/01/01",
teffectivedate=Just $ parsedate "2009/01/01", teffectivedate=Just $ parsedate "2009/01/01",
@ -961,7 +959,7 @@ Right samplejournal2 = journalBalanceTransactions $ Journal
Posting { Posting {
pstatus=False, pstatus=False,
paccount="assets:bank:checking", paccount="assets:bank:checking",
pamount=(Mixed [dollars 1]), pamount=(Mixed [usd 1]),
pcomment="", pcomment="",
ptype=RegularPosting, ptype=RegularPosting,
ptags=[], ptags=[],
@ -980,12 +978,7 @@ Right samplejournal2 = journalBalanceTransactions $ Journal
tpreceding_comment_lines="" tpreceding_comment_lines=""
} }
] ]
[] }
[]
""
nullctx
[]
(TOD 0 0)
-- tests_isInterestingIndented = [ -- tests_isInterestingIndented = [
-- "isInterestingIndented" ~: do -- "isInterestingIndented" ~: do
@ -1010,10 +1003,10 @@ tests_Hledger_Reports = TestList $
-- (summarisePostingsInDateSpan (mkdatespan b e) depth showempty ps `is`) -- (summarisePostingsInDateSpan (mkdatespan b e) depth showempty ps `is`)
-- let ps = -- let ps =
-- [ -- [
-- nullposting{lpdescription="desc",lpaccount="expenses:food:groceries",lpamount=Mixed [dollars 1]} -- nullposting{lpdescription="desc",lpaccount="expenses:food:groceries",lpamount=Mixed [usd 1]}
-- ,nullposting{lpdescription="desc",lpaccount="expenses:food:dining", lpamount=Mixed [dollars 2]} -- ,nullposting{lpdescription="desc",lpaccount="expenses:food:dining", lpamount=Mixed [usd 2]}
-- ,nullposting{lpdescription="desc",lpaccount="expenses:food", lpamount=Mixed [dollars 4]} -- ,nullposting{lpdescription="desc",lpaccount="expenses:food", lpamount=Mixed [usd 4]}
-- ,nullposting{lpdescription="desc",lpaccount="expenses:food:dining", lpamount=Mixed [dollars 8]} -- ,nullposting{lpdescription="desc",lpaccount="expenses:food:dining", lpamount=Mixed [usd 8]}
-- ] -- ]
-- ("2008/01/01","2009/01/01",0,9999,False,[]) `gives` -- ("2008/01/01","2009/01/01",0,9999,False,[]) `gives`
-- [] -- []
@ -1023,21 +1016,21 @@ tests_Hledger_Reports = TestList $
-- ] -- ]
-- ("2008/01/01","2009/01/01",0,9999,False,ts) `gives` -- ("2008/01/01","2009/01/01",0,9999,False,ts) `gives`
-- [ -- [
-- nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food", lpamount=Mixed [dollars 4]} -- nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food", lpamount=Mixed [usd 4]}
-- ,nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food:dining", lpamount=Mixed [dollars 10]} -- ,nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food:dining", lpamount=Mixed [usd 10]}
-- ,nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food:groceries",lpamount=Mixed [dollars 1]} -- ,nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food:groceries",lpamount=Mixed [usd 1]}
-- ] -- ]
-- ("2008/01/01","2009/01/01",0,2,False,ts) `gives` -- ("2008/01/01","2009/01/01",0,2,False,ts) `gives`
-- [ -- [
-- nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food",lpamount=Mixed [dollars 15]} -- nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food",lpamount=Mixed [usd 15]}
-- ] -- ]
-- ("2008/01/01","2009/01/01",0,1,False,ts) `gives` -- ("2008/01/01","2009/01/01",0,1,False,ts) `gives`
-- [ -- [
-- nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses",lpamount=Mixed [dollars 15]} -- nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses",lpamount=Mixed [usd 15]}
-- ] -- ]
-- ("2008/01/01","2009/01/01",0,0,False,ts) `gives` -- ("2008/01/01","2009/01/01",0,0,False,ts) `gives`
-- [ -- [
-- nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="",lpamount=Mixed [dollars 15]} -- nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="",lpamount=Mixed [usd 15]}
-- ] -- ]
] ]

73
hledger/Hledger/Cli.hs
View File

@ -23,9 +23,7 @@ module Hledger.Cli (
tests_Hledger_Cli tests_Hledger_Cli
) )
where where
import qualified Data.Map as Map
import Data.Time.Calendar import Data.Time.Calendar
import System.Time (ClockTime(TOD))
import Test.HUnit import Test.HUnit
import Hledger import Hledger
@ -110,12 +108,9 @@ tests_Hledger_Cli = TestList
"expenses","expenses:food","expenses:food:dining","expenses:phone","expenses:vacation", "expenses","expenses:food","expenses:food:dining","expenses:phone","expenses:vacation",
"liabilities","liabilities:credit cards","liabilities:credit cards:discover"] "liabilities","liabilities:credit cards","liabilities:credit cards:discover"]
,"journalCanonicaliseAmounts" ~: -- ,"journalCanonicaliseAmounts" ~:
"use the greatest precision" ~: -- "use the greatest precision" ~:
(map precision $ journalAmountAndPriceCommodities $ journalCanonicaliseAmounts $ journalWithAmounts ["1","2.00"]) `is` [2,2] -- (map asprecision $ journalAmountAndPriceCommodities $ journalCanonicaliseAmounts $ journalWithAmounts ["1","2.00"]) `is` [2,2]
,"commodities" ~:
Map.elems (ledgerCommodities ledger7) `is` [Commodity {symbol="$", side=L, spaced=False, decimalpoint='.', precision=2, separator=',', separatorpositions=[]}]
-- don't know what this should do -- don't know what this should do
-- ,"elideAccountName" ~: do -- ,"elideAccountName" ~: do
@ -129,9 +124,9 @@ tests_Hledger_Cli = TestList
tdate (head $ jtxns j) `is` fromGregorian 2009 1 1 tdate (head $ jtxns j) `is` fromGregorian 2009 1 1
return () return ()
,"show dollars" ~: showAmount (dollars 1) ~?= "$1.00" ,"show dollars" ~: showAmount (usd 1) ~?= "$1.00"
,"show hours" ~: showAmount (hours 1) ~?= "1.0h" ,"show hours" ~: showAmount (hrs 1) ~?= "1.0h"
] ]
@ -337,9 +332,7 @@ defaultyear_journal_str = unlines
-- ,"" -- ,""
-- ] -- ]
journal7 = Journal journal7 = nulljournal {jtxns =
[]
[]
[ [
txnTieKnot $ Transaction { txnTieKnot $ Transaction {
tdate=parsedate "2007/01/01", tdate=parsedate "2007/01/01",
@ -353,7 +346,7 @@ journal7 = Journal
Posting { Posting {
pstatus=False, pstatus=False,
paccount="assets:cash", paccount="assets:cash",
pamount=(Mixed [dollars 4.82]), pamount=(Mixed [usd 4.82]),
pcomment="", pcomment="",
ptype=RegularPosting, ptype=RegularPosting,
ptags=[], ptags=[],
@ -362,7 +355,7 @@ journal7 = Journal
Posting { Posting {
pstatus=False, pstatus=False,
paccount="equity:opening balances", paccount="equity:opening balances",
pamount=(Mixed [dollars (-4.82)]), pamount=(Mixed [usd (-4.82)]),
pcomment="", pcomment="",
ptype=RegularPosting, ptype=RegularPosting,
ptags=[], ptags=[],
@ -384,7 +377,7 @@ journal7 = Journal
Posting { Posting {
pstatus=False, pstatus=False,
paccount="expenses:vacation", paccount="expenses:vacation",
pamount=(Mixed [dollars 179.92]), pamount=(Mixed [usd 179.92]),
pcomment="", pcomment="",
ptype=RegularPosting, ptype=RegularPosting,
ptags=[], ptags=[],
@ -393,7 +386,7 @@ journal7 = Journal
Posting { Posting {
pstatus=False, pstatus=False,
paccount="assets:checking", paccount="assets:checking",
pamount=(Mixed [dollars (-179.92)]), pamount=(Mixed [usd (-179.92)]),
pcomment="", pcomment="",
ptype=RegularPosting, ptype=RegularPosting,
ptags=[], ptags=[],
@ -415,7 +408,7 @@ journal7 = Journal
Posting { Posting {
pstatus=False, pstatus=False,
paccount="assets:saving", paccount="assets:saving",
pamount=(Mixed [dollars 200]), pamount=(Mixed [usd 200]),
pcomment="", pcomment="",
ptype=RegularPosting, ptype=RegularPosting,
ptags=[], ptags=[],
@ -424,7 +417,7 @@ journal7 = Journal
Posting { Posting {
pstatus=False, pstatus=False,
paccount="assets:checking", paccount="assets:checking",
pamount=(Mixed [dollars (-200)]), pamount=(Mixed [usd (-200)]),
pcomment="", pcomment="",
ptype=RegularPosting, ptype=RegularPosting,
ptags=[], ptags=[],
@ -446,7 +439,7 @@ journal7 = Journal
Posting { Posting {
pstatus=False, pstatus=False,
paccount="expenses:food:dining", paccount="expenses:food:dining",
pamount=(Mixed [dollars 4.82]), pamount=(Mixed [usd 4.82]),
pcomment="", pcomment="",
ptype=RegularPosting, ptype=RegularPosting,
ptags=[], ptags=[],
@ -455,7 +448,7 @@ journal7 = Journal
Posting { Posting {
pstatus=False, pstatus=False,
paccount="assets:cash", paccount="assets:cash",
pamount=(Mixed [dollars (-4.82)]), pamount=(Mixed [usd (-4.82)]),
pcomment="", pcomment="",
ptype=RegularPosting, ptype=RegularPosting,
ptags=[], ptags=[],
@ -477,7 +470,7 @@ journal7 = Journal
Posting { Posting {
pstatus=False, pstatus=False,
paccount="expenses:phone", paccount="expenses:phone",
pamount=(Mixed [dollars 95.11]), pamount=(Mixed [usd 95.11]),
pcomment="", pcomment="",
ptype=RegularPosting, ptype=RegularPosting,
ptags=[], ptags=[],
@ -486,7 +479,7 @@ journal7 = Journal
Posting { Posting {
pstatus=False, pstatus=False,
paccount="assets:checking", paccount="assets:checking",
pamount=(Mixed [dollars (-95.11)]), pamount=(Mixed [usd (-95.11)]),
pcomment="", pcomment="",
ptype=RegularPosting, ptype=RegularPosting,
ptags=[], ptags=[],
@ -508,7 +501,7 @@ journal7 = Journal
Posting { Posting {
pstatus=False, pstatus=False,
paccount="liabilities:credit cards:discover", paccount="liabilities:credit cards:discover",
pamount=(Mixed [dollars 80]), pamount=(Mixed [usd 80]),
pcomment="", pcomment="",
ptype=RegularPosting, ptype=RegularPosting,
ptags=[], ptags=[],
@ -517,7 +510,7 @@ journal7 = Journal
Posting { Posting {
pstatus=False, pstatus=False,
paccount="assets:checking", paccount="assets:checking",
pamount=(Mixed [dollars (-80)]), pamount=(Mixed [usd (-80)]),
pcomment="", pcomment="",
ptype=RegularPosting, ptype=RegularPosting,
ptags=[], ptags=[],
@ -527,12 +520,7 @@ journal7 = Journal
tpreceding_comment_lines="" tpreceding_comment_lines=""
} }
] ]
[] }
[]
""
nullctx
[]
(TOD 0 0)
ledger7 = ledgerFromJournal Any journal7 ledger7 = ledgerFromJournal Any journal7
@ -549,20 +537,13 @@ ledger7 = ledgerFromJournal Any journal7
-- timelogentry2_str = "o 2007/03/11 16:30:00\n" -- timelogentry2_str = "o 2007/03/11 16:30:00\n"
-- timelogentry2 = TimeLogEntry Out (parsedatetime "2007/03/11 16:30:00") "" -- timelogentry2 = TimeLogEntry Out (parsedatetime "2007/03/11 16:30:00") ""
-- a1 = Mixed [(hours 1){price=Just $ Mixed [Amount (comm "$") 10 Nothing]}] -- a1 = Mixed [(hrs 1){aprice=Just $ Mixed [Amount (comm "$") 10 Nothing]}]
-- a2 = Mixed [(hours 2){price=Just $ Mixed [Amount (comm "EUR") 10 Nothing]}] -- a2 = Mixed [(hrs 2){aprice=Just $ Mixed [Amount (comm "EUR") 10 Nothing]}]
-- a3 = Mixed $ amounts a1 ++ amounts a2 -- a3 = Mixed $ amounts a1 ++ amounts a2
journalWithAmounts :: [String] -> Journal -- journalWithAmounts :: [String] -> Journal
journalWithAmounts as = -- journalWithAmounts as =
Journal -- nulljournal{jtxns=
[] -- [t | a <- as, let t = nulltransaction{tdescription=a,tpostings=[nullposting{pamount=parse a,ptransaction=Just t}]}]
[] -- }
[t | a <- as, let t = nulltransaction{tdescription=a,tpostings=[nullposting{pamount=parse a,ptransaction=Just t}]}] -- where parse = fromparse . parseWithCtx nullctx amountp
[]
[]
""
nullctx
[]
(TOD 0 0)
where parse = fromparse . parseWithCtx nullctx amount

10
hledger/Hledger/Cli/Add.hs
View File

@ -148,14 +148,14 @@ getPostings st enteredps = do
-- I think 1 or 4, whichever would show the most decimal places -- I think 1 or 4, whichever would show the most decimal places
p = maxprecisionwithpoint p = maxprecisionwithpoint
amountstr <- runInteractionDefault $ askFor (printf "amount %d" n) defaultamountstr validateamount amountstr <- runInteractionDefault $ askFor (printf "amount %d" n) defaultamountstr validateamount
let a = fromparse $ runParser (amount <|> return missingmixedamt) ctx "" amountstr let a = fromparse $ runParser (amountp <|> return missingmixedamt) ctx "" amountstr
a' = fromparse $ runParser (amount <|> return missingmixedamt) nullctx "" amountstr a' = fromparse $ runParser (amountp <|> return missingmixedamt) nullctx "" amountstr
defaultamtused = Just (showMixedAmount a) == defaultamountstr defaultamtused = Just (showMixedAmount a) == defaultamountstr
commodityadded | c == cwithnodef = Nothing commodityadded | c == cwithnodef = Nothing
| otherwise = c | otherwise = c
where c = maybemixedamountcommodity a where c = maybemixedamountcommodity a
cwithnodef = maybemixedamountcommodity a' cwithnodef = maybemixedamountcommodity a'
maybemixedamountcommodity = maybe Nothing (Just . commodity) . headMay . amounts maybemixedamountcommodity = maybe Nothing (Just . acommodity) . headMay . amounts
p = nullposting{paccount=stripbrackets account, p = nullposting{paccount=stripbrackets account,
pamount=a, pamount=a,
ptype=postingtype account} ptype=postingtype account}
@ -163,7 +163,7 @@ getPostings st enteredps = do
else st{psHistory = historicalps', else st{psHistory = historicalps',
psSuggestHistoricalAmount = False} psSuggestHistoricalAmount = False}
when (isJust commodityadded) $ when (isJust commodityadded) $
liftIO $ hPutStrLn stderr $ printf "using default commodity (%s)" (symbol $ fromJust commodityadded) liftIO $ hPutStrLn stderr $ printf "using default commodity (%s)" (fromJust commodityadded)
getPostings st' (enteredps ++ [p]) getPostings st' (enteredps ++ [p])
where where
j = psJournal st j = psJournal st
@ -179,7 +179,7 @@ getPostings st enteredps = do
postingtype _ = RegularPosting postingtype _ = RegularPosting
stripbrackets = dropWhile (`elem` "([") . reverse . dropWhile (`elem` "])") . reverse stripbrackets = dropWhile (`elem` "([") . reverse . dropWhile (`elem` "])") . reverse
validateamount = Just $ \s -> (null s && not (null enteredrealps)) validateamount = Just $ \s -> (null s && not (null enteredrealps))
|| isRight (runParser (amount>>many spacenonewline>>eof) ctx "" s) || isRight (runParser (amountp >> many spacenonewline >> eof) ctx "" s)
-- | Prompt for and read a string value, optionally with a default value -- | Prompt for and read a string value, optionally with a default value
-- and a validator. A validator causes the prompt to repeat until the -- and a validator. A validator causes the prompt to repeat until the

2
hledger/Hledger/Cli/Stats.hs
View File

@ -62,7 +62,7 @@ showLedgerStats l today span =
path = journalFilePath j path = journalFilePath j
ts = sortBy (comparing tdate) $ filter (spanContainsDate span . tdate) $ jtxns j ts = sortBy (comparing tdate) $ filter (spanContainsDate span . tdate) $ jtxns j
as = nub $ map paccount $ concatMap tpostings ts as = nub $ map paccount $ concatMap tpostings ts
cs = Map.keys $ canonicaliseCommodities $ nub $ map commodity $ concatMap amounts $ map pamount $ concatMap tpostings ts cs = Map.keys $ canonicalStyles $ concatMap amounts $ map pamount $ concatMap tpostings ts
lastdate | null ts = Nothing lastdate | null ts = Nothing
| otherwise = Just $ tdate $ last ts | otherwise = Just $ tdate $ last ts
lastelapsed = maybe Nothing (Just . diffDays today) lastdate lastelapsed = maybe Nothing (Just . diffDays today) lastdate