module Hledger.Data.Amount (
nullamt,
missingamt,
amountWithCommodity,
canonicaliseAmountCommodity,
setAmountPrecision,
costOfAmount,
divideAmount,
sumAmounts,
showAmount,
showAmountDebug,
showAmountWithoutPrice,
maxprecision,
maxprecisionwithpoint,
nullmixedamt,
missingmixedamt,
amounts,
normaliseMixedAmountPreservingFirstPrice,
normaliseMixedAmountPreservingPrices,
canonicaliseMixedAmountCommodity,
mixedAmountWithCommodity,
setMixedAmountPrecision,
costOfMixedAmount,
divideMixedAmount,
isNegativeMixedAmount,
isZeroMixedAmount,
isReallyZeroMixedAmountCost,
showMixedAmount,
showMixedAmountDebug,
showMixedAmountWithoutPrice,
showMixedAmountWithPrecision,
ltraceamount,
tests_Hledger_Data_Amount
) where
import Data.Char (isDigit)
import Data.List
import Data.Map (findWithDefault)
import Test.HUnit
import Text.Printf
import qualified Data.Map as Map
import Hledger.Data.Types
import Hledger.Data.Commodity
import Hledger.Utils
deriving instance Show HistoricalPrice
instance Show Amount where show = showAmountDebug
instance Num Amount where
abs (Amount c q p) = Amount c (abs q) p
signum (Amount c q p) = Amount c (signum q) p
fromInteger i = Amount (comm "") (fromInteger i) Nothing
negate a@Amount{quantity=q} = a{quantity=(q)}
(+) = similarAmountsOp (+)
() = similarAmountsOp ()
(*) = similarAmountsOp (*)
nullamt :: Amount
nullamt = Amount unknown 0 Nothing
similarAmountsOp :: (Double -> Double -> Double) -> Amount -> Amount -> Amount
similarAmountsOp op a@(Amount Commodity{precision=ap} _ _) (Amount bc@Commodity{precision=bp} bq _) =
Amount bc{precision=max ap bp} (quantity (amountWithCommodity bc a) `op` bq) Nothing
amountWithCommodity :: Commodity -> Amount -> Amount
amountWithCommodity c (Amount _ q _) = Amount c q Nothing
sumAmounts :: [Amount] -> MixedAmount
sumAmounts = normaliseMixedAmountPreservingPrices . Mixed
tests_sumAmounts = [
"sumAmounts" ~: do
(sumAmounts [(Amount dollar 1 (Just $ UnitPrice $ Mixed [euros 1])), (Amount dollar 1 (Just $ UnitPrice $ Mixed [euros 1]))])
`is` (Mixed [Amount dollar 2 (Just $ UnitPrice $ Mixed [euros 1])])
(sumAmounts [(Amount dollar 1 (Just $ TotalPrice $ Mixed [euros 1])), (Amount dollar 1 (Just $ TotalPrice $ Mixed [euros 1]))])
`is` (Mixed [(Amount dollar 1 (Just $ TotalPrice $ Mixed [euros 1])), (Amount dollar 1 (Just $ TotalPrice $ Mixed [euros 1]))])
]
costOfAmount :: Amount -> Amount
costOfAmount a@(Amount _ q price) =
case price of
Nothing -> a
Just (UnitPrice (Mixed [Amount pc pq Nothing])) -> Amount pc (pq*q) Nothing
Just (TotalPrice (Mixed [Amount pc pq Nothing])) -> Amount pc (pq*signum q) Nothing
_ -> error' "costOfAmount: Malformed price encountered, programmer error"
divideAmount :: Amount -> Double -> Amount
divideAmount a@Amount{quantity=q} d = a{quantity=q/d}
isNegativeAmount :: Amount -> Bool
isNegativeAmount Amount{quantity=q} = q < 0
digits = "123456789" :: String
isZeroAmount :: Amount -> Bool
isZeroAmount a
| otherwise = (null . filter (`elem` digits) . showAmountWithoutPriceOrCommodity) a
isReallyZeroAmount :: Amount -> Bool
isReallyZeroAmount a
| otherwise = (null . filter (`elem` digits) . printf ("%."++show zeroprecision++"f") . quantity) a
where zeroprecision = 8
showAmountWithPrecision :: Int -> Amount -> String
showAmountWithPrecision p = showAmount . setAmountPrecision p
setAmountPrecision :: Int -> Amount -> Amount
setAmountPrecision p a@Amount{commodity=c} = a{commodity=c{precision=p}}
showAmountDebug :: Amount -> String
showAmountDebug (Amount (Commodity {symbol="AUTO"}) _ _) = "(missing)"
showAmountDebug (Amount c q pri) = printf "Amount {commodity = %s, quantity = %s, price = %s}"
(show c) (show q) (maybe "Nothing" showPriceDebug pri)
showAmountWithoutPrice :: Amount -> String
showAmountWithoutPrice a = showAmount a{price=Nothing}
showAmountWithoutPriceOrCommodity :: Amount -> String
showAmountWithoutPriceOrCommodity a@Amount{commodity=c} = showAmount a{commodity=c{symbol=""}, price=Nothing}
showPrice :: Price -> String
showPrice (UnitPrice pa) = " @ " ++ showMixedAmount pa
showPrice (TotalPrice pa) = " @@ " ++ showMixedAmount pa
showPriceDebug :: Price -> String
showPriceDebug (UnitPrice pa) = " @ " ++ showMixedAmountDebug pa
showPriceDebug (TotalPrice pa) = " @@ " ++ showMixedAmountDebug pa
showAmount :: Amount -> String
showAmount (Amount (Commodity {symbol="AUTO"}) _ _) = ""
showAmount a@(Amount (Commodity {symbol=sym,side=side,spaced=spaced}) _ pri) =
case side of
L -> printf "%s%s%s%s" sym' space quantity' price
R -> printf "%s%s%s%s" quantity' space sym' price
where
quantity = showamountquantity a
displayingzero = null $ filter (`elem` digits) $ quantity
(quantity',sym') | displayingzero = ("0","")
| otherwise = (quantity,quoteCommoditySymbolIfNeeded sym)
space = if (not (null sym') && spaced) then " " else "" :: String
price = maybe "" showPrice pri
showamountquantity :: Amount -> String
showamountquantity (Amount (Commodity {decimalpoint=d,precision=p,separator=s,separatorpositions=spos}) q _) =
punctuatenumber d s spos $ qstr
where
qstr
| p == maxprecisionwithpoint = printf "%f" q
| p == maxprecision = chopdotzero $ printf "%f" q
| otherwise = printf ("%."++show p++"f") q
punctuatenumber :: Char -> Char -> [Int] -> String -> String
punctuatenumber dec sep grps str = sign ++ reverse (addseps sep (extend grps) (reverse int)) ++ frac''
where
(sign,num) = break isDigit str
(int,frac) = break (=='.') num
frac' = dropWhile (=='.') frac
frac'' | null frac' = ""
| otherwise = dec:frac'
extend [] = []
extend gs = init gs ++ repeat (last gs)
addseps _ [] str = str
addseps sep (g:gs) str
| length str <= g = str
| otherwise = let (s,rest) = splitAt g str
in s ++ [sep] ++ addseps sep gs rest
chopdotzero str = reverse $ case reverse str of
'0':'.':s -> s
s -> s
maxprecision :: Int
maxprecision = 999998
maxprecisionwithpoint :: Int
maxprecisionwithpoint = 999999
canonicaliseAmountCommodity :: Maybe (Map.Map String Commodity) -> Amount -> Amount
canonicaliseAmountCommodity Nothing = id
canonicaliseAmountCommodity (Just canonicalcommoditymap) = fixamount
where
fixamount a@Amount{commodity=c} = a{commodity=fixcommodity c}
fixcommodity c@Commodity{symbol=s} = findWithDefault c s canonicalcommoditymap
instance Show MixedAmount where show = showMixedAmountDebug
instance Num MixedAmount where
fromInteger i = Mixed [Amount (comm "") (fromInteger i) Nothing]
negate (Mixed as) = Mixed $ map negate as
(+) (Mixed as) (Mixed bs) = normaliseMixedAmountPreservingPrices $ Mixed $ as ++ bs
(*) = error' "programming error, mixed amounts do not support multiplication"
abs = error' "programming error, mixed amounts do not support abs"
signum = error' "programming error, mixed amounts do not support signum"
nullmixedamt :: MixedAmount
nullmixedamt = Mixed []
missingamt :: Amount
missingamt = Amount unknown{symbol="AUTO"} 0 Nothing
missingmixedamt :: MixedAmount
missingmixedamt = Mixed [missingamt]
normaliseMixedAmountPreservingPrices :: MixedAmount -> MixedAmount
normaliseMixedAmountPreservingPrices (Mixed as) = Mixed as''
where
as'' = if null nonzeros then [nullamt] else nonzeros
(_,nonzeros) = partition isReallyZeroAmount $ filter (/= missingamt) as'
as' = map sumAmountsUsingFirstPrice $ group $ sort as
sort = sortBy (\a1 a2 -> compare (sym a1,price a1) (sym a2,price a2))
sym = symbol . commodity
group = groupBy (\a1 a2 -> sym a1 == sym a2 && sameunitprice a1 a2)
where
sameunitprice a1 a2 =
case (price a1, price a2) of
(Nothing, Nothing) -> True
(Just (UnitPrice p1), Just (UnitPrice p2)) -> p1 == p2
_ -> False
tests_normaliseMixedAmountPreservingPrices = [
"normaliseMixedAmountPreservingPrices" ~: do
assertEqual "discard missing amount" (Mixed [nullamt]) (normaliseMixedAmountPreservingPrices $ Mixed [dollars 0, missingamt])
assertEqual "combine unpriced same-commodity amounts" (Mixed [dollars 2]) (normaliseMixedAmountPreservingPrices $ Mixed [dollars 0, dollars 2])
assertEqual "don't combine total-priced amounts"
(Mixed
[Amount dollar 1 (Just $ TotalPrice $ Mixed [euros 1])
,Amount dollar (2) (Just $ TotalPrice $ Mixed [euros 1])
])
(normaliseMixedAmountPreservingPrices $ Mixed
[Amount dollar 1 (Just $ TotalPrice $ Mixed [euros 1])
,Amount dollar (2) (Just $ TotalPrice $ Mixed [euros 1])
])
]
normaliseMixedAmountPreservingFirstPrice :: MixedAmount -> MixedAmount
normaliseMixedAmountPreservingFirstPrice (Mixed as) = Mixed as''
where
as'' = if null nonzeros then [nullamt] else nonzeros
(_,nonzeros) = partition (\a -> isReallyZeroAmount a && a /= missingamt) as'
as' = map sumAmountsUsingFirstPrice $ group $ sort as
sort = sortBy (\a1 a2 -> compare (sym a1) (sym a2))
group = groupBy (\a1 a2 -> sym a1 == sym a2)
sym = symbol . commodity
sumAmountsUsingFirstPrice [] = nullamt
sumAmountsUsingFirstPrice as = (sum as){price=price $ head as}
amounts :: MixedAmount -> [Amount]
amounts (Mixed as) = as
costOfMixedAmount :: MixedAmount -> MixedAmount
costOfMixedAmount (Mixed as) = Mixed $ map costOfAmount as
divideMixedAmount :: MixedAmount -> Double -> MixedAmount
divideMixedAmount (Mixed as) d = Mixed $ map (flip divideAmount d) as
isNegativeMixedAmount :: MixedAmount -> Maybe Bool
isNegativeMixedAmount m = case as of [a] -> Just $ isNegativeAmount a
_ -> Nothing
where as = amounts $ normaliseMixedAmountPreservingFirstPrice m
isZeroMixedAmount :: MixedAmount -> Bool
isZeroMixedAmount = all isZeroAmount . amounts . normaliseMixedAmountPreservingFirstPrice
isReallyZeroMixedAmount :: MixedAmount -> Bool
isReallyZeroMixedAmount = all isReallyZeroAmount . amounts . normaliseMixedAmountPreservingFirstPrice
isReallyZeroMixedAmountCost :: MixedAmount -> Bool
isReallyZeroMixedAmountCost = isReallyZeroMixedAmount . costOfMixedAmount
mixedAmountWithCommodity :: Commodity -> MixedAmount -> Amount
mixedAmountWithCommodity c (Mixed as) = Amount c total Nothing
where
total = sum $ map (quantity . amountWithCommodity c) as
showMixedAmount :: MixedAmount -> String
showMixedAmount m = vConcatRightAligned $ map showAmount $ amounts $ normaliseMixedAmountPreservingFirstPrice m
ltraceamount :: String -> MixedAmount -> MixedAmount
ltraceamount s = tracewith (((s ++ ": ") ++).showMixedAmount)
setMixedAmountPrecision :: Int -> MixedAmount -> MixedAmount
setMixedAmountPrecision p (Mixed as) = Mixed $ map (setAmountPrecision p) as
showMixedAmountWithPrecision :: Int -> MixedAmount -> String
showMixedAmountWithPrecision p m =
vConcatRightAligned $ map (showAmountWithPrecision p) $ amounts $ normaliseMixedAmountPreservingFirstPrice m
showMixedAmountDebug :: MixedAmount -> String
showMixedAmountDebug m | m == missingmixedamt = "(missing)"
| otherwise = printf "Mixed [%s]" as
where as = intercalate "\n " $ map showAmountDebug $ amounts m
showMixedAmountWithoutPrice :: MixedAmount -> String
showMixedAmountWithoutPrice m = concat $ intersperse "\n" $ map showfixedwidth as
where
(Mixed as) = normaliseMixedAmountPreservingFirstPrice $ stripPrices m
stripPrices (Mixed as) = Mixed $ map stripprice as where stripprice a = a{price=Nothing}
width = maximum $ map (length . showAmount) as
showfixedwidth = printf (printf "%%%ds" width) . showAmountWithoutPrice
canonicaliseMixedAmountCommodity :: Maybe (Map.Map String Commodity) -> MixedAmount -> MixedAmount
canonicaliseMixedAmountCommodity canonicalcommoditymap (Mixed as) = Mixed $ map (canonicaliseAmountCommodity canonicalcommoditymap) as
tests_Hledger_Data_Amount = TestList $
tests_normaliseMixedAmountPreservingPrices
++ tests_sumAmounts
++ [
"costOfAmount" ~: do
costOfAmount (euros 1) `is` euros 1
costOfAmount (euros 2){price=Just $ UnitPrice $ Mixed [dollars 2]} `is` dollars 4
costOfAmount (euros 1){price=Just $ TotalPrice $ Mixed [dollars 2]} `is` dollars 2
costOfAmount (euros (1)){price=Just $ TotalPrice $ Mixed [dollars 2]} `is` dollars (2)
,"isZeroAmount" ~: do
assertBool "" $ isZeroAmount $ Amount unknown 0 Nothing
assertBool "" $ isZeroAmount $ dollars 0
,"negating amounts" ~: do
let a = dollars 1
negate a `is` a{quantity=(1)}
let b = (dollars 1){price=Just $ UnitPrice $ Mixed [euros 2]}
negate b `is` b{quantity=(1)}
,"adding amounts without prices" ~: do
let a1 = dollars 1.23
let a2 = dollars (1.23)
let a3 = dollars (1.23)
(a1 + a2) `is` Amount (comm "$") 0 Nothing
(a1 + a3) `is` Amount (comm "$") 0 Nothing
(a2 + a3) `is` Amount (comm "$") (2.46) Nothing
(a3 + a3) `is` Amount (comm "$") (2.46) Nothing
sum [a1,a2,a3,a3] `is` Amount (comm "$") 0 Nothing
let ap1 = (dollars 1){commodity=dollar{precision=1}}
ap3 = (dollars 1){commodity=dollar{precision=3}}
(sum [ap1,ap3]) `is` ap3{quantity=2}
(sum [ap3,ap1]) `is` ap3{quantity=2}
assertBool "" $ isZeroAmount (a1 euros 1.23)
,"showAmount" ~: do
showAmount (dollars 0 + pounds 0) `is` "0"
,"normaliseMixedAmountPreservingFirstPrice" ~: do
normaliseMixedAmountPreservingFirstPrice (Mixed []) `is` Mixed [nullamt]
assertBool "" $ isZeroMixedAmount $ normaliseMixedAmountPreservingFirstPrice (Mixed [Amount {commodity=dollar, quantity=10, price=Nothing}
,Amount {commodity=dollar, quantity=10, price=Just (TotalPrice (Mixed [Amount {commodity=euro, quantity=7, price=Nothing}]))}
,Amount {commodity=dollar, quantity=(10), price=Nothing}
,Amount {commodity=dollar, quantity=(10), price=Just (TotalPrice (Mixed [Amount {commodity=euro, quantity=7, price=Nothing}]))}
])
,"adding mixed amounts" ~: do
let dollar0 = dollar{precision=0}
(sum $ map (Mixed . (\a -> [a]))
[Amount dollar 1.25 Nothing,
Amount dollar0 (1) Nothing,
Amount dollar (0.25) Nothing])
`is` Mixed [Amount unknown 0 Nothing]
,"adding mixed amounts with total prices" ~: do
(sum $ map (Mixed . (\a -> [a]))
[Amount dollar 1 (Just $ TotalPrice $ Mixed [euros 1])
,Amount dollar (2) (Just $ TotalPrice $ Mixed [euros 1])
])
`is` (Mixed [Amount dollar 1 (Just $ TotalPrice $ Mixed [euros 1])
,Amount dollar (2) (Just $ TotalPrice $ Mixed [euros 1])
])
,"showMixedAmount" ~: do
showMixedAmount (Mixed [dollars 1]) `is` "$1.00"
showMixedAmount (Mixed [(dollars 1){price=Just $ UnitPrice $ Mixed [euros 2]}]) `is` "$1.00 @ €2.00"
showMixedAmount (Mixed [dollars 0]) `is` "0"
showMixedAmount (Mixed []) `is` "0"
showMixedAmount missingmixedamt `is` ""
,"showMixedAmountWithoutPrice" ~: do
let a = (dollars 1){price=Just $ UnitPrice $ Mixed [euros 2]}
showMixedAmountWithoutPrice (Mixed [a]) `is` "$1.00"
showMixedAmountWithoutPrice (Mixed [a, (a)]) `is` "0"
]