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

new API for MixedAmount arithmetic (#1491)

Browse Source 
Previously we relied on MixedAmount being a Num, which allows +, -,
sum, negate, fromInteger etc. to be used with MixedAmounts. While
convenient, this Num instance is not (and can't be) fully implemented
or law abiding, so it's possible to misuse it, potentially leading to
bugs.

Now, MixedAmount is a lawful Monoid (and a Semigroup), so you can
combine (add) MixedAmounts with <> or mconcat and represent zero with
mempty.

However, we recommend using the following more abstract API, which
will insulate you from future implementation changes:

maPlus       (instead of +)
maMinus      (instead of -)
maNegate     (instead of negate)
maSum        (instead of sum/sumStrict)
nullmixedamt (instead of 0)

And when constructing MixedAmounts, avoid the Mixed constructor,
instead use:

mixed        :: [Amount] -> MixedAmount
mixedAmount  :: Amount -> MixedAmount
maAddAmount  :: MixedAmount -> Amount -> MixedAmount
maAddAmounts :: MixedAmount -> [Amount] -> MixedAmount

For now the Num instance remains, as a convenience for scripters and
for backward compatibility, but for production code you should
probably consider it deprecated.
This commit is contained in:
Simon Michael 2021-03-17 17:36:23 -07:00
commit cef9aede93
30 changed files with 318 additions and 269 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
bin/_hledger-chart.hs
View File

@ -162,7 +162,7 @@ sameSignNonZero is
| otherwise = (map pos $ filter (test.fourth4) nzs, sign) | otherwise = (map pos $ filter (test.fourth4) nzs, sign)
where where
nzs = filter ((/=0).fourth4) is nzs = filter ((/=0).fourth4) is
pos (acct,_,_,Mixed as) = (acct, abs $ read $ show $ maybe 0 aquantity $ headMay as) pos (acct,_,_,as) = (acct, abs $ read $ show $ maybe 0 aquantity $ headMay $ amounts as)
sign = if fourth4 (head nzs) >= 0 then 1 else (-1) sign = if fourth4 (head nzs) >= 0 then 1 else (-1)
test = if sign > 0 then (>0) else (<0) test = if sign > 0 then (>0) else (<0)

12
bin/hledger-check-fancyassertions.hs
View File

@ -218,15 +218,15 @@ checkAssertion accounts = checkAssertion'
evaluate (Account account) = evaluate (Account account) =
fromMaybe H.nullmixedamt $ lookup account accounts fromMaybe H.nullmixedamt $ lookup account accounts
evaluate (AccountNested account) = evaluate (AccountNested account) =
sum [m | (a,m) <- accounts, account == a || (a <> pack ":") `isPrefixOf` account] maSum [m | (a,m) <- accounts, account == a || (a <> pack ":") `isPrefixOf` account]
evaluate (Amount amount) = H.mixed [amount] evaluate (Amount amount) = H.mixed [amount]
-- Add missing amounts (with 0 value), normalise, throw away style -- Add missing amounts (with 0 value), normalise, throw away style
-- information, and sort by commodity name. -- information, and sort by commodity name.
fixup (H.Mixed m1) (H.Mixed m2) = H.Mixed $ fixup m1 m2 =
let m = H.Mixed (m1 ++ [m_ { H.aquantity = 0 } | m_ <- m2]) let m = H.mixed $ amounts m1 ++ [m_ { H.aquantity = 0 } | m_ <- amounts m2]
(H.Mixed as) = H.normaliseMixedAmount m as = amounts $ H.normaliseMixedAmount m
in sortOn H.acommodity . map (\a -> a { H.astyle = H.amountstyle }) $ as in H.mixed $ sortOn H.acommodity . map (\a -> a { H.astyle = H.amountstyle }) $ as
-- | Check if an account name is mentioned in an assertion. -- | Check if an account name is mentioned in an assertion.
inAssertion :: H.AccountName -> Predicate -> Bool inAssertion :: H.AccountName -> Predicate -> Bool
@ -279,7 +279,7 @@ closingBalances' postings =
-- | Add balances in matching accounts. -- | Add balances in matching accounts.
addAccounts :: [(H.AccountName, H.MixedAmount)] -> [(H.AccountName, H.MixedAmount)] -> [(H.AccountName, H.MixedAmount)] addAccounts :: [(H.AccountName, H.MixedAmount)] -> [(H.AccountName, H.MixedAmount)] -> [(H.AccountName, H.MixedAmount)]
addAccounts as1 as2 = [ (a, a1 + a2) addAccounts as1 as2 = [ (a, a1 `maPlus` a2)
| a <- nub (map fst as1 ++ map fst as2) | a <- nub (map fst as1 ++ map fst as2)
, let a1 = fromMaybe H.nullmixedamt $ lookup a as1 , let a1 = fromMaybe H.nullmixedamt $ lookup a as1
, let a2 = fromMaybe H.nullmixedamt $ lookup a as2 , let a2 = fromMaybe H.nullmixedamt $ lookup a as2

2
bin/hledger-combine-balances.hs
View File

@ -34,7 +34,7 @@ appendReports r1 r2 =
mergeRows (PeriodicReportRow name amt1 tot1 avg1) (PeriodicReportRow _ amt2 tot2 avg2) = mergeRows (PeriodicReportRow name amt1 tot1 avg1) (PeriodicReportRow _ amt2 tot2 avg2) =
PeriodicReportRow { prrName = name PeriodicReportRow { prrName = name
, prrAmounts = amt1++amt2 , prrAmounts = amt1++amt2
, prrTotal = tot1+tot2 , prrTotal = tot1 `maPlus` tot2
, prrAverage = averageMixedAmounts [avg1,avg2] , prrAverage = averageMixedAmounts [avg1,avg2]
} }

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

@ -65,7 +65,7 @@ accountsFromPostings ps =
let let
grouped = groupSort [(paccount p,pamount p) | p <- ps] grouped = groupSort [(paccount p,pamount p) | p <- ps]
counted = [(aname, length amts) | (aname, amts) <- grouped] counted = [(aname, length amts) | (aname, amts) <- grouped]
summed = [(aname, sumStrict amts) | (aname, amts) <- grouped] -- always non-empty summed = [(aname, maSum amts) | (aname, amts) <- grouped] -- always non-empty
acctstree = accountTree "root" $ map fst summed acctstree = accountTree "root" $ map fst summed
acctswithnumps = mapAccounts setnumps acctstree where setnumps a = a{anumpostings=fromMaybe 0 $ lookup (aname a) counted} acctswithnumps = mapAccounts setnumps acctstree where setnumps a = a{anumpostings=fromMaybe 0 $ lookup (aname a) counted}
acctswithebals = mapAccounts setebalance acctswithnumps where setebalance a = a{aebalance=lookupJustDef nullmixedamt (aname a) summed} acctswithebals = mapAccounts setebalance acctswithnumps where setebalance a = a{aebalance=lookupJustDef nullmixedamt (aname a) summed}
@ -122,7 +122,7 @@ sumAccounts a
| otherwise = a{aibalance=ibal, asubs=subs} | otherwise = a{aibalance=ibal, asubs=subs}
where where
subs = map sumAccounts $ asubs a subs = map sumAccounts $ asubs a
ibal = sum $ aebalance a : map aibalance subs ibal = maSum $ aebalance a : map aibalance subs
-- | Remove all subaccounts below a certain depth. -- | Remove all subaccounts below a certain depth.
clipAccounts :: Int -> Account -> Account clipAccounts :: Int -> Account -> Account
@ -139,7 +139,7 @@ clipAccountsAndAggregate Nothing as = as
clipAccountsAndAggregate (Just d) as = combined clipAccountsAndAggregate (Just d) as = combined
where where
clipped = [a{aname=clipOrEllipsifyAccountName (Just d) $ aname a} | a <- as] clipped = [a{aname=clipOrEllipsifyAccountName (Just d) $ aname a} | a <- as]
combined = [a{aebalance=sum $ map aebalance same} combined = [a{aebalance=maSum $ map aebalance same}
| same@(a:_) <- groupOn aname clipped] | same@(a:_) <- groupOn aname clipped]
{- {-
test cases, assuming d=1: test cases, assuming d=1:

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

@ -94,6 +94,9 @@ module Hledger.Data.Amount (
nullmixedamt, nullmixedamt,
missingmixedamt, missingmixedamt,
mixed, mixed,
mixedAmount,
maAddAmount,
maAddAmounts,
amounts, amounts,
filterMixedAmount, filterMixedAmount,
filterMixedAmountByCommodity, filterMixedAmountByCommodity,
@ -104,12 +107,18 @@ module Hledger.Data.Amount (
mixedAmountStripPrices, mixedAmountStripPrices,
-- ** arithmetic -- ** arithmetic
mixedAmountCost, mixedAmountCost,
maNegate,
maPlus,
maMinus,
maSum,
divideMixedAmount, divideMixedAmount,
multiplyMixedAmount, multiplyMixedAmount,
averageMixedAmounts, averageMixedAmounts,
isNegativeAmount, isNegativeAmount,
isNegativeMixedAmount, isNegativeMixedAmount,
mixedAmountIsZero, mixedAmountIsZero,
maIsZero,
maIsNonZero,
mixedAmountLooksZero, mixedAmountLooksZero,
mixedAmountTotalPriceToUnitPrice, mixedAmountTotalPriceToUnitPrice,
-- ** rendering -- ** rendering
@ -138,12 +147,12 @@ import Control.Monad (foldM)
import Data.Decimal (DecimalRaw(..), decimalPlaces, normalizeDecimal, roundTo) import Data.Decimal (DecimalRaw(..), decimalPlaces, normalizeDecimal, roundTo)
import Data.Default (Default(..)) import Data.Default (Default(..))
import Data.Foldable (toList) import Data.Foldable (toList)
import Data.List (intercalate, intersperse, mapAccumL, partition) import Data.List (foldl', intercalate, intersperse, mapAccumL, partition)
import Data.List.NonEmpty (NonEmpty(..), nonEmpty) import Data.List.NonEmpty (NonEmpty(..), nonEmpty)
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
#if !(MIN_VERSION_base(4,11,0)) #if !(MIN_VERSION_base(4,11,0))
import Data.Semigroup ((<>)) import Data.Semigroup (Semigroup(..))
#endif #endif
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Lazy.Builder as TB import qualified Data.Text.Lazy.Builder as TB
@ -494,13 +503,26 @@ canonicaliseAmount styles a@Amount{acommodity=c, astyle=s} = a{astyle=s'}
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- MixedAmount -- MixedAmount
instance Semigroup MixedAmount where
(<>) = maPlus
instance Monoid MixedAmount where
mempty = nullmixedamt
#if !(MIN_VERSION_base(4,11,0))
mappend = (<>)
#endif
instance Num MixedAmount where instance Num MixedAmount where
fromInteger i = Mixed [fromInteger i] fromInteger i = Mixed [fromInteger i]
negate (Mixed as) = Mixed $ map negate as negate = maNegate
(+) (Mixed as) (Mixed bs) = normaliseMixedAmount $ Mixed $ as ++ bs (+) = maPlus
(*) = error' "error, mixed amounts do not support multiplication" -- PARTIAL: (*) = error' "error, mixed amounts do not support multiplication" -- PARTIAL:
abs = error' "error, mixed amounts do not support abs" abs = error' "error, mixed amounts do not support abs"
signum = error' "error, mixed amounts do not support signum" signum = error' "error, mixed amounts do not support signum"
-- | Get a mixed amount's component amounts.
amounts :: MixedAmount -> [Amount]
amounts (Mixed as) = as
-- | The empty mixed amount. -- | The empty mixed amount.
nullmixedamt :: MixedAmount nullmixedamt :: MixedAmount
@ -508,12 +530,91 @@ nullmixedamt = Mixed []
-- | A temporary value for parsed transactions which had no amount specified. -- | A temporary value for parsed transactions which had no amount specified.
missingmixedamt :: MixedAmount missingmixedamt :: MixedAmount
missingmixedamt = Mixed [missingamt] missingmixedamt = mixedAmount missingamt
-- | Convert amounts in various commodities into a normalised MixedAmount. -- | Convert amounts in various commodities into a normalised MixedAmount.
mixed :: [Amount] -> MixedAmount mixed :: [Amount] -> MixedAmount
mixed = normaliseMixedAmount . Mixed mixed = normaliseMixedAmount . Mixed
-- | Create a MixedAmount from a single Amount.
mixedAmount :: Amount -> MixedAmount
mixedAmount = Mixed . pure
-- | Add an Amount to a MixedAmount, normalising the result.
maAddAmount :: MixedAmount -> Amount -> MixedAmount
maAddAmount (Mixed as) a = normaliseMixedAmount . Mixed $ a : as
-- | Add a collection of Amounts to a MixedAmount, normalising the result.
maAddAmounts :: MixedAmount -> [Amount] -> MixedAmount
maAddAmounts (Mixed as) bs = bs `seq` normaliseMixedAmount . Mixed $ bs ++ as
-- | Negate mixed amount's quantities (and total prices, if any).
maNegate :: MixedAmount -> MixedAmount
maNegate = transformMixedAmount negate
-- | Sum two MixedAmount.
maPlus :: MixedAmount -> MixedAmount -> MixedAmount
maPlus (Mixed as) (Mixed bs) = normaliseMixedAmount . Mixed $ as ++ bs
-- | Subtract a MixedAmount from another.
maMinus :: MixedAmount -> MixedAmount -> MixedAmount
maMinus a = maPlus a . maNegate
-- | Sum a collection of MixedAmounts.
maSum :: Foldable t => t MixedAmount -> MixedAmount
maSum = foldl' maPlus nullmixedamt
-- | Divide a mixed amount's quantities (and total prices, if any) by a constant.
divideMixedAmount :: Quantity -> MixedAmount -> MixedAmount
divideMixedAmount n = transformMixedAmount (/n)
-- | Multiply a mixed amount's quantities (and total prices, if any) by a constant.
multiplyMixedAmount :: Quantity -> MixedAmount -> MixedAmount
multiplyMixedAmount n = transformMixedAmount (*n)
-- | Apply a function to a mixed amount's quantities (and its total prices, if it has any).
transformMixedAmount :: (Quantity -> Quantity) -> MixedAmount -> MixedAmount
transformMixedAmount f = mapMixedAmount (transformAmount f)
-- | Calculate the average of some mixed amounts.
averageMixedAmounts :: [MixedAmount] -> MixedAmount
averageMixedAmounts as = fromIntegral (length as) `divideMixedAmount` maSum as
-- | Is this mixed amount negative, if we can tell that unambiguously?
-- Ie when normalised, are all individual commodity amounts negative ?
isNegativeMixedAmount :: MixedAmount -> Maybe Bool
isNegativeMixedAmount m =
case amounts $ normaliseMixedAmountSquashPricesForDisplay m of
[] -> Just False
[a] -> Just $ isNegativeAmount a
as | all isNegativeAmount as -> Just True
as | not (any isNegativeAmount as) -> Just False
_ -> Nothing -- multiple amounts with different signs
-- | Does this mixed amount appear to be zero when rendered with its display precision?
-- i.e. does it have zero quantity with no price, zero quantity with a total price (which is also zero),
-- and zero quantity for each unit price?
mixedAmountLooksZero :: MixedAmount -> Bool
mixedAmountLooksZero = all amountLooksZero . amounts . normaliseMixedAmount
-- | Is this mixed amount exactly zero, ignoring its display precision?
-- i.e. does it have zero quantity with no price, zero quantity with a total price (which is also zero),
-- and zero quantity for each unit price?
mixedAmountIsZero :: MixedAmount -> Bool
mixedAmountIsZero = all amountIsZero . amounts . normaliseMixedAmount
-- | Is this mixed amount exactly zero, ignoring its display precision?
--
-- A convenient alias for mixedAmountIsZero.
maIsZero :: MixedAmount -> Bool
maIsZero = mixedAmountIsZero
-- | Is this mixed amount non-zero, ignoring its display precision?
--
-- A convenient alias for not . mixedAmountIsZero.
maIsNonZero :: MixedAmount -> Bool
maIsNonZero = not . mixedAmountIsZero
-- | Simplify a mixed amount's component amounts: -- | Simplify a mixed amount's component amounts:
-- --
-- * amounts in the same commodity are combined unless they have different prices or total prices -- * amounts in the same commodity are combined unless they have different prices or total prices
@ -581,10 +682,6 @@ sumSimilarAmountsUsingFirstPrice a b = (a + b){aprice=p}
-- sumSimilarAmountsNotingPriceDifference [] = nullamt -- sumSimilarAmountsNotingPriceDifference [] = nullamt
-- sumSimilarAmountsNotingPriceDifference as = undefined -- sumSimilarAmountsNotingPriceDifference as = undefined
-- | Get a mixed amount's component amounts.
amounts :: MixedAmount -> [Amount]
amounts (Mixed as) = as
-- | Filter a mixed amount's component amounts by a predicate. -- | Filter a mixed amount's component amounts by a predicate.
filterMixedAmount :: (Amount -> Bool) -> MixedAmount -> MixedAmount filterMixedAmount :: (Amount -> Bool) -> MixedAmount -> MixedAmount
filterMixedAmount p (Mixed as) = Mixed $ filter p as filterMixedAmount p (Mixed as) = Mixed $ filter p as
@ -609,42 +706,6 @@ mapMixedAmount f (Mixed as) = Mixed $ map f as
mixedAmountCost :: MixedAmount -> MixedAmount mixedAmountCost :: MixedAmount -> MixedAmount
mixedAmountCost = mapMixedAmount amountCost mixedAmountCost = mapMixedAmount amountCost
-- | Divide a mixed amount's quantities (and total prices, if any) by a constant.
divideMixedAmount :: Quantity -> MixedAmount -> MixedAmount
divideMixedAmount n = mapMixedAmount (divideAmount n)
-- | Multiply a mixed amount's quantities (and total prices, if any) by a constant.
multiplyMixedAmount :: Quantity -> MixedAmount -> MixedAmount
multiplyMixedAmount n = mapMixedAmount (multiplyAmount n)
-- | Calculate the average of some mixed amounts.
averageMixedAmounts :: [MixedAmount] -> MixedAmount
averageMixedAmounts [] = 0
averageMixedAmounts as = fromIntegral (length as) `divideMixedAmount` sum as
-- | Is this mixed amount negative, if we can tell that unambiguously?
-- Ie when normalised, are all individual commodity amounts negative ?
isNegativeMixedAmount :: MixedAmount -> Maybe Bool
isNegativeMixedAmount m =
case amounts $ normaliseMixedAmountSquashPricesForDisplay m of
[] -> Just False
[a] -> Just $ isNegativeAmount a
as | all isNegativeAmount as -> Just True
as | not (any isNegativeAmount as) -> Just False
_ -> Nothing -- multiple amounts with different signs
-- | Does this mixed amount appear to be zero when rendered with its display precision?
-- i.e. does it have zero quantity with no price, zero quantity with a total price (which is also zero),
-- and zero quantity for each unit price?
mixedAmountLooksZero :: MixedAmount -> Bool
mixedAmountLooksZero = all amountLooksZero . amounts . normaliseMixedAmountSquashPricesForDisplay
-- | Is this mixed amount exactly to be zero, ignoring its display precision?
-- i.e. does it have zero quantity with no price, zero quantity with a total price (which is also zero),
-- and zero quantity for each unit price?
mixedAmountIsZero :: MixedAmount -> Bool
mixedAmountIsZero = all amountIsZero . amounts . normaliseMixedAmountSquashPricesForDisplay
-- -- | 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.
@ -888,52 +949,52 @@ tests_Amount = tests "Amount" [
,tests "MixedAmount" [ ,tests "MixedAmount" [
test "adding mixed amounts to zero, the commodity and amount style are preserved" $ test "adding mixed amounts to zero, the commodity and amount style are preserved" $
sum (map (Mixed . (:[])) maSum (map mixedAmount
[usd 1.25 [usd 1.25
,usd (-1) `withPrecision` Precision 3 ,usd (-1) `withPrecision` Precision 3
,usd (-0.25) ,usd (-0.25)
]) ])
@?= Mixed [usd 0 `withPrecision` Precision 3] @?= Mixed [usd 0 `withPrecision` Precision 3]
,test "adding mixed amounts with total prices" $ do ,test "adding mixed amounts with total prices" $ do
sum (map (Mixed . (:[])) maSum (map mixedAmount
[usd 1 @@ eur 1 [usd 1 @@ eur 1
,usd (-2) @@ eur 1 ,usd (-2) @@ eur 1
]) ])
@?= Mixed [usd (-1) @@ eur 2 ] @?= Mixed [usd (-1) @@ eur 2 ]
,test "showMixedAmount" $ do ,test "showMixedAmount" $ do
showMixedAmount (Mixed [usd 1]) @?= "$1.00" showMixedAmount (mixedAmount (usd 1)) @?= "$1.00"
showMixedAmount (Mixed [usd 1 `at` eur 2]) @?= "$1.00 @ €2.00" showMixedAmount (mixedAmount (usd 1 `at` eur 2)) @?= "$1.00 @ €2.00"
showMixedAmount (Mixed [usd 0]) @?= "0" showMixedAmount (mixedAmount (usd 0)) @?= "0"
showMixedAmount (Mixed []) @?= "0" showMixedAmount nullmixedamt @?= "0"
showMixedAmount missingmixedamt @?= "" showMixedAmount missingmixedamt @?= ""
,test "showMixedAmountWithoutPrice" $ do ,test "showMixedAmountWithoutPrice" $ do
let a = usd 1 `at` eur 2 let a = usd 1 `at` eur 2
showMixedAmountWithoutPrice False (Mixed [a]) @?= "$1.00" showMixedAmountWithoutPrice False (mixedAmount (a)) @?= "$1.00"
showMixedAmountWithoutPrice False (Mixed [a, -a]) @?= "0" showMixedAmountWithoutPrice False (mixed [a, -a]) @?= "0"
,tests "normaliseMixedAmount" [ ,tests "normaliseMixedAmount" [
test "a missing amount overrides any other amounts" $ test "a missing amount overrides any other amounts" $
normaliseMixedAmount (Mixed [usd 1, missingamt]) @?= missingmixedamt amounts (normaliseMixedAmount $ mixed [usd 1, missingamt]) @?= [missingamt]
,test "unpriced same-commodity amounts are combined" $ ,test "unpriced same-commodity amounts are combined" $
normaliseMixedAmount (Mixed [usd 0, usd 2]) @?= Mixed [usd 2] amounts (normaliseMixedAmount $ mixed [usd 0, usd 2]) @?= [usd 2]
,test "amounts with same unit price are combined" $ ,test "amounts with same unit price are combined" $
normaliseMixedAmount (Mixed [usd 1 `at` eur 1, usd 1 `at` eur 1]) @?= Mixed [usd 2 `at` eur 1] amounts (normaliseMixedAmount $ mixed [usd 1 `at` eur 1, usd 1 `at` eur 1]) @?= [usd 2 `at` eur 1]
,test "amounts with different unit prices are not combined" $ ,test "amounts with different unit prices are not combined" $
normaliseMixedAmount (Mixed [usd 1 `at` eur 1, usd 1 `at` eur 2]) @?= Mixed [usd 1 `at` eur 1, usd 1 `at` eur 2] amounts (normaliseMixedAmount $ mixed [usd 1 `at` eur 1, usd 1 `at` eur 2]) @?= [usd 1 `at` eur 1, usd 1 `at` eur 2]
,test "amounts with total prices are combined" $ ,test "amounts with total prices are combined" $
normaliseMixedAmount (Mixed [usd 1 @@ eur 1, usd 1 @@ eur 1]) @?= Mixed [usd 2 @@ eur 2] amounts (normaliseMixedAmount $ mixed [usd 1 @@ eur 1, usd 1 @@ eur 1]) @?= [usd 2 @@ eur 2]
] ]
,test "normaliseMixedAmountSquashPricesForDisplay" $ do ,test "normaliseMixedAmountSquashPricesForDisplay" $ do
normaliseMixedAmountSquashPricesForDisplay (Mixed []) @?= Mixed [nullamt] amounts (normaliseMixedAmountSquashPricesForDisplay nullmixedamt) @?= [nullamt]
assertBool "" $ mixedAmountLooksZero $ normaliseMixedAmountSquashPricesForDisplay assertBool "" $ mixedAmountLooksZero $ normaliseMixedAmountSquashPricesForDisplay
(Mixed [usd 10 (mixed [usd 10
,usd 10 @@ eur 7 ,usd 10 @@ eur 7
,usd (-10) ,usd (-10)
,usd (-10) @@ eur 7 ,usd (-10) @@ eur (-7)
]) ])
] ]

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

@ -524,7 +524,7 @@ filterTransactionAmounts q t@Transaction{tpostings=ps} = t{tpostings=map (filter
-- | Filter out all parts of this posting's amount which do not match the query. -- | Filter out all parts of this posting's amount which do not match the query.
filterPostingAmount :: Query -> Posting -> Posting filterPostingAmount :: Query -> Posting -> Posting
filterPostingAmount q p@Posting{pamount=Mixed as} = p{pamount=Mixed $ filter (q `matchesAmount`) as} filterPostingAmount q p@Posting{pamount=as} = p{pamount=filterMixedAmount (q `matchesAmount`) as}
filterTransactionPostings :: Query -> Transaction -> Transaction filterTransactionPostings :: Query -> Transaction -> Transaction
filterTransactionPostings q t@Transaction{tpostings=ps} = t{tpostings=filter (q `matchesPosting`) ps} filterTransactionPostings q t@Transaction{tpostings=ps} = t{tpostings=filter (q `matchesPosting`) ps}
@ -765,14 +765,14 @@ withRunningBalance f = ask >>= lift . lift . f
-- | Get this account's current exclusive running balance. -- | Get this account's current exclusive running balance.
getRunningBalanceB :: AccountName -> Balancing s MixedAmount getRunningBalanceB :: AccountName -> Balancing s MixedAmount
getRunningBalanceB acc = withRunningBalance $ \BalancingState{bsBalances} -> do getRunningBalanceB acc = withRunningBalance $ \BalancingState{bsBalances} -> do
fromMaybe 0 <$> H.lookup bsBalances acc fromMaybe nullmixedamt <$> H.lookup bsBalances acc
-- | Add this amount to this account's exclusive running balance. -- | Add this amount to this account's exclusive running balance.
-- Returns the new running balance. -- Returns the new running balance.
addToRunningBalanceB :: AccountName -> MixedAmount -> Balancing s MixedAmount addToRunningBalanceB :: AccountName -> MixedAmount -> Balancing s MixedAmount
addToRunningBalanceB acc amt = withRunningBalance $ \BalancingState{bsBalances} -> do addToRunningBalanceB acc amt = withRunningBalance $ \BalancingState{bsBalances} -> do
old <- fromMaybe 0 <$> H.lookup bsBalances acc old <- fromMaybe nullmixedamt <$> H.lookup bsBalances acc
let new = old + amt let new = maPlus old amt
H.insert bsBalances acc new H.insert bsBalances acc new
return new return new
@ -780,9 +780,9 @@ addToRunningBalanceB acc amt = withRunningBalance $ \BalancingState{bsBalances}
-- Returns the change in exclusive running balance. -- Returns the change in exclusive running balance.
setRunningBalanceB :: AccountName -> MixedAmount -> Balancing s MixedAmount setRunningBalanceB :: AccountName -> MixedAmount -> Balancing s MixedAmount
setRunningBalanceB acc amt = withRunningBalance $ \BalancingState{bsBalances} -> do setRunningBalanceB acc amt = withRunningBalance $ \BalancingState{bsBalances} -> do
old <- fromMaybe 0 <$> H.lookup bsBalances acc old <- fromMaybe nullmixedamt <$> H.lookup bsBalances acc
H.insert bsBalances acc amt H.insert bsBalances acc amt
return $ amt - old return $ maMinus amt old
-- | Set this account's exclusive running balance to whatever amount -- | Set this account's exclusive running balance to whatever amount
-- makes its *inclusive* running balance (the sum of exclusive running -- makes its *inclusive* running balance (the sum of exclusive running
@ -790,13 +790,13 @@ setRunningBalanceB acc amt = withRunningBalance $ \BalancingState{bsBalances} ->
-- Returns the change in exclusive running balance. -- Returns the change in exclusive running balance.
setInclusiveRunningBalanceB :: AccountName -> MixedAmount -> Balancing s MixedAmount setInclusiveRunningBalanceB :: AccountName -> MixedAmount -> Balancing s MixedAmount
setInclusiveRunningBalanceB acc newibal = withRunningBalance $ \BalancingState{bsBalances} -> do setInclusiveRunningBalanceB acc newibal = withRunningBalance $ \BalancingState{bsBalances} -> do
oldebal <- fromMaybe 0 <$> H.lookup bsBalances acc oldebal <- fromMaybe nullmixedamt <$> H.lookup bsBalances acc
allebals <- H.toList bsBalances allebals <- H.toList bsBalances
let subsibal = -- sum of any subaccounts' running balances let subsibal = -- sum of any subaccounts' running balances
sum $ map snd $ filter ((acc `isAccountNamePrefixOf`).fst) allebals maSum . map snd $ filter ((acc `isAccountNamePrefixOf`).fst) allebals
let newebal = newibal - subsibal let newebal = maMinus newibal subsibal
H.insert bsBalances acc newebal H.insert bsBalances acc newebal
return $ newebal - oldebal return $ maMinus newebal oldebal
-- | Update (overwrite) this transaction in the balancing state. -- | Update (overwrite) this transaction in the balancing state.
updateTransactionB :: Transaction -> Balancing s () updateTransactionB :: Transaction -> Balancing s ()
@ -897,21 +897,15 @@ addOrAssignAmountAndCheckAssertionB p@Posting{paccount=acc, pamount=amt, pbalanc
return p return p
-- no explicit posting amount, but there is a balance assignment -- no explicit posting amount, but there is a balance assignment
-- TODO this doesn't yet handle inclusive assignments right, #1207
| Just BalanceAssertion{baamount,batotal,bainclusive} <- mba = do | Just BalanceAssertion{baamount,batotal,bainclusive} <- mba = do
(diff,newbal) <- case batotal of newbal <- if batotal
-- a total balance assignment (==, all commodities) -- a total balance assignment (==, all commodities)
True -> do then return $ mixedAmount baamount
let newbal = Mixed [baamount] -- a partial balance assignment (=, one commodity)
diff <- (if bainclusive then setInclusiveRunningBalanceB else setRunningBalanceB) acc newbal else do
return (diff,newbal) oldbalothercommodities <- filterMixedAmount ((acommodity baamount /=) . acommodity) <$> getRunningBalanceB acc
-- a partial balance assignment (=, one commodity) return $ maAddAmount oldbalothercommodities baamount
False -> do diff <- (if bainclusive then setInclusiveRunningBalanceB else setRunningBalanceB) acc newbal
oldbalothercommodities <- filterMixedAmount ((acommodity baamount /=) . acommodity) <$> getRunningBalanceB acc
let assignedbalthiscommodity = Mixed [baamount]
newbal = oldbalothercommodities + assignedbalthiscommodity
diff <- (if bainclusive then setInclusiveRunningBalanceB else setRunningBalanceB) acc newbal
return (diff,newbal)
let p' = p{pamount=diff, poriginal=Just $ originalPosting p} let p' = p{pamount=diff, poriginal=Just $ originalPosting p}
whenM (R.reader bsAssrt) $ checkBalanceAssertionB p' newbal whenM (R.reader bsAssrt) $ checkBalanceAssertionB p' newbal
return p' return p'
@ -961,9 +955,9 @@ checkBalanceAssertionOneCommodityB p@Posting{paccount=assertedacct} assertedamt
-- sum the running balances of this account and any of its subaccounts seen so far -- sum the running balances of this account and any of its subaccounts seen so far
withRunningBalance $ \BalancingState{bsBalances} -> withRunningBalance $ \BalancingState{bsBalances} ->
H.foldM H.foldM
(\ibal (acc, amt) -> return $ ibal + (\ibal (acc, amt) -> return $
if assertedacct==acc || assertedacct `isAccountNamePrefixOf` acc then amt else 0) if assertedacct==acc || assertedacct `isAccountNamePrefixOf` acc then maPlus ibal amt else ibal)
0 nullmixedamt
bsBalances bsBalances
else return actualbal else return actualbal
let let
@ -1153,7 +1147,7 @@ canonicalStyle a b = a{asprecision=prec, asdecimalpoint=decmark, asdigitgroups=m
-- fixtransaction t@Transaction{tdate=d, tpostings=ps} = t{tpostings=map fixposting ps} -- fixtransaction t@Transaction{tdate=d, tpostings=ps} = t{tpostings=map fixposting ps}
-- where -- where
-- 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 = mapMixedAmount fixamount
-- fixamount = fixprice -- fixamount = fixprice
-- fixprice a@Amount{price=Just _} = a -- fixprice a@Amount{price=Just _} = a
-- fixprice a@Amount{commodity=c} = a{price=maybe Nothing (Just . UnitPrice) $ journalPriceDirectiveFor j d c} -- fixprice a@Amount{commodity=c} = a{price=maybe Nothing (Just . UnitPrice) $ journalPriceDirectiveFor j d c}
@ -1182,8 +1176,8 @@ journalInferMarketPricesFromTransactions j =
postingInferredmarketPrice :: Posting -> Maybe MarketPrice postingInferredmarketPrice :: Posting -> Maybe MarketPrice
postingInferredmarketPrice p@Posting{pamount} = postingInferredmarketPrice p@Posting{pamount} =
-- convert any total prices to unit prices -- convert any total prices to unit prices
case mixedAmountTotalPriceToUnitPrice pamount of case amounts $ mixedAmountTotalPriceToUnitPrice pamount of
Mixed ( Amount{acommodity=fromcomm, aprice = Just (UnitPrice Amount{acommodity=tocomm, aquantity=rate})} : _) -> Amount{acommodity=fromcomm, aprice = Just (UnitPrice Amount{acommodity=tocomm, aquantity=rate})}:_ ->
Just MarketPrice { Just MarketPrice {
mpdate = postingDate p mpdate = postingDate p
,mpfrom = fromcomm ,mpfrom = fromcomm
@ -1561,7 +1555,7 @@ tests_Journal = tests "Journal" [
]} ]}
assertRight ej assertRight ej
let Right j = ej let Right j = ej
(jtxns j & head & tpostings & head & pamount) @?= Mixed [num 1] (jtxns j & head & tpostings & head & pamount) @?= mixedAmount (num 1)
,test "same-day-1" $ do ,test "same-day-1" $ do
assertRight $ journalBalanceTransactions True $ assertRight $ journalBalanceTransactions True $

12
hledger-lib/Hledger/Data/Posting.hs
View File

@ -75,15 +75,16 @@ import Control.Monad (foldM)
import Data.Foldable (asum) import Data.Foldable (asum)
import Data.List.Extra (nubSort) import Data.List.Extra (nubSort)
import qualified Data.Map as M import qualified Data.Map as M
import Data.Maybe import Data.Maybe (fromMaybe, isJust)
import Data.MemoUgly (memo) import Data.MemoUgly (memo)
import Data.List (foldl')
#if !(MIN_VERSION_base(4,11,0)) #if !(MIN_VERSION_base(4,11,0))
import Data.Monoid import Data.Monoid
#endif #endif
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Time.Calendar import Data.Time.Calendar (Day)
import Safe import Safe (headDef)
import Hledger.Utils import Hledger.Utils
import Hledger.Data.Types import Hledger.Data.Types
@ -197,12 +198,11 @@ accountNamesFromPostings :: [Posting] -> [AccountName]
accountNamesFromPostings = nubSort . map paccount accountNamesFromPostings = nubSort . map paccount
sumPostings :: [Posting] -> MixedAmount sumPostings :: [Posting] -> MixedAmount
sumPostings = sumStrict . map pamount sumPostings = foldl' (\amt p -> maPlus amt $ pamount p) nullmixedamt
-- | Remove all prices of a posting -- | Remove all prices of a posting
removePrices :: Posting -> Posting removePrices :: Posting -> Posting
removePrices p = p{ pamount = Mixed $ remove <$> amounts (pamount p) } removePrices = postingTransformAmount (mapMixedAmount $ \a -> a{aprice=Nothing})
where remove a = a { aprice = Nothing }
-- | Get a posting's (primary) date - it's own primary date if specified, -- | Get a posting's (primary) date - it's own primary date if specified,
-- otherwise the parent transaction's primary date, or the null date if -- otherwise the parent transaction's primary date, or the null date if

2
hledger-lib/Hledger/Data/Timeclock.hs
View File

@ -121,7 +121,7 @@ entryFromTimeclockInOut i o
showtime = take 5 . show showtime = take 5 . show
hours = elapsedSeconds (toutc otime) (toutc itime) / 3600 where toutc = localTimeToUTC utc hours = elapsedSeconds (toutc otime) (toutc itime) / 3600 where toutc = localTimeToUTC utc
acctname = tlaccount i acctname = tlaccount i
amount = Mixed [hrs hours] amount = mixedAmount $ hrs hours
ps = [posting{paccount=acctname, pamount=amount, ptype=VirtualPosting, ptransaction=Just t}] ps = [posting{paccount=acctname, pamount=amount, ptype=VirtualPosting, ptransaction=Just t}]

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

@ -471,9 +471,9 @@ inferBalancingAmount styles t@Transaction{tpostings=ps}
in Right (t{tpostings=map fst psandinferredamts}, inferredacctsandamts) in Right (t{tpostings=map fst psandinferredamts}, inferredacctsandamts)
where where
(amountfulrealps, amountlessrealps) = partition hasAmount (realPostings t) (amountfulrealps, amountlessrealps) = partition hasAmount (realPostings t)
realsum = sumStrict $ map pamount amountfulrealps realsum = sumPostings amountfulrealps
(amountfulbvps, amountlessbvps) = partition hasAmount (balancedVirtualPostings t) (amountfulbvps, amountlessbvps) = partition hasAmount (balancedVirtualPostings t)
bvsum = sumStrict $ map pamount amountfulbvps bvsum = sumPostings amountfulbvps
inferamount :: Posting -> (Posting, Maybe MixedAmount) inferamount :: Posting -> (Posting, Maybe MixedAmount)
inferamount p = inferamount p =
@ -490,7 +490,7 @@ inferBalancingAmount styles t@Transaction{tpostings=ps}
-- Inferred amounts are converted to cost. -- Inferred amounts are converted to cost.
-- Also ensure the new amount has the standard style for its commodity -- Also ensure the new amount has the standard style for its commodity
-- (since the main amount styling pass happened before this balancing pass); -- (since the main amount styling pass happened before this balancing pass);
a' = styleMixedAmount styles $ normaliseMixedAmount $ mixedAmountCost (-a) a' = styleMixedAmount styles . normaliseMixedAmount . mixedAmountCost $ maNegate a
-- | Infer prices for this transaction's posting amounts, if needed to make -- | Infer prices for this transaction's posting amounts, if needed to make
-- the postings balance, and if possible. This is done once for the real -- the postings balance, and if possible. This is done once for the real
@ -542,17 +542,16 @@ priceInferrerFor :: Transaction -> PostingType -> (Posting -> Posting)
priceInferrerFor t pt = inferprice priceInferrerFor t pt = inferprice
where where
postings = filter ((==pt).ptype) $ tpostings t postings = filter ((==pt).ptype) $ tpostings t
pmixedamounts = map pamount postings pamounts = concatMap (amounts . pamount) postings
pamounts = concatMap amounts pmixedamounts
pcommodities = map acommodity pamounts pcommodities = map acommodity pamounts
sumamounts = amounts $ sumStrict pmixedamounts -- sum normalises to one amount per commodity & price sumamounts = amounts $ sumPostings postings -- sum normalises to one amount per commodity & price
sumcommodities = map acommodity sumamounts sumcommodities = map acommodity sumamounts
sumprices = filter (/=Nothing) $ map aprice sumamounts sumprices = filter (/=Nothing) $ map aprice sumamounts
caninferprices = length sumcommodities == 2 && null sumprices caninferprices = length sumcommodities == 2 && null sumprices
inferprice p@Posting{pamount=Mixed [a]} inferprice p@Posting{pamount=Mixed [a]}
| caninferprices && ptype p == pt && acommodity a == fromcommodity | caninferprices && ptype p == pt && acommodity a == fromcommodity
= p{pamount=Mixed [a{aprice=Just conversionprice}], poriginal=Just $ originalPosting p} = p{pamount=mixedAmount $ a{aprice=Just conversionprice}, poriginal=Just $ originalPosting p}
where where
fromcommodity = head $ filter (`elem` sumcommodities) pcommodities -- these heads are ugly but should be safe fromcommodity = head $ filter (`elem` sumcommodities) pcommodities -- these heads are ugly but should be safe
totalpricesign = if aquantity a < 0 then negate else id totalpricesign = if aquantity a < 0 then negate else id

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

@ -120,14 +120,14 @@ tmPostingRuleToFunction querytxt pr =
-- Approach 1: convert to a unit price and increase the display precision slightly -- Approach 1: convert to a unit price and increase the display precision slightly
-- Mixed as = dbg6 "multipliedamount" $ n `multiplyMixedAmount` mixedAmountTotalPriceToUnitPrice matchedamount -- Mixed as = dbg6 "multipliedamount" $ n `multiplyMixedAmount` mixedAmountTotalPriceToUnitPrice matchedamount
-- Approach 2: multiply the total price (keeping it positive) as well as the quantity -- Approach 2: multiply the total price (keeping it positive) as well as the quantity
Mixed as = dbg6 "multipliedamount" $ n `multiplyMixedAmount` matchedamount as = dbg6 "multipliedamount" $ n `multiplyMixedAmount` matchedamount
in in
case acommodity pramount of case acommodity pramount of
"" -> Mixed as "" -> as
-- TODO multipliers with commodity symbols are not yet a documented feature. -- TODO multipliers with commodity symbols are not yet a documented feature.
-- For now: in addition to multiplying the quantity, it also replaces the -- For now: in addition to multiplying the quantity, it also replaces the
-- matched amount's commodity, display style, and price with those of the posting rule. -- matched amount's commodity, display style, and price with those of the posting rule.
c -> Mixed [a{acommodity = c, astyle = astyle pramount, aprice = aprice pramount} | a <- as] c -> mapMixedAmount (\a -> a{acommodity = c, astyle = astyle pramount, aprice = aprice pramount}) as
postingRuleMultiplier :: TMPostingRule -> Maybe Quantity postingRuleMultiplier :: TMPostingRule -> Maybe Quantity
postingRuleMultiplier p = postingRuleMultiplier p =

6
hledger-lib/Hledger/Read/Common.hs
View File

@ -729,7 +729,7 @@ spaceandamountormissingp :: JournalParser m MixedAmount
spaceandamountormissingp = spaceandamountormissingp =
option missingmixedamt $ try $ do option missingmixedamt $ try $ do
lift $ skipNonNewlineSpaces1 lift $ skipNonNewlineSpaces1
Mixed . (:[]) <$> amountp mixedAmount <$> amountp
-- | Parse a single-commodity amount, with optional symbol on the left -- | Parse a single-commodity amount, with optional symbol on the left
-- or right, followed by, in any order: an optional transaction price, -- or right, followed by, in any order: an optional transaction price,
@ -855,7 +855,7 @@ amountp' s =
-- | Parse a mixed amount from a string, or get an error. -- | Parse a mixed amount from a string, or get an error.
mamountp' :: String -> MixedAmount mamountp' :: String -> MixedAmount
mamountp' = Mixed . (:[]) . amountp' mamountp' = mixedAmount . amountp'
-- | Parse a minus or plus sign followed by zero or more spaces, -- | Parse a minus or plus sign followed by zero or more spaces,
-- or nothing, returning a function that negates or does nothing. -- or nothing, returning a function that negates or does nothing.
@ -1560,7 +1560,7 @@ tests_Common = tests "Common" [
assertParseError p "1.5555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555" "" assertParseError p "1.5555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555" ""
,tests "spaceandamountormissingp" [ ,tests "spaceandamountormissingp" [
test "space and amount" $ assertParseEq spaceandamountormissingp " $47.18" (Mixed [usd 47.18]) test "space and amount" $ assertParseEq spaceandamountormissingp " $47.18" (mixedAmount $ usd 47.18)
,test "empty string" $ assertParseEq spaceandamountormissingp "" missingmixedamt ,test "empty string" $ assertParseEq spaceandamountormissingp "" missingmixedamt
-- ,test "just space" $ assertParseEq spaceandamountormissingp " " missingmixedamt -- XXX should it ? -- ,test "just space" $ assertParseEq spaceandamountormissingp " " missingmixedamt -- XXX should it ?
-- ,test "just amount" $ assertParseError spaceandamountormissingp "$47.18" "" -- succeeds, consuming nothing -- ,test "just amount" $ assertParseError spaceandamountormissingp "$47.18" "" -- succeeds, consuming nothing

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

@ -995,7 +995,7 @@ getAmount rules record currency p1IsVirtual n =
, let a = parseAmount rules record currency v , let a = parseAmount rules record currency v
-- With amount/amount-in/amount-out, in posting 2, -- With amount/amount-in/amount-out, in posting 2,
-- flip the sign and convert to cost, as they did before 1.17 -- flip the sign and convert to cost, as they did before 1.17
, let a' = if f `elem` unnumberedfieldnames && n==2 then mixedAmountCost (-a) else a , let a' = if f `elem` unnumberedfieldnames && n==2 then mixedAmountCost (maNegate a) else a
] ]
-- if any of the numbered field names are present, discard all the unnumbered ones -- if any of the numbered field names are present, discard all the unnumbered ones
@ -1013,7 +1013,7 @@ getAmount rules record currency p1IsVirtual n =
in case -- dbg0 ("amounts for posting "++show n) in case -- dbg0 ("amounts for posting "++show n)
assignments'' of assignments'' of
[] -> Nothing [] -> Nothing
[(f,a)] | "-out" `T.isSuffixOf` f -> Just (-a) -- for -out fields, flip the sign [(f,a)] | "-out" `T.isSuffixOf` f -> Just (maNegate a) -- for -out fields, flip the sign
[(_,a)] -> Just a [(_,a)] -> Just a
fs -> error' . T.unpack . T.unlines $ [ -- PARTIAL: fs -> error' . T.unpack . T.unlines $ [ -- PARTIAL:
"multiple non-zero amounts or multiple zero amounts assigned," "multiple non-zero amounts or multiple zero amounts assigned,"
@ -1048,7 +1048,7 @@ getBalance rules record currency n = do
-- The whole CSV record is provided for the error message. -- The whole CSV record is provided for the error message.
parseAmount :: CsvRules -> CsvRecord -> Text -> Text -> MixedAmount parseAmount :: CsvRules -> CsvRecord -> Text -> Text -> MixedAmount
parseAmount rules record currency s = parseAmount rules record currency s =
either mkerror (Mixed . (:[])) $ -- PARTIAL: either mkerror mixedAmount $ -- PARTIAL:
runParser (evalStateT (amountp <* eof) journalparsestate) "" $ runParser (evalStateT (amountp <* eof) journalparsestate) "" $
currency <> simplifySign s currency <> simplifySign s
where where

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

@ -711,7 +711,7 @@ postingp mTransactionYear = do
return (status, account) return (status, account)
let (ptype, account') = (accountNamePostingType account, textUnbracket account) let (ptype, account') = (accountNamePostingType account, textUnbracket account)
lift skipNonNewlineSpaces lift skipNonNewlineSpaces
amount <- option missingmixedamt $ Mixed . (:[]) <$> amountp amount <- option missingmixedamt $ mixedAmount <$> amountp
lift skipNonNewlineSpaces lift skipNonNewlineSpaces
massertion <- optional balanceassertionp massertion <- optional balanceassertionp
lift skipNonNewlineSpaces lift skipNonNewlineSpaces

18
hledger-lib/Hledger/Reports/AccountTransactionsReport.hs
View File

@ -1,4 +1,6 @@
{-# LANGUAGE OverloadedStrings, RecordWildCards, FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-| {-|
An account-centric transactions report. An account-centric transactions report.
@ -15,12 +17,12 @@ module Hledger.Reports.AccountTransactionsReport (
) )
where where
import Data.List import Data.List (mapAccumL, nub, partition, sortBy)
import Data.Ord import Data.Ord (comparing)
import Data.Maybe import Data.Maybe (catMaybes, fromMaybe)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Time.Calendar import Data.Time.Calendar (Day)
import Hledger.Data import Hledger.Data
import Hledger.Query import Hledger.Query
@ -145,7 +147,7 @@ accountTransactionsReport rspec@ReportSpec{rsOpts=ropts} j reportq thisacctq = i
filtertxns = txn_dates_ ropts filtertxns = txn_dates_ ropts
items = reverse $ items = reverse $
accountTransactionsReportItems reportq' thisacctq startbal negate $ accountTransactionsReportItems reportq' thisacctq startbal maNegate $
(if filtertxns then filter (reportq' `matchesTransaction`) else id) $ (if filtertxns then filter (reportq' `matchesTransaction`) else id) $
ts5 ts5
@ -179,8 +181,8 @@ accountTransactionsReportItem reportq thisacctq signfn bal torig = balItem
otheracctstr | thisacctq == None = summarisePostingAccounts reportps -- no current account ? summarise all matched postings otheracctstr | thisacctq == None = summarisePostingAccounts reportps -- no current account ? summarise all matched postings
| numotheraccts == 0 = summarisePostingAccounts thisacctps -- only postings to current account ? summarise those | numotheraccts == 0 = summarisePostingAccounts thisacctps -- only postings to current account ? summarise those
| otherwise = summarisePostingAccounts otheracctps -- summarise matched postings to other account(s) | otherwise = summarisePostingAccounts otheracctps -- summarise matched postings to other account(s)
a = signfn $ negate $ sum $ map pamount thisacctps a = signfn . maNegate $ sumPostings thisacctps
b = bal + a b = bal `maPlus` a
-- | What is the transaction's date in the context of a particular account -- | What is the transaction's date in the context of a particular account
-- (specified with a query) and report query, as in an account register ? -- (specified with a query) and report query, as in an account register ?

22
hledger-lib/Hledger/Reports/BalanceReport.hs
View File

@ -112,7 +112,7 @@ tests_BalanceReport = tests "BalanceReport" [
tests "balanceReport" [ tests "balanceReport" [
test "no args, null journal" $ test "no args, null journal" $
(defreportspec, nulljournal) `gives` ([], 0) (defreportspec, nulljournal) `gives` ([], nullmixedamt)
,test "no args, sample journal" $ ,test "no args, sample journal" $
(defreportspec, samplejournal) `gives` (defreportspec, samplejournal) `gives`
@ -125,7 +125,7 @@ tests_BalanceReport = tests "BalanceReport" [
,("income:gifts","income:gifts",0, mamountp' "$-1.00") ,("income:gifts","income:gifts",0, mamountp' "$-1.00")
,("income:salary","income:salary",0, mamountp' "$-1.00") ,("income:salary","income:salary",0, mamountp' "$-1.00")
], ],
Mixed [usd 0]) mixedAmount (usd 0))
,test "with --tree" $ ,test "with --tree" $
(defreportspec{rsOpts=defreportopts{accountlistmode_=ALTree}}, samplejournal) `gives` (defreportspec{rsOpts=defreportopts{accountlistmode_=ALTree}}, samplejournal) `gives`
@ -142,7 +142,7 @@ tests_BalanceReport = tests "BalanceReport" [
,("income:gifts","gifts",1, mamountp' "$-1.00") ,("income:gifts","gifts",1, mamountp' "$-1.00")
,("income:salary","salary",1, mamountp' "$-1.00") ,("income:salary","salary",1, mamountp' "$-1.00")
], ],
Mixed [usd 0]) mixedAmount (usd 0))
,test "with --depth=N" $ ,test "with --depth=N" $
(defreportspec{rsOpts=defreportopts{depth_=Just 1}}, samplejournal) `gives` (defreportspec{rsOpts=defreportopts{depth_=Just 1}}, samplejournal) `gives`
@ -150,7 +150,7 @@ tests_BalanceReport = tests "BalanceReport" [
("expenses", "expenses", 0, mamountp' "$2.00") ("expenses", "expenses", 0, mamountp' "$2.00")
,("income", "income", 0, mamountp' "$-2.00") ,("income", "income", 0, mamountp' "$-2.00")
], ],
Mixed [usd 0]) mixedAmount (usd 0))
,test "with depth:N" $ ,test "with depth:N" $
(defreportspec{rsQuery=Depth 1}, samplejournal) `gives` (defreportspec{rsQuery=Depth 1}, samplejournal) `gives`
@ -158,11 +158,11 @@ tests_BalanceReport = tests "BalanceReport" [
("expenses", "expenses", 0, mamountp' "$2.00") ("expenses", "expenses", 0, mamountp' "$2.00")
,("income", "income", 0, mamountp' "$-2.00") ,("income", "income", 0, mamountp' "$-2.00")
], ],
Mixed [usd 0]) mixedAmount (usd 0))
,test "with date:" $ ,test "with date:" $
(defreportspec{rsQuery=Date $ DateSpan (Just $ fromGregorian 2009 01 01) (Just $ fromGregorian 2010 01 01)}, samplejournal2) `gives` (defreportspec{rsQuery=Date $ DateSpan (Just $ fromGregorian 2009 01 01) (Just $ fromGregorian 2010 01 01)}, samplejournal2) `gives`
([], 0) ([], nullmixedamt)
,test "with date2:" $ ,test "with date2:" $
(defreportspec{rsQuery=Date2 $ DateSpan (Just $ fromGregorian 2009 01 01) (Just $ fromGregorian 2010 01 01)}, samplejournal2) `gives` (defreportspec{rsQuery=Date2 $ DateSpan (Just $ fromGregorian 2009 01 01) (Just $ fromGregorian 2010 01 01)}, samplejournal2) `gives`
@ -170,7 +170,7 @@ tests_BalanceReport = tests "BalanceReport" [
("assets:bank:checking","assets:bank:checking",0,mamountp' "$1.00") ("assets:bank:checking","assets:bank:checking",0,mamountp' "$1.00")
,("income:salary","income:salary",0,mamountp' "$-1.00") ,("income:salary","income:salary",0,mamountp' "$-1.00")
], ],
Mixed [usd 0]) mixedAmount (usd 0))
,test "with desc:" $ ,test "with desc:" $
(defreportspec{rsQuery=Desc $ toRegexCI' "income"}, samplejournal) `gives` (defreportspec{rsQuery=Desc $ toRegexCI' "income"}, samplejournal) `gives`
@ -178,7 +178,7 @@ tests_BalanceReport = tests "BalanceReport" [
("assets:bank:checking","assets:bank:checking",0,mamountp' "$1.00") ("assets:bank:checking","assets:bank:checking",0,mamountp' "$1.00")
,("income:salary","income:salary",0, mamountp' "$-1.00") ,("income:salary","income:salary",0, mamountp' "$-1.00")
], ],
Mixed [usd 0]) mixedAmount (usd 0))
,test "with not:desc:" $ ,test "with not:desc:" $
(defreportspec{rsQuery=Not . Desc $ toRegexCI' "income"}, samplejournal) `gives` (defreportspec{rsQuery=Not . Desc $ toRegexCI' "income"}, samplejournal) `gives`
@ -189,7 +189,7 @@ tests_BalanceReport = tests "BalanceReport" [
,("expenses:supplies","expenses:supplies",0, mamountp' "$1.00") ,("expenses:supplies","expenses:supplies",0, mamountp' "$1.00")
,("income:gifts","income:gifts",0, mamountp' "$-1.00") ,("income:gifts","income:gifts",0, mamountp' "$-1.00")
], ],
Mixed [usd 0]) mixedAmount (usd 0))
,test "with period on a populated period" $ ,test "with period on a populated period" $
(defreportspec{rsOpts=defreportopts{period_= PeriodBetween (fromGregorian 2008 1 1) (fromGregorian 2008 1 2)}}, samplejournal) `gives` (defreportspec{rsOpts=defreportopts{period_= PeriodBetween (fromGregorian 2008 1 1) (fromGregorian 2008 1 2)}}, samplejournal) `gives`
@ -198,11 +198,11 @@ tests_BalanceReport = tests "BalanceReport" [
("assets:bank:checking","assets:bank:checking",0, mamountp' "$1.00") ("assets:bank:checking","assets:bank:checking",0, mamountp' "$1.00")
,("income:salary","income:salary",0, mamountp' "$-1.00") ,("income:salary","income:salary",0, mamountp' "$-1.00")
], ],
Mixed [usd 0]) mixedAmount (usd 0))
,test "with period on an unpopulated period" $ ,test "with period on an unpopulated period" $
(defreportspec{rsOpts=defreportopts{period_= PeriodBetween (fromGregorian 2008 1 2) (fromGregorian 2008 1 3)}}, samplejournal) `gives` (defreportspec{rsOpts=defreportopts{period_= PeriodBetween (fromGregorian 2008 1 2) (fromGregorian 2008 1 3)}}, samplejournal) `gives`
([], 0) ([], nullmixedamt)

14
hledger-lib/Hledger/Reports/BudgetReport.hs
View File

@ -206,7 +206,7 @@ combineBudgetAndActual ropts j
sortedrows :: [BudgetReportRow] = sortRowsLike (mbrsorted unbudgetedrows ++ mbrsorted rows') rows sortedrows :: [BudgetReportRow] = sortRowsLike (mbrsorted unbudgetedrows ++ mbrsorted rows') rows
where where
(unbudgetedrows, rows') = partition ((==unbudgetedAccountName) . prrFullName) rows (unbudgetedrows, rows') = partition ((==unbudgetedAccountName) . prrFullName) rows
mbrsorted = map prrFullName . sortRows ropts j . map (fmap $ fromMaybe 0 . fst) mbrsorted = map prrFullName . sortRows ropts j . map (fmap $ fromMaybe nullmixedamt . fst)
rows = rows1 ++ rows2 rows = rows1 ++ rows2
-- TODO: grand total & average shows 0% when there are no actual amounts, inconsistent with other cells -- TODO: grand total & average shows 0% when there are no actual amounts, inconsistent with other cells
@ -244,7 +244,7 @@ budgetReportAsText ropts@ReportOpts{..} budgetr = TB.toLazyText $
displayCell (actual, budget) = (showamt actual', budgetAndPerc <$> budget) displayCell (actual, budget) = (showamt actual', budgetAndPerc <$> budget)
where where
actual' = fromMaybe 0 actual actual' = fromMaybe nullmixedamt actual
budgetAndPerc b = (showamt b, showper <$> percentage actual' b) budgetAndPerc b = (showamt b, showper <$> percentage actual' b)
showamt = (\(WideBuilder b w) -> (TL.toStrict $ TB.toLazyText b, w)) . showMixedAmountB oneLine{displayColour=color_, displayMaxWidth=Just 32} showamt = (\(WideBuilder b w) -> (TL.toStrict $ TB.toLazyText b, w)) . showMixedAmountB oneLine{displayColour=color_, displayMaxWidth=Just 32}
showper p = let str = T.pack (show $ roundTo 0 p) in (str, T.length str) showper p = let str = T.pack (show $ roundTo 0 p) in (str, T.length str)
@ -280,15 +280,15 @@ budgetReportAsText ropts@ReportOpts{..} budgetr = TB.toLazyText $
-- - the goal is zero -- - the goal is zero
percentage :: Change -> BudgetGoal -> Maybe Percentage percentage :: Change -> BudgetGoal -> Maybe Percentage
percentage actual budget = percentage actual budget =
case (maybecost $ normaliseMixedAmount actual, maybecost $ normaliseMixedAmount budget) of case (costedAmounts actual, costedAmounts budget) of
(Mixed [a], Mixed [b]) | (acommodity a == acommodity b || amountLooksZero a) && not (amountLooksZero b) ([a], [b]) | (acommodity a == acommodity b || amountLooksZero a) && not (amountLooksZero b)
-> Just $ 100 * aquantity a / aquantity b -> Just $ 100 * aquantity a / aquantity b
_ -> -- trace (pshow $ (maybecost actual, maybecost budget)) -- debug missing percentage _ -> -- trace (pshow $ (maybecost actual, maybecost budget)) -- debug missing percentage
Nothing Nothing
where where
maybecost = case cost_ of costedAmounts = case cost_ of
Cost -> mixedAmountCost Cost -> amounts . mixedAmountCost . normaliseMixedAmount
NoCost -> id NoCost -> amounts . normaliseMixedAmount
maybetranspose | transpose_ = \(Table rh ch vals) -> Table ch rh (transpose vals) maybetranspose | transpose_ = \(Table rh ch vals) -> Table ch rh (transpose vals)
| otherwise = id | otherwise = id

50
hledger-lib/Hledger/Reports/MultiBalanceReport.hs
View File

@ -174,7 +174,7 @@ compoundBalanceReportWith rspec' j priceoracle subreportspecs = cbr
(r:rs) -> sconcat $ fmap subreportTotal (r:|rs) (r:rs) -> sconcat $ fmap subreportTotal (r:|rs)
where where
subreportTotal (_, sr, increasestotal) = subreportTotal (_, sr, increasestotal) =
(if increasestotal then id else fmap negate) $ prTotals sr (if increasestotal then id else fmap maNegate) $ prTotals sr
cbr = CompoundPeriodicReport "" (M.keys colps) subreports overalltotals cbr = CompoundPeriodicReport "" (M.keys colps) subreports overalltotals
@ -338,7 +338,7 @@ generateMultiBalanceReport rspec@ReportSpec{rsOpts=ropts} j priceoracle colps st
displaynames = dbg5 "displaynames" $ displayedAccounts rspec matrix displaynames = dbg5 "displaynames" $ displayedAccounts rspec matrix
-- All the rows of the report. -- All the rows of the report.
rows = dbg5 "rows" . (if invert_ ropts then map (fmap negate) else id) -- Negate amounts if applicable rows = dbg5 "rows" . (if invert_ ropts then map (fmap maNegate) else id) -- Negate amounts if applicable
$ buildReportRows ropts displaynames matrix $ buildReportRows ropts displaynames matrix
-- Calculate column totals -- Calculate column totals
@ -357,7 +357,7 @@ buildReportRows :: ReportOpts
-> HashMap AccountName DisplayName -> HashMap AccountName DisplayName
-> HashMap AccountName (Map DateSpan Account) -> HashMap AccountName (Map DateSpan Account)
-> [MultiBalanceReportRow] -> [MultiBalanceReportRow]
buildReportRows ropts displaynames = buildReportRows ropts displaynames =
toList . HM.mapMaybeWithKey mkRow -- toList of HashMap's Foldable instance - does not sort consistently toList . HM.mapMaybeWithKey mkRow -- toList of HashMap's Foldable instance - does not sort consistently
where where
mkRow name accts = do mkRow name accts = do
@ -369,8 +369,8 @@ buildReportRows ropts displaynames =
-- These are always simply the sum/average of the displayed row amounts. -- These are always simply the sum/average of the displayed row amounts.
-- Total for a cumulative/historical report is always the last column. -- Total for a cumulative/historical report is always the last column.
rowtot = case balancetype_ ropts of rowtot = case balancetype_ ropts of
PeriodChange -> sum rowbals PeriodChange -> maSum rowbals
_ -> lastDef 0 rowbals _ -> lastDef nullmixedamt rowbals
rowavg = averageMixedAmounts rowbals rowavg = averageMixedAmounts rowbals
balance = case accountlistmode_ ropts of ALTree -> aibalance; ALFlat -> aebalance balance = case accountlistmode_ ropts of ALTree -> aibalance; ALFlat -> aebalance
@ -439,7 +439,7 @@ sortRows ropts j
-- Set the inclusive balance of an account from the rows, or sum the -- Set the inclusive balance of an account from the rows, or sum the
-- subaccounts if it's not present -- subaccounts if it's not present
accounttreewithbals = mapAccounts setibalance accounttree accounttreewithbals = mapAccounts setibalance accounttree
setibalance a = a{aibalance = maybe (sum . map aibalance $ asubs a) prrTotal $ setibalance a = a{aibalance = maybe (maSum . map aibalance $ asubs a) prrTotal $
HM.lookup (aname a) rowMap} HM.lookup (aname a) rowMap}
sortedaccounttree = sortAccountTreeByAmount (fromMaybe NormallyPositive $ normalbalance_ ropts) accounttreewithbals sortedaccounttree = sortAccountTreeByAmount (fromMaybe NormallyPositive $ normalbalance_ ropts) accounttreewithbals
sortedanames = map aname $ drop 1 $ flattenAccounts sortedaccounttree sortedanames = map aname $ drop 1 $ flattenAccounts sortedaccounttree
@ -470,14 +470,14 @@ calculateTotalsRow ropts rows =
colamts = transpose . map prrAmounts $ filter isTopRow rows colamts = transpose . map prrAmounts $ filter isTopRow rows
coltotals :: [MixedAmount] = dbg5 "coltotals" $ map sum colamts coltotals :: [MixedAmount] = dbg5 "coltotals" $ map maSum colamts
-- Calculate the grand total and average. These are always the sum/average -- Calculate the grand total and average. These are always the sum/average
-- of the column totals. -- of the column totals.
-- Total for a cumulative/historical report is always the last column. -- Total for a cumulative/historical report is always the last column.
grandtotal = case balancetype_ ropts of grandtotal = case balancetype_ ropts of
PeriodChange -> sum coltotals PeriodChange -> maSum coltotals
_ -> lastDef 0 coltotals _ -> lastDef nullmixedamt coltotals
grandaverage = averageMixedAmounts coltotals grandaverage = averageMixedAmounts coltotals
-- | Map the report rows to percentages if needed -- | Map the report rows to percentages if needed
@ -535,12 +535,12 @@ perdivide a b = fromMaybe (error' errmsg) $ do -- PARTIAL:
-- in scanl, so other properties (such as anumpostings) stay in the right place -- in scanl, so other properties (such as anumpostings) stay in the right place
sumAcct :: Account -> Account -> Account sumAcct :: Account -> Account -> Account
sumAcct Account{aibalance=i1,aebalance=e1} a@Account{aibalance=i2,aebalance=e2} = sumAcct Account{aibalance=i1,aebalance=e1} a@Account{aibalance=i2,aebalance=e2} =
a{aibalance = i1 + i2, aebalance = e1 + e2} a{aibalance = i1 `maPlus` i2, aebalance = e1 `maPlus` e2}
-- Subtract the values in one account from another. Should be left-biased. -- Subtract the values in one account from another. Should be left-biased.
subtractAcct :: Account -> Account -> Account subtractAcct :: Account -> Account -> Account
subtractAcct a@Account{aibalance=i1,aebalance=e1} Account{aibalance=i2,aebalance=e2} = subtractAcct a@Account{aibalance=i1,aebalance=e1} Account{aibalance=i2,aebalance=e2} =
a{aibalance = i1 - i2, aebalance = e1 - e2} a{aibalance = i1 `maMinus` i2, aebalance = e1 `maMinus` e2}
-- | Extract period changes from a cumulative list -- | Extract period changes from a cumulative list
periodChanges :: Account -> Map k Account -> Map k Account periodChanges :: Account -> Map k Account -> Map k Account
@ -586,13 +586,13 @@ tests_MultiBalanceReport = tests "MultiBalanceReport" [
in in
tests "multiBalanceReport" [ tests "multiBalanceReport" [
test "null journal" $ test "null journal" $
(defreportspec, nulljournal) `gives` ([], Mixed [nullamt]) (defreportspec, nulljournal) `gives` ([], nullmixedamt)
,test "with -H on a populated period" $ ,test "with -H on a populated period" $
(defreportspec{rsOpts=defreportopts{period_= PeriodBetween (fromGregorian 2008 1 1) (fromGregorian 2008 1 2), balancetype_=HistoricalBalance}}, samplejournal) `gives` (defreportspec{rsOpts=defreportopts{period_= PeriodBetween (fromGregorian 2008 1 1) (fromGregorian 2008 1 2), balancetype_=HistoricalBalance}}, samplejournal) `gives`
( (
[ PeriodicReportRow (flatDisplayName "assets:bank:checking") [mamountp' "$1.00"] (mamountp' "$1.00") (Mixed [amt0 {aquantity=1}]) [ PeriodicReportRow (flatDisplayName "assets:bank:checking") [mamountp' "$1.00"] (mamountp' "$1.00") (mixedAmount amt0{aquantity=1})
, PeriodicReportRow (flatDisplayName "income:salary") [mamountp' "$-1.00"] (mamountp' "$-1.00") (Mixed [amt0 {aquantity=(-1)}]) , PeriodicReportRow (flatDisplayName "income:salary") [mamountp' "$-1.00"] (mamountp' "$-1.00") (mixedAmount amt0{aquantity=(-1)})
], ],
mamountp' "$0.00") mamountp' "$0.00")
@ -600,23 +600,23 @@ tests_MultiBalanceReport = tests "MultiBalanceReport" [
-- (defreportopts{period_= PeriodBetween (fromGregorian 2008 1 2) (fromGregorian 2008 1 3), balancetype_=HistoricalBalance}, samplejournal) `gives` -- (defreportopts{period_= PeriodBetween (fromGregorian 2008 1 2) (fromGregorian 2008 1 3), balancetype_=HistoricalBalance}, samplejournal) `gives`
-- ( -- (
-- [ -- [
-- ("assets:bank:checking","checking",3, [mamountp' "$1.00"], mamountp' "$1.00",Mixed [amt0 {aquantity=1}]) -- ("assets:bank:checking","checking",3, [mamountp' "$1.00"], mamountp' "$1.00",mixedAmount amt0 {aquantity=1})
-- ,("income:salary","salary",2, [mamountp' "$-1.00"], mamountp' "$-1.00",Mixed [amt0 {aquantity=(-1)}]) -- ,("income:salary","salary",2, [mamountp' "$-1.00"], mamountp' "$-1.00",mixedAmount amt0 {aquantity=(-1)})
-- ], -- ],
-- Mixed [usd0]) -- mixedAmount usd0)
-- ,test "a valid history on an empty period (more complex)" $ -- ,test "a valid history on an empty period (more complex)" $
-- (defreportopts{period_= PeriodBetween (fromGregorian 2009 1 1) (fromGregorian 2009 1 2), balancetype_=HistoricalBalance}, samplejournal) `gives` -- (defreportopts{period_= PeriodBetween (fromGregorian 2009 1 1) (fromGregorian 2009 1 2), balancetype_=HistoricalBalance}, samplejournal) `gives`
-- ( -- (
-- [ -- [
-- ("assets:bank:checking","checking",3, [mamountp' "$1.00"], mamountp' "$1.00",Mixed [amt0 {aquantity=1}]) -- ("assets:bank:checking","checking",3, [mamountp' "$1.00"], mamountp' "$1.00",mixedAmount amt0 {aquantity=1})
-- ,("assets:bank:saving","saving",3, [mamountp' "$1.00"], mamountp' "$1.00",Mixed [amt0 {aquantity=1}]) -- ,("assets:bank:saving","saving",3, [mamountp' "$1.00"], mamountp' "$1.00",mixedAmount amt0 {aquantity=1})
-- ,("assets:cash","cash",2, [mamountp' "$-2.00"], mamountp' "$-2.00",Mixed [amt0 {aquantity=(-2)}]) -- ,("assets:cash","cash",2, [mamountp' "$-2.00"], mamountp' "$-2.00",mixedAmount amt0 {aquantity=(-2)})
-- ,("expenses:food","food",2, [mamountp' "$1.00"], mamountp' "$1.00",Mixed [amt0 {aquantity=(1)}]) -- ,("expenses:food","food",2, [mamountp' "$1.00"], mamountp' "$1.00",mixedAmount amt0 {aquantity=(1)})
-- ,("expenses:supplies","supplies",2, [mamountp' "$1.00"], mamountp' "$1.00",Mixed [amt0 {aquantity=(1)}]) -- ,("expenses:supplies","supplies",2, [mamountp' "$1.00"], mamountp' "$1.00",mixedAmount amt0 {aquantity=(1)})
-- ,("income:gifts","gifts",2, [mamountp' "$-1.00"], mamountp' "$-1.00",Mixed [amt0 {aquantity=(-1)}]) -- ,("income:gifts","gifts",2, [mamountp' "$-1.00"], mamountp' "$-1.00",mixedAmount amt0 {aquantity=(-1)})
-- ,("income:salary","salary",2, [mamountp' "$-1.00"], mamountp' "$-1.00",Mixed [amt0 {aquantity=(-1)}]) -- ,("income:salary","salary",2, [mamountp' "$-1.00"], mamountp' "$-1.00",mixedAmount amt0 {aquantity=(-1)})
-- ], -- ],
-- Mixed [usd0]) -- mixedAmount usd0)
] ]
] ]

49
hledger-lib/Hledger/Reports/PostingsReport.hs
View File

@ -4,11 +4,11 @@ Postings report, used by the register command.
-} -}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
module Hledger.Reports.PostingsReport ( module Hledger.Reports.PostingsReport (
PostingsReport, PostingsReport,
@ -21,11 +21,11 @@ module Hledger.Reports.PostingsReport (
) )
where where
import Data.List import Data.List (nub, sortOn)
import Data.List.Extra (nubSort) import Data.List.Extra (nubSort)
import Data.Maybe import Data.Maybe (fromMaybe, isJust, isNothing)
import Data.Text (Text) import Data.Text (Text)
import Data.Time.Calendar import Data.Time.Calendar (Day, addDays)
import Safe (headMay, lastMay) import Safe (headMay, lastMay)
import Hledger.Data import Hledger.Data
@ -101,12 +101,11 @@ postingsReport rspec@ReportSpec{rsOpts=ropts@ReportOpts{..}} j = items
-- of --value on reports". -- of --value on reports".
-- XXX balance report doesn't value starting balance.. should this ? -- XXX balance report doesn't value starting balance.. should this ?
historical = balancetype_ == HistoricalBalance historical = balancetype_ == HistoricalBalance
startbal | average_ = if historical then precedingavg else 0 startbal | average_ = if historical then precedingavg else nullmixedamt
| otherwise = if historical then precedingsum else 0 | otherwise = if historical then precedingsum else nullmixedamt
where where
precedingsum = sumPostings $ map (pvalue daybeforereportstart) precedingps precedingsum = sumPostings $ map (pvalue daybeforereportstart) precedingps
precedingavg | null precedingps = 0 precedingavg = divideMixedAmount (fromIntegral $ length precedingps) precedingsum
| otherwise = divideMixedAmount (fromIntegral $ length precedingps) precedingsum
daybeforereportstart = daybeforereportstart =
maybe (error' "postingsReport: expected a non-empty journal") -- PARTIAL: shouldn't happen maybe (error' "postingsReport: expected a non-empty journal") -- PARTIAL: shouldn't happen
(addDays (-1)) (addDays (-1))
@ -121,8 +120,8 @@ postingsReport rspec@ReportSpec{rsOpts=ropts@ReportOpts{..}} j = items
-- and return the new average/total. -- and return the new average/total.
registerRunningCalculationFn :: ReportOpts -> (Int -> MixedAmount -> MixedAmount -> MixedAmount) registerRunningCalculationFn :: ReportOpts -> (Int -> MixedAmount -> MixedAmount -> MixedAmount)
registerRunningCalculationFn ropts registerRunningCalculationFn ropts
| average_ ropts = \i avg amt -> avg + divideMixedAmount (fromIntegral i) (amt - avg) | average_ ropts = \i avg amt -> avg `maPlus` divideMixedAmount (fromIntegral i) (amt `maMinus` avg)
| otherwise = \_ bal amt -> bal + amt | otherwise = \_ bal amt -> bal `maPlus` amt
-- | Find postings matching a given query, within a given date span, -- | Find postings matching a given query, within a given date span,
-- and also any similarly-matched postings before that date span. -- and also any similarly-matched postings before that date span.
@ -218,7 +217,7 @@ summarisePostingsInDateSpan (DateSpan b e) wd mdepth showempty ps
e' = fromMaybe (maybe (addDays 1 nulldate) postingdate $ lastMay ps) e e' = fromMaybe (maybe (addDays 1 nulldate) postingdate $ lastMay ps) e
summaryp = nullposting{pdate=Just b'} summaryp = nullposting{pdate=Just b'}
clippedanames = nub $ map (clipAccountName mdepth) anames clippedanames = nub $ map (clipAccountName mdepth) anames
summaryps | mdepth == Just 0 = [summaryp{paccount="...",pamount=sum $ map pamount ps}] summaryps | mdepth == Just 0 = [summaryp{paccount="...",pamount=sumPostings ps}]
| otherwise = [summaryp{paccount=a,pamount=balance a} | a <- clippedanames] | otherwise = [summaryp{paccount=a,pamount=balance a} | a <- clippedanames]
summarypes = map (, e') $ (if showempty then id else filter (not . mixedAmountLooksZero . pamount)) summaryps summarypes = map (, e') $ (if showempty then id else filter (not . mixedAmountLooksZero . pamount)) summaryps
anames = nubSort $ map paccount ps anames = nubSort $ map paccount ps
@ -230,7 +229,7 @@ summarisePostingsInDateSpan (DateSpan b e) wd mdepth showempty ps
isclipped a = maybe True (accountNameLevel a >=) mdepth isclipped a = maybe True (accountNameLevel a >=) mdepth
negatePostingAmount :: Posting -> Posting negatePostingAmount :: Posting -> Posting
negatePostingAmount p = p { pamount = negate $ pamount p } negatePostingAmount p = p { pamount = maNegate $ pamount p }
-- tests -- tests
@ -407,10 +406,10 @@ tests_PostingsReport = tests "PostingsReport" [
-- (summarisePostingsInDateSpan (DateSpan b e) depth showempty ps `is`) -- (summarisePostingsInDateSpan (DateSpan b e) depth showempty ps `is`)
-- let ps = -- let ps =
-- [ -- [
-- nullposting{lpdescription="desc",lpaccount="expenses:food:groceries",lpamount=Mixed [usd 1]} -- nullposting{lpdescription="desc",lpaccount="expenses:food:groceries",lpamount=mixedAmount (usd 1)}
-- ,nullposting{lpdescription="desc",lpaccount="expenses:food:dining", lpamount=Mixed [usd 2]} -- ,nullposting{lpdescription="desc",lpaccount="expenses:food:dining", lpamount=mixedAmount (usd 2)}
-- ,nullposting{lpdescription="desc",lpaccount="expenses:food", lpamount=Mixed [usd 4]} -- ,nullposting{lpdescription="desc",lpaccount="expenses:food", lpamount=mixedAmount (usd 4)}
-- ,nullposting{lpdescription="desc",lpaccount="expenses:food:dining", lpamount=Mixed [usd 8]} -- ,nullposting{lpdescription="desc",lpaccount="expenses:food:dining", lpamount=mixedAmount (usd 8)}
-- ] -- ]
-- ("2008/01/01","2009/01/01",0,9999,False,[]) `gives` -- ("2008/01/01","2009/01/01",0,9999,False,[]) `gives`
-- [] -- []
@ -420,21 +419,21 @@ tests_PostingsReport = tests "PostingsReport" [
-- ] -- ]
-- ("2008/01/01","2009/01/01",0,9999,False,ts) `gives` -- ("2008/01/01","2009/01/01",0,9999,False,ts) `gives`
-- [ -- [
-- nullposting{lpdate=fromGregorian 2008 01 01,lpdescription="- 2008/12/31",lpaccount="expenses:food", lpamount=Mixed [usd 4]} -- nullposting{lpdate=fromGregorian 2008 01 01,lpdescription="- 2008/12/31",lpaccount="expenses:food", lpamount=mixedAmount (usd 4)}
-- ,nullposting{lpdate=fromGregorian 2008 01 01,lpdescription="- 2008/12/31",lpaccount="expenses:food:dining", lpamount=Mixed [usd 10]} -- ,nullposting{lpdate=fromGregorian 2008 01 01,lpdescription="- 2008/12/31",lpaccount="expenses:food:dining", lpamount=mixedAmount (usd 10)}
-- ,nullposting{lpdate=fromGregorian 2008 01 01,lpdescription="- 2008/12/31",lpaccount="expenses:food:groceries",lpamount=Mixed [usd 1]} -- ,nullposting{lpdate=fromGregorian 2008 01 01,lpdescription="- 2008/12/31",lpaccount="expenses:food:groceries",lpamount=mixedAmount (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=fromGregorian 2008 01 01,lpdescription="- 2008/12/31",lpaccount="expenses:food",lpamount=Mixed [usd 15]} -- nullposting{lpdate=fromGregorian 2008 01 01,lpdescription="- 2008/12/31",lpaccount="expenses:food",lpamount=mixedAmount (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=fromGregorian 2008 01 01,lpdescription="- 2008/12/31",lpaccount="expenses",lpamount=Mixed [usd 15]} -- nullposting{lpdate=fromGregorian 2008 01 01,lpdescription="- 2008/12/31",lpaccount="expenses",lpamount=mixedAmount (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=fromGregorian 2008 01 01,lpdescription="- 2008/12/31",lpaccount="",lpamount=Mixed [usd 15]} -- nullposting{lpdate=fromGregorian 2008 01 01,lpdescription="- 2008/12/31",lpaccount="",lpamount=mixedAmount (usd 15)}
-- ] -- ]
] ]

6
hledger-lib/Hledger/Reports/ReportTypes.hs
View File

@ -98,11 +98,11 @@ data PeriodicReportRow a b =
, prrAverage :: b -- The average of this row's values. , prrAverage :: b -- The average of this row's values.
} deriving (Show, Functor, Generic, ToJSON) } deriving (Show, Functor, Generic, ToJSON)
instance Num b => Semigroup (PeriodicReportRow a b) where instance Semigroup b => Semigroup (PeriodicReportRow a b) where
(PeriodicReportRow _ amts1 t1 a1) <> (PeriodicReportRow n2 amts2 t2 a2) = (PeriodicReportRow _ amts1 t1 a1) <> (PeriodicReportRow n2 amts2 t2 a2) =
PeriodicReportRow n2 (sumPadded amts1 amts2) (t1 + t2) (a1 + a2) PeriodicReportRow n2 (sumPadded amts1 amts2) (t1 <> t2) (a1 <> a2)
where where
sumPadded (a:as) (b:bs) = (a + b) : sumPadded as bs sumPadded (a:as) (b:bs) = (a <> b) : sumPadded as bs
sumPadded as [] = as sumPadded as [] = as
sumPadded [] bs = bs sumPadded [] bs = bs

10
hledger-lib/Hledger/Reports/TransactionsReport.hs
View File

@ -1,4 +1,6 @@
{-# LANGUAGE OverloadedStrings, RecordWildCards, FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-| {-|
A transactions report. Like an EntriesReport, but with more A transactions report. Like an EntriesReport, but with more
@ -21,10 +23,10 @@ module Hledger.Reports.TransactionsReport (
) )
where where
import Data.List import Data.List (sortBy)
import Data.List.Extra (nubSort) import Data.List.Extra (nubSort)
import Data.Ord (comparing)
import Data.Text (Text) import Data.Text (Text)
import Data.Ord
import Hledger.Data import Hledger.Data
import Hledger.Query import Hledger.Query
@ -99,7 +101,7 @@ filterTransactionsReportByCommodity c =
startbal = filterMixedAmountByCommodity c $ triBalance i startbal = filterMixedAmountByCommodity c $ triBalance i
go _ [] = [] go _ [] = []
go bal ((t,t2,s,o,amt,_):is) = (t,t2,s,o,amt,bal'):go bal' is go bal ((t,t2,s,o,amt,_):is) = (t,t2,s,o,amt,bal'):go bal' is
where bal' = bal + amt where bal' = bal `maPlus` amt
-- tests -- tests

24
hledger-lib/Hledger/Utils.hs
View File

@ -4,7 +4,9 @@ Standard imports and utilities which are useful everywhere, or needed low
in the module hierarchy. This is the bottom of hledger's module graph. in the module hierarchy. This is the bottom of hledger's module graph.
-} -}
{-# LANGUAGE OverloadedStrings, LambdaCase #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Hledger.Utils (---- provide these frequently used modules - or not, for clearer api: module Hledger.Utils (---- provide these frequently used modules - or not, for clearer api:
-- module Control.Monad, -- module Control.Monad,
@ -35,25 +37,21 @@ module Hledger.Utils (---- provide these frequently used modules - or not, for c
where where
import Control.Monad (liftM, when) import Control.Monad (liftM, when)
-- import Data.Char
import Data.FileEmbed (makeRelativeToProject, embedStringFile) import Data.FileEmbed (makeRelativeToProject, embedStringFile)
import Data.List import Data.List (foldl', foldl1')
-- import Data.Maybe
-- import Data.PPrint
-- import Data.String.Here (hereFile) -- import Data.String.Here (hereFile)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text.IO as T import qualified Data.Text.IO as T
import Data.Time.Clock import Data.Time.Clock (getCurrentTime)
import Data.Time.LocalTime import Data.Time.LocalTime (LocalTime, ZonedTime, getCurrentTimeZone,
-- import Data.Text (Text) utcToLocalTime, utcToZonedTime)
-- import qualified Data.Text as T
-- import Language.Haskell.TH.Quote (QuasiQuoter(..)) -- import Language.Haskell.TH.Quote (QuasiQuoter(..))
import Language.Haskell.TH.Syntax (Q, Exp) import Language.Haskell.TH.Syntax (Q, Exp)
import System.Directory (getHomeDirectory) import System.Directory (getHomeDirectory)
import System.FilePath((</>), isRelative) import System.FilePath (isRelative, (</>))
import System.IO import System.IO
-- import Text.Printf (Handle, IOMode (..), hGetEncoding, hSetEncoding, hSetNewlineMode,
-- import qualified Data.Map as Map openFile, stdin, universalNewlineMode, utf8_bom)
import Hledger.Utils.Debug import Hledger.Utils.Debug
import Hledger.Utils.Parse import Hledger.Utils.Parse
@ -160,7 +158,7 @@ expandPath :: FilePath -> FilePath -> IO FilePath -- general type sig for use in
expandPath _ "-" = return "-" expandPath _ "-" = return "-"
expandPath curdir p = (if isRelative p then (curdir </>) else id) `liftM` expandHomePath p expandPath curdir p = (if isRelative p then (curdir </>) else id) `liftM` expandHomePath p
-- PARTIAL: -- PARTIAL:
-- | Expand user home path indicated by tilde prefix -- | Expand user home path indicated by tilde prefix
expandHomePath :: FilePath -> IO FilePath expandHomePath :: FilePath -> IO FilePath
expandHomePath = \case expandHomePath = \case

3
hledger-ui/Hledger/UI/AccountsScreen.hs
View File

@ -103,8 +103,7 @@ asInit d reset ui@UIState{
,asItemRenderedAmounts = map showAmountWithoutPrice amts ,asItemRenderedAmounts = map showAmountWithoutPrice amts
} }
where where
Mixed amts = normaliseMixedAmountSquashPricesForDisplay $ stripPrices bal amts = amounts . normaliseMixedAmountSquashPricesForDisplay $ mixedAmountStripPrices bal
stripPrices (Mixed as) = Mixed $ map stripprice as where stripprice a = a{aprice=Nothing}
displayitems = map displayitem items displayitems = map displayitem items
-- blanks added for scrolling control, cf RegisterScreen. -- blanks added for scrolling control, cf RegisterScreen.
-- XXX Ugly. Changing to 0 helps when debugging. -- XXX Ugly. Changing to 0 helps when debugging.

8
hledger/Hledger/Cli/Commands/Add.hs
View File

@ -329,7 +329,7 @@ amountAndCommentWizard PrevInput{..} EntryState{..} = do
(mhistoricalp,followedhistoricalsofar) = (mhistoricalp,followedhistoricalsofar) =
case esSimilarTransaction of case esSimilarTransaction of
Nothing -> (Nothing,False) Nothing -> (Nothing,False)
Just Transaction{tpostings=ps} -> Just Transaction{tpostings=ps} ->
( if length ps >= pnum then Just (ps !! (pnum-1)) else Nothing ( if length ps >= pnum then Just (ps !! (pnum-1)) else Nothing
, all sameamount $ zip esPostings ps , all sameamount $ zip esPostings ps
) )
@ -343,7 +343,7 @@ amountAndCommentWizard PrevInput{..} EntryState{..} = do
retryMsg "A valid hledger amount is required. Eg: 1, $2, 3 EUR, \"4 red apples\"." $ retryMsg "A valid hledger amount is required. Eg: 1, $2, 3 EUR, \"4 red apples\"." $
parser parseAmountAndComment $ parser parseAmountAndComment $
withCompletion (amountCompleter def) $ withCompletion (amountCompleter def) $
defaultTo' def $ defaultTo' def $
nonEmpty $ nonEmpty $
linePrewritten (green $ printf "Amount %d%s: " pnum (showDefault def)) (fromMaybe "" $ prevAmountAndCmnt `atMay` length esPostings) "" linePrewritten (green $ printf "Amount %d%s: " pnum (showDefault def)) (fromMaybe "" $ prevAmountAndCmnt `atMay` length esPostings) ""
where where
@ -360,8 +360,8 @@ amountAndCommentWizard PrevInput{..} EntryState{..} = do
c <- T.pack <$> fromMaybe "" `fmap` optional (char ';' >> many anySingle) c <- T.pack <$> fromMaybe "" `fmap` optional (char ';' >> many anySingle)
-- eof -- eof
return (a,c) return (a,c)
balancingamt = negate $ sum $ map pamount realps where realps = filter isReal esPostings balancingamt = maNegate . sumPostings $ filter isReal esPostings
balancingamtfirstcommodity = Mixed $ take 1 $ amounts balancingamt balancingamtfirstcommodity = mixed . take 1 $ amounts balancingamt
showamt = showamt =
showMixedAmount . mixedAmountSetPrecision showMixedAmount . mixedAmountSetPrecision
-- what should this be ? -- what should this be ?

3
hledger/Hledger/Cli/Commands/Balancesheet.hs
View File

@ -33,7 +33,7 @@ balancesheetSpec = CompoundBalanceCommandSpec {
cbcsubreporttitle="Liabilities" cbcsubreporttitle="Liabilities"
,cbcsubreportquery=journalLiabilityAccountQuery ,cbcsubreportquery=journalLiabilityAccountQuery
,cbcsubreportoptions=(\ropts -> ropts{normalbalance_=Just NormallyNegative}) ,cbcsubreportoptions=(\ropts -> ropts{normalbalance_=Just NormallyNegative})
,cbcsubreporttransform=fmap negate ,cbcsubreporttransform=fmap maNegate
,cbcsubreportincreasestotal=False ,cbcsubreportincreasestotal=False
} }
], ],
@ -45,4 +45,3 @@ balancesheetmode = compoundBalanceCommandMode balancesheetSpec
balancesheet :: CliOpts -> Journal -> IO () balancesheet :: CliOpts -> Journal -> IO ()
balancesheet = compoundBalanceCommand balancesheetSpec balancesheet = compoundBalanceCommand balancesheetSpec

4
hledger/Hledger/Cli/Commands/Balancesheetequity.hs
View File

@ -34,14 +34,14 @@ balancesheetequitySpec = CompoundBalanceCommandSpec {
cbcsubreporttitle="Liabilities" cbcsubreporttitle="Liabilities"
,cbcsubreportquery=journalLiabilityAccountQuery ,cbcsubreportquery=journalLiabilityAccountQuery
,cbcsubreportoptions=(\ropts -> ropts{normalbalance_=Just NormallyNegative}) ,cbcsubreportoptions=(\ropts -> ropts{normalbalance_=Just NormallyNegative})
,cbcsubreporttransform=fmap negate ,cbcsubreporttransform=fmap maNegate
,cbcsubreportincreasestotal=False ,cbcsubreportincreasestotal=False
} }
,CBCSubreportSpec{ ,CBCSubreportSpec{
cbcsubreporttitle="Equity" cbcsubreporttitle="Equity"
,cbcsubreportquery=journalEquityAccountQuery ,cbcsubreportquery=journalEquityAccountQuery
,cbcsubreportoptions=(\ropts -> ropts{normalbalance_=Just NormallyNegative}) ,cbcsubreportoptions=(\ropts -> ropts{normalbalance_=Just NormallyNegative})
,cbcsubreporttransform=fmap negate ,cbcsubreporttransform=fmap maNegate
,cbcsubreportincreasestotal=False ,cbcsubreportincreasestotal=False
} }
], ],

4
hledger/Hledger/Cli/Commands/Close.hs
View File

@ -89,7 +89,7 @@ close CliOpts{rawopts_=rawopts, reportspec_=rspec} j = do
-- the balances to close -- the balances to close
(acctbals,_) = balanceReport rspec_ j (acctbals,_) = balanceReport rspec_ j
totalamt = sum $ map (\(_,_,_,b) -> normalise b) acctbals totalamt = maSum $ map (\(_,_,_,b) -> normalise b) acctbals
-- since balance assertion amounts are required to be exact, the -- since balance assertion amounts are required to be exact, the
-- amounts in opening/closing transactions should be too (#941, #1137) -- amounts in opening/closing transactions should be too (#941, #1137)
@ -150,7 +150,7 @@ close CliOpts{rawopts_=rawopts, reportspec_=rspec} j = do
, let commoditysum = (sum bs)] , let commoditysum = (sum bs)]
, (b, mcommoditysum) <- bs' , (b, mcommoditysum) <- bs'
] ]
++ [posting{paccount=openingacct, pamount=if explicit then mapMixedAmount precise (negate totalamt) else missingmixedamt} | not interleaved] ++ [posting{paccount=openingacct, pamount=if explicit then mapMixedAmount precise (maNegate totalamt) else missingmixedamt} | not interleaved]
-- print them -- print them
when closing . T.putStr $ showTransaction closingtxn when closing . T.putStr $ showTransaction closingtxn

2
hledger/Hledger/Cli/Commands/Incomestatement.hs
View File

@ -24,7 +24,7 @@ incomestatementSpec = CompoundBalanceCommandSpec {
cbcsubreporttitle="Revenues" cbcsubreporttitle="Revenues"
,cbcsubreportquery=journalRevenueAccountQuery ,cbcsubreportquery=journalRevenueAccountQuery
,cbcsubreportoptions=(\ropts -> ropts{normalbalance_=Just NormallyNegative}) ,cbcsubreportoptions=(\ropts -> ropts{normalbalance_=Just NormallyNegative})
,cbcsubreporttransform=fmap negate ,cbcsubreporttransform=fmap maNegate
,cbcsubreportincreasestotal=True ,cbcsubreportincreasestotal=True
} }
,CBCSubreportSpec{ ,CBCSubreportSpec{

3
hledger/Hledger/Cli/Commands/Print.hs
View File

@ -181,9 +181,8 @@ postingToCSV p =
let credit = if q < 0 then showamt $ negate a_ else "" in let credit = if q < 0 then showamt $ negate a_ else "" in
let debit = if q >= 0 then showamt a_ else "" in let debit = if q >= 0 then showamt a_ else "" in
[account, amount, c, credit, debit, status, comment]) [account, amount, c, credit, debit, status, comment])
amounts . amounts $ pamount p
where where
Mixed amounts = pamount p
status = T.pack . show $ pstatus p status = T.pack . show $ pstatus p
account = showAccountName Nothing (ptype p) (paccount p) account = showAccountName Nothing (ptype p) (paccount p)
comment = T.strip $ pcomment p comment = T.strip $ pcomment p

2
hledger/Hledger/Cli/Commands/Registermatch.hs
View File

@ -34,7 +34,7 @@ registermatch opts@CliOpts{rawopts_=rawopts,reportspec_=rspec} j =
,Nothing ,Nothing
,tdescription <$> ptransaction p ,tdescription <$> ptransaction p
,p ,p
,0) ,nullmixedamt)
_ -> putStrLn "please provide one description argument." _ -> putStrLn "please provide one description argument."
-- Identify the closest recent match for this description in the given date-sorted postings. -- Identify the closest recent match for this description in the given date-sorted postings.

35
hledger/Hledger/Cli/Commands/Roi.hs
View File

@ -102,7 +102,7 @@ roi CliOpts{rawopts_=rawopts, reportspec_=rspec@ReportSpec{rsOpts=ReportOpts{..}
-- Spans are [spanBegin,spanEnd), and spanEnd is 1 day after then actual end date we are interested in -- Spans are [spanBegin,spanEnd), and spanEnd is 1 day after then actual end date we are interested in
let let
cashFlowApplyCostValue = map (\(d,amt) -> (d,mixedAmountValue spanEnd d amt)) cashFlowApplyCostValue = map (\(d,amt) -> (d,mixedAmountValue spanEnd d amt))
valueBefore = valueBefore =
mixedAmountValue spanEnd spanBegin $ mixedAmountValue spanEnd spanBegin $
total trans (And [ investmentsQuery total trans (And [ investmentsQuery
@ -115,7 +115,7 @@ roi CliOpts{rawopts_=rawopts, reportspec_=rspec@ReportSpec{rsOpts=ReportOpts{..}
priceDates = dbg3 "priceDates" $ nub $ filter (spanContainsDate span) priceDirectiveDates priceDates = dbg3 "priceDates" $ nub $ filter (spanContainsDate span) priceDirectiveDates
cashFlow = cashFlow =
((map (\d -> (d,0)) priceDates)++) $ ((map (\d -> (d,nullmixedamt)) priceDates)++) $
cashFlowApplyCostValue $ cashFlowApplyCostValue $
calculateCashFlow trans (And [ Not investmentsQuery calculateCashFlow trans (And [ Not investmentsQuery
, Not pnlQuery , Not pnlQuery
@ -133,14 +133,14 @@ roi CliOpts{rawopts_=rawopts, reportspec_=rspec@ReportSpec{rsOpts=ReportOpts{..}
irr <- internalRateOfReturn showCashFlow prettyTables thisSpan irr <- internalRateOfReturn showCashFlow prettyTables thisSpan
twr <- timeWeightedReturn showCashFlow prettyTables investmentsQuery trans mixedAmountValue thisSpan twr <- timeWeightedReturn showCashFlow prettyTables investmentsQuery trans mixedAmountValue thisSpan
let cashFlowAmt = negate $ sum $ map snd cashFlow let cashFlowAmt = maNegate . maSum $ map snd cashFlow
let smallIsZero x = if abs x < 0.01 then 0.0 else x let smallIsZero x = if abs x < 0.01 then 0.0 else x
return [ showDate spanBegin return [ showDate spanBegin
, showDate (addDays (-1) spanEnd) , showDate (addDays (-1) spanEnd)
, T.pack $ showMixedAmount valueBefore , T.pack $ showMixedAmount valueBefore
, T.pack $ showMixedAmount cashFlowAmt , T.pack $ showMixedAmount cashFlowAmt
, T.pack $ showMixedAmount valueAfter , T.pack $ showMixedAmount valueAfter
, T.pack $ showMixedAmount (valueAfter - (valueBefore + cashFlowAmt)) , T.pack $ showMixedAmount (valueAfter `maMinus` (valueBefore `maPlus` cashFlowAmt))
, T.pack $ printf "%0.2f%%" $ smallIsZero irr , T.pack $ printf "%0.2f%%" $ smallIsZero irr
, T.pack $ printf "%0.2f%%" $ smallIsZero twr ] , T.pack $ printf "%0.2f%%" $ smallIsZero twr ]
@ -165,12 +165,12 @@ timeWeightedReturn showCashFlow prettyTables investmentsQuery trans mixedAmountV
-- first for processing cash flow. This is why pnl changes are Left -- first for processing cash flow. This is why pnl changes are Left
-- and cashflows are Right -- and cashflows are Right
sort sort
$ (++) (map (\(date,amt) -> (date,Left (-amt))) pnl ) $ (++) (map (\(date,amt) -> (date,Left $ maNegate amt)) pnl )
-- Aggregate all entries for a single day, assuming that intraday interest is negligible -- Aggregate all entries for a single day, assuming that intraday interest is negligible
$ map (\date_cash -> let (dates, cash) = unzip date_cash in (head dates, Right (sum cash))) $ map (\date_cash -> let (dates, cash) = unzip date_cash in (head dates, Right (maSum cash)))
$ groupBy ((==) `on` fst) $ groupBy ((==) `on` fst)
$ sortOn fst $ sortOn fst
$ map (\(d,a) -> (d, negate a)) $ map (\(d,a) -> (d, maNegate a))
$ cashFlow $ cashFlow
let units = let units =
@ -203,17 +203,15 @@ timeWeightedReturn showCashFlow prettyTables investmentsQuery trans mixedAmountV
when showCashFlow $ do when showCashFlow $ do
printf "\nTWR cash flow for %s - %s\n" (showDate spanBegin) (showDate (addDays (-1) spanEnd)) printf "\nTWR cash flow for %s - %s\n" (showDate spanBegin) (showDate (addDays (-1) spanEnd))
let (dates', amounts) = unzip changes let (dates', amounts) = unzip changes
cashflows' = map (either (\_ -> 0) id) amounts cashflows' = map (either (const nullmixedamt) id) amounts
pnls' = map (either id (\_ -> 0)) amounts pnls = map (either id (const nullmixedamt)) amounts
(valuesOnDate',unitsBoughtOrSold', unitPrices', unitBalances') = unzip4 units (valuesOnDate,unitsBoughtOrSold', unitPrices', unitBalances') = unzip4 units
add x lst = if valueBefore/=0 then x:lst else lst add x lst = if valueBefore/=0 then x:lst else lst
dates = add spanBegin dates' dates = add spanBegin dates'
cashflows = add valueBeforeAmt cashflows' cashflows = add valueBeforeAmt cashflows'
pnls = add 0 pnls'
unitsBoughtOrSold = add initialUnits unitsBoughtOrSold' unitsBoughtOrSold = add initialUnits unitsBoughtOrSold'
unitPrices = add initialUnitPrice unitPrices' unitPrices = add initialUnitPrice unitPrices'
unitBalances = add initialUnits unitBalances' unitBalances = add initialUnits unitBalances'
valuesOnDate = add 0 valuesOnDate'
TL.putStr $ Ascii.render prettyTables id id T.pack TL.putStr $ Ascii.render prettyTables id id T.pack
(Table (Table
@ -236,11 +234,11 @@ timeWeightedReturn showCashFlow prettyTables investmentsQuery trans mixedAmountV
return annualizedTWR return annualizedTWR
internalRateOfReturn showCashFlow prettyTables (OneSpan spanBegin spanEnd valueBefore valueAfter cashFlow _pnl) = do internalRateOfReturn showCashFlow prettyTables (OneSpan spanBegin spanEnd valueBefore valueAfter cashFlow _pnl) = do
let prefix = (spanBegin, negate valueBefore) let prefix = (spanBegin, maNegate valueBefore)
postfix = (spanEnd, valueAfter) postfix = (spanEnd, valueAfter)
totalCF = filter ((/=0) . snd) $ prefix : (sortOn fst cashFlow) ++ [postfix] totalCF = filter (maIsNonZero . snd) $ prefix : (sortOn fst cashFlow) ++ [postfix]
when showCashFlow $ do when showCashFlow $ do
printf "\nIRR cash flow for %s - %s\n" (showDate spanBegin) (showDate (addDays (-1) spanEnd)) printf "\nIRR cash flow for %s - %s\n" (showDate spanBegin) (showDate (addDays (-1) spanEnd))
@ -267,16 +265,15 @@ type CashFlow = [(Day, MixedAmount)]
interestSum :: Day -> CashFlow -> Double -> Double interestSum :: Day -> CashFlow -> Double -> Double
interestSum referenceDay cf rate = sum $ map go cf interestSum referenceDay cf rate = sum $ map go cf
where go (t,m) = fromRational (toRational (unMix m)) * (rate ** (fromIntegral (referenceDay `diffDays` t) / 365)) where go (t,m) = realToFrac (unMix m) * rate ** (fromIntegral (referenceDay `diffDays` t) / 365)
calculateCashFlow :: [Transaction] -> Query -> CashFlow calculateCashFlow :: [Transaction] -> Query -> CashFlow
calculateCashFlow trans query = filter ((/=0).snd) $ map go trans calculateCashFlow trans query = filter (maIsNonZero . snd) $ map go trans
where where go t = (transactionDate2 t, total [t] query)
go t = (transactionDate2 t, total [t] query)
total :: [Transaction] -> Query -> MixedAmount total :: [Transaction] -> Query -> MixedAmount
total trans query = sumPostings $ filter (matchesPosting query) $ concatMap realPostings trans total trans query = sumPostings . filter (matchesPosting query) $ concatMap realPostings trans
unMix :: MixedAmount -> Quantity unMix :: MixedAmount -> Quantity
unMix a = unMix a =