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

lib: Change internal representation of MixedAmount to use a strict Map

Browse Source 
instead of a list of Amounts. No longer export Mixed constructor, to
keep API clean (if you really need it, you can import it directly from
Hledger.Data.Types). We also ensure the JSON representation of
MixedAmount doesn't change: it is stored as a normalised list of
Amounts.

This commit improves performance. Here are some indicative results.

hledger reg -f examples/10000x1000x10.journal
- Maximum residency decreases from 65MB to 60MB (8% decrease)
- Total memory in use decreases from 178MiB to 157MiB (12% decrease)

hledger reg -f examples/10000x10000x10.journal
- Maximum residency decreases from 69MB to 60MB (13% decrease)
- Total memory in use decreases from 198MiB to 153MiB (23% decrease)

hledger bal -f examples/10000x1000x10.journal
- Total heap usage decreases from 6.4GB to 6.0GB (6% decrease)
- Total memory in use decreases from 178MiB to 153MiB (14% decrease)

hledger bal -f examples/10000x10000x10.journal
- Total heap usage decreases from 7.3GB to 6.9GB (5% decrease)
- Total memory in use decreases from 196MiB to 185MiB (5% decrease)

hledger bal -M -f examples/10000x1000x10.journal
- Total heap usage decreases from 16.8GB to 10.6GB (47% decrease)
- Total time decreases from 14.3s to 12.0s (16% decrease)

hledger bal -M -f examples/10000x10000x10.journal
- Total heap usage decreases from 108GB to 48GB (56% decrease)
- Total time decreases from 62s to 41s (33% decrease)

If you never directly use the constructor Mixed or pattern match against
it then you don't need to make any changes. If you do, then do the
following:

- If you really care about the individual Amounts and never normalise
  your MixedAmount (for example, just storing `Mixed amts` and then
  extracting `amts` as a pattern match, then use should switch to using
  [Amount]. This should just involve removing the `Mixed` constructor.
- If you ever call `mixed`, `normaliseMixedAmount`, or do any sort of
  amount arithmetic (+), (-), then you should replace the constructor
  `Mixed` with the function `mixed`. To extract the list of Amounts, use
  the function `amounts`.
- If you ever call `normaliseMixedAmountSquashPricesForDisplay`, you can
  replace that with `mixedAmountStripPrices`. (N.B. this does something
  slightly different from `normaliseMixedAmountSquashPricesForDisplay`,
  but I don't think there's any use case for squashing prices and then
  keeping the first of the squashed prices around. If you disagree let
  me know.)
- Any remaining calls to `normaliseMixedAmount` can be removed, as that
  is now the identity function.
This commit is contained in:
Stephen Morgan 2021-01-29 16:07:11 +11:00 committed by Simon Michael
parent 4013a81af8
commit 5e7b69356f
24 changed files with 295 additions and 235 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
bin/hledger-smooth.hs
View File

@ -110,11 +110,11 @@ splitPosting acct dates p@Posting{paccount,pamount}
[d] -> (d, []) [d] -> (d, [])
[] -> error' "splitPosting ran out of dates, should not happen (maybe sort your transactions by date)" [] -> error' "splitPosting ran out of dates, should not happen (maybe sort your transactions by date)"
days = initSafe [start..end] days = initSafe [start..end]
amt = (genericLength days) `divideMixedAmount` pamount amt = (fromIntegral $ length days) `divideMixedAmount` pamount
-- give one of the postings an exact balancing amount to ensure the transaction is balanced -- give one of the postings an exact balancing amount to ensure the transaction is balanced
-- lastamt = pamount - ptrace (amt `multiplyMixedAmount` (fromIntegral $ length days)) -- lastamt = pamount - ptrace (amt `multiplyMixedAmount` (fromIntegral $ length days))
lastamt = missingmixedamt lastamt = missingmixedamt
daysamts = zip days (take (length days - 1) (repeat amt) ++ [lastamt]) daysamts = zip days (replicate (length days - 1) amt ++ [lastamt])
ps' = [postingSetDate (Just d) p{pamount=a} | (d,a) <- daysamts ] ps' = [postingSetDate (Just d) p{pamount=a} | (d,a) <- daysamts ]
-- | Set a posting's (primary) date, as if it had been parsed from the journal entry: -- | Set a posting's (primary) date, as if it had been parsed from the journal entry:

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

@ -47,7 +47,7 @@ import Hledger.Data.StringFormat
import Hledger.Data.Timeclock import Hledger.Data.Timeclock
import Hledger.Data.Transaction import Hledger.Data.Transaction
import Hledger.Data.TransactionModifier import Hledger.Data.TransactionModifier
import Hledger.Data.Types import Hledger.Data.Types hiding (MixedAmountKey, Mixed)
import Hledger.Data.Valuation import Hledger.Data.Valuation
import Hledger.Utils.Test import Hledger.Utils.Test

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

@ -101,6 +101,7 @@ module Hledger.Data.Amount (
maAddAmount, maAddAmount,
maAddAmounts, maAddAmounts,
amounts, amounts,
amountsRaw,
filterMixedAmount, filterMixedAmount,
filterMixedAmountByCommodity, filterMixedAmountByCommodity,
mapMixedAmount, mapMixedAmount,
@ -152,10 +153,8 @@ import Data.Foldable (toList)
import Data.List (find, foldl', intercalate, intersperse, mapAccumL, partition) import Data.List (find, 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, isNothing)
#if !(MIN_VERSION_base(4,11,0))
import Data.Semigroup (Semigroup(..)) import Data.Semigroup (Semigroup(..))
#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
import Data.Word (Word8) import Data.Word (Word8)
@ -589,48 +588,54 @@ canonicaliseAmount styles a@Amount{acommodity=c, astyle=s} = a{astyle=s'}
instance Semigroup MixedAmount where instance Semigroup MixedAmount where
(<>) = maPlus (<>) = maPlus
sconcat = maSum
stimes n = multiplyMixedAmount (fromIntegral n)
instance Monoid MixedAmount where instance Monoid MixedAmount where
mempty = nullmixedamt mempty = nullmixedamt
mconcat = maSum
#if !(MIN_VERSION_base(4,11,0)) #if !(MIN_VERSION_base(4,11,0))
mappend = (<>) mappend = (<>)
#endif #endif
instance Num MixedAmount where instance Num MixedAmount where
fromInteger i = Mixed [fromInteger i] fromInteger = mixedAmount . fromInteger
negate = maNegate negate = maNegate
(+) = maPlus (+) = 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. -- | Calculate the key used to store an Amount within a MixedAmount.
amounts :: MixedAmount -> [Amount] amountKey :: Amount -> MixedAmountKey
amounts (Mixed as) = as amountKey amt@Amount{acommodity=c} = case aprice amt of
Nothing -> MixedAmountKeyNoPrice c
Just (TotalPrice p) -> MixedAmountKeyTotalPrice c (acommodity p)
Just (UnitPrice p) -> MixedAmountKeyUnitPrice c (acommodity p) (aquantity p)
-- | The empty mixed amount. -- | The empty mixed amount.
nullmixedamt :: MixedAmount nullmixedamt :: MixedAmount
nullmixedamt = Mixed [] nullmixedamt = Mixed mempty
-- | 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 = mixedAmount missingamt missingmixedamt = mixedAmount missingamt
-- | Convert amounts in various commodities into a normalised MixedAmount. -- | Convert amounts in various commodities into a mixed amount.
mixed :: [Amount] -> MixedAmount mixed :: Foldable t => t Amount -> MixedAmount
mixed = normaliseMixedAmount . Mixed mixed = maAddAmounts nullmixedamt
-- | Create a MixedAmount from a single Amount. -- | Create a MixedAmount from a single Amount.
mixedAmount :: Amount -> MixedAmount mixedAmount :: Amount -> MixedAmount
mixedAmount = Mixed . pure mixedAmount a = Mixed $ M.singleton (amountKey a) a
-- | Add an Amount to a MixedAmount, normalising the result. -- | Add an Amount to a MixedAmount, normalising the result.
maAddAmount :: MixedAmount -> Amount -> MixedAmount maAddAmount :: MixedAmount -> Amount -> MixedAmount
maAddAmount (Mixed as) a = normaliseMixedAmount . Mixed $ a : as maAddAmount (Mixed ma) a = Mixed $ M.insertWith sumSimilarAmountsUsingFirstPrice (amountKey a) a ma
-- | Add a collection of Amounts to a MixedAmount, normalising the result. -- | Add a collection of Amounts to a MixedAmount, normalising the result.
maAddAmounts :: MixedAmount -> [Amount] -> MixedAmount maAddAmounts :: Foldable t => MixedAmount -> t Amount -> MixedAmount
maAddAmounts (Mixed as) bs = bs `seq` normaliseMixedAmount . Mixed $ bs ++ as maAddAmounts = foldl' maAddAmount
-- | Negate mixed amount's quantities (and total prices, if any). -- | Negate mixed amount's quantities (and total prices, if any).
maNegate :: MixedAmount -> MixedAmount maNegate :: MixedAmount -> MixedAmount
@ -638,7 +643,7 @@ maNegate = transformMixedAmount negate
-- | Sum two MixedAmount. -- | Sum two MixedAmount.
maPlus :: MixedAmount -> MixedAmount -> MixedAmount maPlus :: MixedAmount -> MixedAmount -> MixedAmount
maPlus (Mixed as) (Mixed bs) = normaliseMixedAmount . Mixed $ as ++ bs maPlus (Mixed as) (Mixed bs) = Mixed $ M.unionWith sumSimilarAmountsUsingFirstPrice as bs
-- | Subtract a MixedAmount from another. -- | Subtract a MixedAmount from another.
maMinus :: MixedAmount -> MixedAmount -> MixedAmount maMinus :: MixedAmount -> MixedAmount -> MixedAmount
@ -658,7 +663,7 @@ multiplyMixedAmount n = transformMixedAmount (*n)
-- | Apply a function to a mixed amount's quantities (and its total prices, if it has any). -- | Apply a function to a mixed amount's quantities (and its total prices, if it has any).
transformMixedAmount :: (Quantity -> Quantity) -> MixedAmount -> MixedAmount transformMixedAmount :: (Quantity -> Quantity) -> MixedAmount -> MixedAmount
transformMixedAmount f = mapMixedAmount (transformAmount f) transformMixedAmount f = mapMixedAmountUnsafe (transformAmount f)
-- | Calculate the average of some mixed amounts. -- | Calculate the average of some mixed amounts.
averageMixedAmounts :: [MixedAmount] -> MixedAmount averageMixedAmounts :: [MixedAmount] -> MixedAmount
@ -699,7 +704,7 @@ maIsZero = mixedAmountIsZero
maIsNonZero :: MixedAmount -> Bool maIsNonZero :: MixedAmount -> Bool
maIsNonZero = not . mixedAmountIsZero maIsNonZero = not . mixedAmountIsZero
-- | Simplify a mixed amount's component amounts: -- | Get 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
-- --
@ -711,34 +716,35 @@ maIsNonZero = not . mixedAmountIsZero
-- --
-- * the special "missing" mixed amount remains unchanged -- * the special "missing" mixed amount remains unchanged
-- --
normaliseMixedAmount :: MixedAmount -> MixedAmount amounts :: MixedAmount -> [Amount]
normaliseMixedAmount = normaliseHelper False amounts (Mixed ma)
| missingkey `M.member` ma = [missingamt] -- missingamt should always be alone, but detect it even if not
normaliseHelper :: Bool -> MixedAmount -> MixedAmount | M.null nonzeros = [newzero]
normaliseHelper squashprices (Mixed as) | otherwise = toList nonzeros
| missingkey `M.member` amtMap = missingmixedamt -- missingamt should always be alone, but detect it even if not
| M.null nonzeros = Mixed [newzero]
| otherwise = Mixed $ toList nonzeros
where where
newzero = fromMaybe nullamt $ find (not . T.null . acommodity) zeros newzero = fromMaybe nullamt $ find (not . T.null . acommodity) zeros
(zeros, nonzeros) = M.partition amountIsZero amtMap (zeros, nonzeros) = M.partition amountIsZero ma
amtMap = foldr (\a -> M.insertWith sumSimilarAmountsUsingFirstPrice (key a) a) mempty as missingkey = amountKey missingamt
key Amount{acommodity=c,aprice=p} = (c, if squashprices then Nothing else priceKey <$> p)
where
priceKey (UnitPrice x) = (acommodity x, Just $ aquantity x)
priceKey (TotalPrice x) = (acommodity x, Nothing)
missingkey = key missingamt
-- | Like normaliseMixedAmount, but combine each commodity's amounts -- | Get a mixed amount's component amounts without normalising zero and missing
-- into just one by throwing away all prices except the first. This is -- amounts. This is used for JSON serialisation, so the order is important. In
-- only used as a rendering helper, and could show a misleading price. -- particular, we want the Amounts given in the order of the MixedAmountKeys,
-- i.e. lexicographically first by commodity, then by price commodity, then by
-- unit price from most negative to most positive.
amountsRaw :: MixedAmount -> [Amount]
amountsRaw (Mixed ma) = toList ma
normaliseMixedAmount :: MixedAmount -> MixedAmount
normaliseMixedAmount = id -- XXX Remove
-- | Strip prices from a MixedAmount.
normaliseMixedAmountSquashPricesForDisplay :: MixedAmount -> MixedAmount normaliseMixedAmountSquashPricesForDisplay :: MixedAmount -> MixedAmount
normaliseMixedAmountSquashPricesForDisplay = normaliseHelper True normaliseMixedAmountSquashPricesForDisplay = mixedAmountStripPrices -- XXX Remove
-- | Unify a MixedAmount to a single commodity value if possible. -- | Unify a MixedAmount to a single commodity value if possible.
-- Like normaliseMixedAmount, this consolidates amounts of the same commodity -- This consolidates amounts of the same commodity and discards zero
-- and discards zero amounts; but this one insists on simplifying to -- amounts; but this one insists on simplifying to a single commodity,
-- a single commodity, and will return Nothing if this is not possible. -- and will return Nothing if this is not possible.
unifyMixedAmount :: MixedAmount -> Maybe Amount unifyMixedAmount :: MixedAmount -> Maybe Amount
unifyMixedAmount = foldM combine 0 . amounts unifyMixedAmount = foldM combine 0 . amounts
where where
@ -768,22 +774,27 @@ sumSimilarAmountsUsingFirstPrice a b = (a + b){aprice=p}
-- | 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 ma) = Mixed $ M.filter p ma
-- | Return an unnormalised MixedAmount containing exactly one Amount -- | Return an unnormalised MixedAmount containing exactly one Amount
-- with the specified commodity and the quantity of that commodity -- with the specified commodity and the quantity of that commodity
-- found in the original. NB if Amount's quantity is zero it will be -- found in the original. NB if Amount's quantity is zero it will be
-- discarded next time the MixedAmount gets normalised. -- discarded next time the MixedAmount gets normalised.
filterMixedAmountByCommodity :: CommoditySymbol -> MixedAmount -> MixedAmount filterMixedAmountByCommodity :: CommoditySymbol -> MixedAmount -> MixedAmount
filterMixedAmountByCommodity c (Mixed as) = Mixed as' filterMixedAmountByCommodity c (Mixed ma)
where | M.null ma' = mixedAmount nullamt{acommodity=c}
as' = case filter ((==c) . acommodity) as of | otherwise = Mixed ma'
[] -> [nullamt{acommodity=c}] where ma' = M.filter ((c==) . acommodity) ma
as'' -> [sum as'']
-- | Apply a transform to a mixed amount's component 'Amount's. -- | Apply a transform to a mixed amount's component 'Amount's.
mapMixedAmount :: (Amount -> Amount) -> MixedAmount -> MixedAmount mapMixedAmount :: (Amount -> Amount) -> MixedAmount -> MixedAmount
mapMixedAmount f (Mixed as) = Mixed $ map f as mapMixedAmount f (Mixed ma) = mixed . map f $ toList ma
-- | Apply a transform to a mixed amount's component 'Amount's, which does not
-- affect the key of the amount (i.e. doesn't change the commodity, price
-- commodity, or unit price amount). This condition is not checked.
mapMixedAmountUnsafe :: (Amount -> Amount) -> MixedAmount -> MixedAmount
mapMixedAmountUnsafe f (Mixed ma) = Mixed $ M.map f ma -- Use M.map instead of fmap to maintain strictness
-- | Convert all component amounts to cost/selling price where -- | Convert all component amounts to cost/selling price where
-- possible (see amountCost). -- possible (see amountCost).
@ -795,17 +806,17 @@ mixedAmountCost = mapMixedAmount amountCost
-- -- For now, use this when cross-commodity zero equality is important. -- -- For now, use this when cross-commodity zero equality is important.
-- mixedAmountEquals :: MixedAmount -> MixedAmount -> Bool -- mixedAmountEquals :: MixedAmount -> MixedAmount -> Bool
-- mixedAmountEquals a b = amounts a' == amounts b' || (mixedAmountLooksZero a' && mixedAmountLooksZero b') -- mixedAmountEquals a b = amounts a' == amounts b' || (mixedAmountLooksZero a' && mixedAmountLooksZero b')
-- where a' = normaliseMixedAmountSquashPricesForDisplay a -- where a' = mixedAmountStripPrices a
-- b' = normaliseMixedAmountSquashPricesForDisplay b -- b' = mixedAmountStripPrices b
-- | Given a map of standard commodity display styles, apply the -- | Given a map of standard commodity display styles, apply the
-- appropriate one to each individual amount. -- appropriate one to each individual amount.
styleMixedAmount :: M.Map CommoditySymbol AmountStyle -> MixedAmount -> MixedAmount styleMixedAmount :: M.Map CommoditySymbol AmountStyle -> MixedAmount -> MixedAmount
styleMixedAmount styles = mapMixedAmount (styleAmount styles) styleMixedAmount styles = mapMixedAmountUnsafe (styleAmount styles)
-- | Reset each individual amount's display style to the default. -- | Reset each individual amount's display style to the default.
mixedAmountUnstyled :: MixedAmount -> MixedAmount mixedAmountUnstyled :: MixedAmount -> MixedAmount
mixedAmountUnstyled = mapMixedAmount amountUnstyled mixedAmountUnstyled = mapMixedAmountUnsafe amountUnstyled
-- | Get the string representation of a mixed amount, after -- | Get the string representation of a mixed amount, after
-- normalising it to one amount per commodity. Assumes amounts have -- normalising it to one amount per commodity. Assumes amounts have
@ -871,8 +882,8 @@ showMixedAmountDebug m | m == missingmixedamt = "(missing)"
-- - If displayed on multiple lines, any Amounts longer than the -- - If displayed on multiple lines, any Amounts longer than the
-- maximum width will be elided. -- maximum width will be elided.
showMixedAmountB :: AmountDisplayOpts -> MixedAmount -> WideBuilder showMixedAmountB :: AmountDisplayOpts -> MixedAmount -> WideBuilder
showMixedAmountB opts = showAmountsB opts . amounts showMixedAmountB opts =
. (if displayPrice opts then id else mixedAmountStripPrices) . normaliseMixedAmountSquashPricesForDisplay showAmountsB opts . amounts . if displayPrice opts then id else mixedAmountStripPrices
data AmountDisplay = AmountDisplay data AmountDisplay = AmountDisplay
{ adBuilder :: !WideBuilder -- ^ String representation of the Amount { adBuilder :: !WideBuilder -- ^ String representation of the Amount
@ -916,20 +927,22 @@ ltraceamount s = traceWith (((s ++ ": ") ++).showMixedAmount)
-- | Set the display precision in the amount's commodities. -- | Set the display precision in the amount's commodities.
mixedAmountSetPrecision :: AmountPrecision -> MixedAmount -> MixedAmount mixedAmountSetPrecision :: AmountPrecision -> MixedAmount -> MixedAmount
mixedAmountSetPrecision p = mapMixedAmount (amountSetPrecision p) mixedAmountSetPrecision p = mapMixedAmountUnsafe (amountSetPrecision p)
-- | In each component amount, increase the display precision sufficiently -- | In each component amount, increase the display precision sufficiently
-- to render it exactly (showing all significant decimal digits). -- to render it exactly (showing all significant decimal digits).
mixedAmountSetFullPrecision :: MixedAmount -> MixedAmount mixedAmountSetFullPrecision :: MixedAmount -> MixedAmount
mixedAmountSetFullPrecision = mapMixedAmount amountSetFullPrecision mixedAmountSetFullPrecision = mapMixedAmountUnsafe amountSetFullPrecision
-- | Strip all prices from a MixedAmount. -- | Remove all prices from a MixedAmount.
mixedAmountStripPrices :: MixedAmount -> MixedAmount mixedAmountStripPrices :: MixedAmount -> MixedAmount
mixedAmountStripPrices = mapMixedAmount amountStripPrices mixedAmountStripPrices (Mixed ma) =
foldl' (\m a -> maAddAmount m a{aprice=Nothing}) (Mixed noPrices) withPrices
where (noPrices, withPrices) = M.partition (isNothing . aprice) ma
-- | Canonicalise a mixed amount's display styles using the provided commodity style map. -- | Canonicalise a mixed amount's display styles using the provided commodity style map.
canonicaliseMixedAmount :: M.Map CommoditySymbol AmountStyle -> MixedAmount -> MixedAmount canonicaliseMixedAmount :: M.Map CommoditySymbol AmountStyle -> MixedAmount -> MixedAmount
canonicaliseMixedAmount styles = mapMixedAmount (canonicaliseAmount styles) canonicaliseMixedAmount styles = mapMixedAmountUnsafe (canonicaliseAmount styles)
-- | Replace each component amount's TotalPrice, if it has one, with an equivalent UnitPrice. -- | Replace each component amount's TotalPrice, if it has one, with an equivalent UnitPrice.
-- Has no effect on amounts without one. -- Has no effect on amounts without one.
@ -982,14 +995,14 @@ tests_Amount = tests "Amount" [
,usd (-1) `withPrecision` Precision 3 ,usd (-1) `withPrecision` Precision 3
,usd (-0.25) ,usd (-0.25)
]) ])
@?= Mixed [usd 0 `withPrecision` Precision 3] @?= mixedAmount (usd 0 `withPrecision` Precision 3)
,test "adding mixed amounts with total prices" $ do ,test "adding mixed amounts with total prices" $ do
maSum (map mixedAmount maSum (map mixedAmount
[usd 1 @@ eur 1 [usd 1 @@ eur 1
,usd (-2) @@ eur 1 ,usd (-2) @@ eur 1
]) ])
@?= Mixed [usd (-1) @@ eur 2 ] @?= mixedAmount (usd (-1) @@ eur 2)
,test "showMixedAmount" $ do ,test "showMixedAmount" $ do
showMixedAmount (mixedAmount (usd 1)) @?= "$1.00" showMixedAmount (mixedAmount (usd 1)) @?= "$1.00"
@ -1003,22 +1016,22 @@ tests_Amount = tests "Amount" [
showMixedAmountWithoutPrice False (mixedAmount (a)) @?= "$1.00" showMixedAmountWithoutPrice False (mixedAmount (a)) @?= "$1.00"
showMixedAmountWithoutPrice False (mixed [a, -a]) @?= "0" showMixedAmountWithoutPrice False (mixed [a, -a]) @?= "0"
,tests "normaliseMixedAmount" [ ,tests "amounts" [
test "a missing amount overrides any other amounts" $ test "a missing amount overrides any other amounts" $
amounts (normaliseMixedAmount $ mixed [usd 1, missingamt]) @?= [missingamt] amounts (mixed [usd 1, missingamt]) @?= [missingamt]
,test "unpriced same-commodity amounts are combined" $ ,test "unpriced same-commodity amounts are combined" $
amounts (normaliseMixedAmount $ mixed [usd 0, usd 2]) @?= [usd 2] amounts (mixed [usd 0, usd 2]) @?= [usd 2]
,test "amounts with same unit price are combined" $ ,test "amounts with same unit price are combined" $
amounts (normaliseMixedAmount $ mixed [usd 1 `at` eur 1, usd 1 `at` eur 1]) @?= [usd 2 `at` eur 1] amounts (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" $
amounts (normaliseMixedAmount $ mixed [usd 1 `at` eur 1, usd 1 `at` eur 2]) @?= [usd 1 `at` eur 1, usd 1 `at` eur 2] amounts (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" $
amounts (normaliseMixedAmount $ mixed [usd 1 @@ eur 1, usd 1 @@ eur 1]) @?= [usd 2 @@ eur 2] amounts (mixed [usd 1 @@ eur 1, usd 1 @@ eur 1]) @?= [usd 2 @@ eur 2]
] ]
,test "normaliseMixedAmountSquashPricesForDisplay" $ do ,test "mixedAmountStripPrices" $ do
amounts (normaliseMixedAmountSquashPricesForDisplay nullmixedamt) @?= [nullamt] amounts (mixedAmountStripPrices nullmixedamt) @?= [nullamt]
assertBool "" $ mixedAmountLooksZero $ normaliseMixedAmountSquashPricesForDisplay assertBool "" $ mixedAmountLooksZero $ mixedAmountStripPrices
(mixed [usd 10 (mixed [usd 10
,usd 10 @@ eur 7 ,usd 10 @@ eur 7
,usd (-10) ,usd (-10)

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

@ -547,8 +547,8 @@ journalMapPostings :: (Posting -> Posting) -> Journal -> Journal
journalMapPostings f j@Journal{jtxns=ts} = j{jtxns=map (transactionMapPostings f) ts} journalMapPostings f j@Journal{jtxns=ts} = j{jtxns=map (transactionMapPostings f) ts}
-- | Apply a transformation to a journal's posting amounts. -- | Apply a transformation to a journal's posting amounts.
journalMapPostingAmounts :: (Amount -> Amount) -> Journal -> Journal journalMapPostingAmounts :: (MixedAmount -> MixedAmount) -> Journal -> Journal
journalMapPostingAmounts f = journalMapPostings (postingTransformAmount (mapMixedAmount f)) journalMapPostingAmounts f = journalMapPostings (postingTransformAmount f)
{- {-
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
@ -929,7 +929,7 @@ addOrAssignAmountAndCheckAssertionB p@Posting{paccount=acc, pamount=amt, pbalanc
-- need to see the balance as it stands after each individual posting. -- need to see the balance as it stands after each individual posting.
addAmountAndCheckAssertionB :: Posting -> Balancing s Posting addAmountAndCheckAssertionB :: Posting -> Balancing s Posting
addAmountAndCheckAssertionB p | hasAmount p = do addAmountAndCheckAssertionB p | hasAmount p = do
newbal <- addToRunningBalanceB (paccount p) (pamount p) newbal <- addToRunningBalanceB (paccount p) $ pamount p
whenM (R.reader bsAssrt) $ checkBalanceAssertionB p newbal whenM (R.reader bsAssrt) $ checkBalanceAssertionB p newbal
return p return p
addAmountAndCheckAssertionB p = return p addAmountAndCheckAssertionB p = return p
@ -940,13 +940,12 @@ addAmountAndCheckAssertionB p = return p
-- are ignored; if it is total, they will cause the assertion to fail. -- are ignored; if it is total, they will cause the assertion to fail.
checkBalanceAssertionB :: Posting -> MixedAmount -> Balancing s () checkBalanceAssertionB :: Posting -> MixedAmount -> Balancing s ()
checkBalanceAssertionB p@Posting{pbalanceassertion=Just (BalanceAssertion{baamount,batotal})} actualbal = checkBalanceAssertionB p@Posting{pbalanceassertion=Just (BalanceAssertion{baamount,batotal})} actualbal =
forM_ assertedamts $ \amt -> checkBalanceAssertionOneCommodityB p amt actualbal forM_ (baamount : otheramts) $ \amt -> checkBalanceAssertionOneCommodityB p amt actualbal
where where
assertedamts = baamount : otheramts assertedcomm = acommodity baamount
where otheramts | batotal = map (\a -> a{aquantity=0}) . amountsRaw
assertedcomm = acommodity baamount $ filterMixedAmount ((/=assertedcomm).acommodity) actualbal
otheramts | batotal = map (\a -> a{aquantity=0}) $ amounts $ filterMixedAmount ((/=assertedcomm).acommodity) actualbal | otherwise = []
| otherwise = []
checkBalanceAssertionB _ _ = return () checkBalanceAssertionB _ _ = return ()
-- | Does this (single commodity) expected balance match the amount of that -- | Does this (single commodity) expected balance match the amount of that
@ -971,7 +970,7 @@ checkBalanceAssertionOneCommodityB p@Posting{paccount=assertedacct} assertedamt
else return actualbal else return actualbal
let let
assertedcomm = acommodity assertedamt assertedcomm = acommodity assertedamt
actualbalincomm = headDef 0 $ amounts $ filterMixedAmountByCommodity assertedcomm $ actualbal' actualbalincomm = headDef nullamt . amountsRaw . filterMixedAmountByCommodity assertedcomm $ actualbal'
pass = pass =
aquantity aquantity
-- traceWith (("asserted:"++).showAmountDebug) -- traceWith (("asserted:"++).showAmountDebug)
@ -1181,16 +1180,16 @@ journalInferMarketPricesFromTransactions j =
-- first commodity amount is considered. -- first commodity amount is considered.
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 amounts $ mixedAmountTotalPriceToUnitPrice pamount of case amountsRaw $ mixedAmountTotalPriceToUnitPrice pamount of
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
,mpto = tocomm ,mpto = tocomm
,mprate = rate ,mprate = rate
} }
_ -> Nothing _ -> Nothing
-- | Convert all this journal's amounts to cost using the transaction prices, if any. -- | Convert all this journal's amounts to cost using the transaction prices, if any.
-- The journal's commodity styles are applied to the resulting amounts. -- The journal's commodity styles are applied to the resulting amounts.
@ -1229,12 +1228,12 @@ journalToCost j@Journal{jtxns=ts} = j{jtxns=map (transactionToCost styles) ts}
-- Transaction price amounts (posting amounts' aprice field) are not included. -- Transaction price amounts (posting amounts' aprice field) are not included.
-- --
journalStyleInfluencingAmounts :: Journal -> [Amount] journalStyleInfluencingAmounts :: Journal -> [Amount]
journalStyleInfluencingAmounts j = journalStyleInfluencingAmounts j =
dbg7 "journalStyleInfluencingAmounts" $ dbg7 "journalStyleInfluencingAmounts" $
catMaybes $ concat [ catMaybes $ concat [
[mdefaultcommodityamt] [mdefaultcommodityamt]
,map (Just . pdamount) $ jpricedirectives j ,map (Just . pdamount) $ jpricedirectives j
,map Just $ concatMap amounts $ map pamount $ journalPostings j ,map Just . concatMap (amountsRaw . pamount) $ journalPostings j
] ]
where where
-- D's amount style isn't actually stored as an amount, make it into one -- D's amount style isn't actually stored as an amount, make it into one
@ -1561,7 +1560,7 @@ tests_Journal = tests "Journal" [
]} ]}
assertRight ej assertRight ej
let Right j = ej let Right j = ej
(jtxns j & head & tpostings & head & pamount) @?= mixedAmount (num 1) (jtxns j & head & tpostings & head & pamount & amountsRaw) @?= [num 1]
,test "same-day-1" $ do ,test "same-day-1" $ do
assertRight $ journalBalanceTransactions True $ assertRight $ journalBalanceTransactions True $

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

@ -50,6 +50,7 @@ import GHC.Generics (Generic)
import System.Time (ClockTime) import System.Time (ClockTime)
import Hledger.Data.Types import Hledger.Data.Types
import Hledger.Data.Amount (amountsRaw, mixed)
-- To JSON -- To JSON
@ -105,7 +106,11 @@ instance ToJSON AmountPrecision where
instance ToJSON Side instance ToJSON Side
instance ToJSON DigitGroupStyle instance ToJSON DigitGroupStyle
instance ToJSON MixedAmount
instance ToJSON MixedAmount where
toJSON = toJSON . amountsRaw
toEncoding = toEncoding . amountsRaw
instance ToJSON BalanceAssertion instance ToJSON BalanceAssertion
instance ToJSON AmountPrice instance ToJSON AmountPrice
instance ToJSON MarketPrice instance ToJSON MarketPrice
@ -188,7 +193,10 @@ instance FromJSON AmountPrecision where
instance FromJSON Side instance FromJSON Side
instance FromJSON DigitGroupStyle instance FromJSON DigitGroupStyle
instance FromJSON MixedAmount
instance FromJSON MixedAmount where
parseJSON = fmap (mixed :: [Amount] -> MixedAmount) . parseJSON
instance FromJSON BalanceAssertion instance FromJSON BalanceAssertion
instance FromJSON AmountPrice instance FromJSON AmountPrice
instance FromJSON MarketPrice instance FromJSON MarketPrice

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

@ -115,7 +115,7 @@ posting = nullposting
-- | Make a posting to an account. -- | Make a posting to an account.
post :: AccountName -> Amount -> Posting post :: AccountName -> Amount -> Posting
post acc amt = posting {paccount=acc, pamount=Mixed [amt]} post acc amt = posting {paccount=acc, pamount=mixedAmount amt}
-- | Make a virtual (unbalanced) posting to an account. -- | Make a virtual (unbalanced) posting to an account.
vpost :: AccountName -> Amount -> Posting vpost :: AccountName -> Amount -> Posting
@ -123,7 +123,7 @@ vpost acc amt = (post acc amt){ptype=VirtualPosting}
-- | Make a posting to an account, maybe with a balance assertion. -- | Make a posting to an account, maybe with a balance assertion.
post' :: AccountName -> Amount -> Maybe BalanceAssertion -> Posting post' :: AccountName -> Amount -> Maybe BalanceAssertion -> Posting
post' acc amt ass = posting {paccount=acc, pamount=Mixed [amt], pbalanceassertion=ass} post' acc amt ass = posting {paccount=acc, pamount=mixedAmount amt, pbalanceassertion=ass}
-- | Make a virtual (unbalanced) posting to an account, maybe with a balance assertion. -- | Make a virtual (unbalanced) posting to an account, maybe with a balance assertion.
vpost' :: AccountName -> Amount -> Maybe BalanceAssertion -> Posting vpost' :: AccountName -> Amount -> Maybe BalanceAssertion -> Posting
@ -197,10 +197,11 @@ hasBalanceAssignment p = not (hasAmount p) && isJust (pbalanceassertion p)
accountNamesFromPostings :: [Posting] -> [AccountName] accountNamesFromPostings :: [Posting] -> [AccountName]
accountNamesFromPostings = nubSort . map paccount accountNamesFromPostings = nubSort . map paccount
-- | Sum all amounts from a list of postings.
sumPostings :: [Posting] -> MixedAmount sumPostings :: [Posting] -> MixedAmount
sumPostings = foldl' (\amt p -> maPlus amt $ pamount p) nullmixedamt sumPostings = foldl' (\amt p -> maPlus amt $ pamount p) nullmixedamt
-- | Remove all prices of a posting -- | Strip all prices from a Posting.
postingStripPrices :: Posting -> Posting postingStripPrices :: Posting -> Posting
postingStripPrices = postingTransformAmount mixedAmountStripPrices postingStripPrices = postingTransformAmount mixedAmountStripPrices

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

@ -65,7 +65,7 @@ where
import Data.Default (def) import Data.Default (def)
import Data.List (intercalate, partition) import Data.List (intercalate, partition)
import Data.List.Extra (nubSort) import Data.List.Extra (nubSort)
import Data.Maybe (fromMaybe, mapMaybe) import Data.Maybe (fromMaybe, isJust, mapMaybe)
#if !(MIN_VERSION_base(4,11,0)) #if !(MIN_VERSION_base(4,11,0))
import Data.Semigroup ((<>)) import Data.Semigroup ((<>))
#endif #endif
@ -283,9 +283,8 @@ postingAsLines elideamount onelineamounts acctwidth amtwidth p =
-- amtwidth and thisamtwidth, make sure thisamtwidth does not depend on -- amtwidth and thisamtwidth, make sure thisamtwidth does not depend on
-- amtwidth at all. -- amtwidth at all.
shownAmounts shownAmounts
| elideamount || null (amounts $ pamount p) = [mempty] | elideamount = [mempty]
| otherwise = showAmountsLinesB displayopts . amounts $ pamount p | otherwise = showAmountsLinesB noColour{displayOneLine=onelineamounts} . amounts $ pamount p
where displayopts = noColour{displayOneLine=onelineamounts}
thisamtwidth = maximumDef 0 $ map wbWidth shownAmounts thisamtwidth = maximumDef 0 $ map wbWidth shownAmounts
(samelinecomment, newlinecomments) = (samelinecomment, newlinecomments) =
@ -554,35 +553,35 @@ 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
pamounts = concatMap (amounts . pamount) postings pmixedamounts = map pamount postings
pcommodities = map acommodity pamounts pcommodities = map acommodity $ concatMap amountsRaw pmixedamounts
sumamounts = amounts $ sumPostings postings -- sum normalises to one amount per commodity & price sumamounts = amounts $ maSum pmixedamounts -- sum normalises to one amount per commodity & price
sumcommodities = map acommodity sumamounts sumcommodities = map acommodity sumamounts
sumprices = filter (/=Nothing) $ map aprice sumamounts sumprices = filter isJust $ 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=amt} = case amountsRaw amt of
| caninferprices && ptype p == pt && acommodity a == fromcommodity [a] | caninferprices && ptype p == pt && acommodity a == fromcommodity
= p{pamount=mixedAmount $ a{aprice=Just conversionprice}, poriginal=Just $ originalPosting p} -> p{ pamount=mixedAmount a{aprice=Just conversionprice}
where , poriginal=Just $ originalPosting p}
fromcommodity = head $ filter (`elem` sumcommodities) pcommodities -- these heads are ugly but should be safe where
totalpricesign = if aquantity a < 0 then negate else id fromcommodity = head $ filter (`elem` sumcommodities) pcommodities -- these heads are ugly but should be safe
conversionprice totalpricesign = if aquantity a < 0 then negate else id
| fromcount==1 = TotalPrice $ totalpricesign (abs toamount) `withPrecision` NaturalPrecision conversionprice = case filter (==fromcommodity) pcommodities of
| otherwise = UnitPrice $ abs unitprice `withPrecision` unitprecision [_] -> TotalPrice $ totalpricesign (abs toamount) `withPrecision` NaturalPrecision
where _ -> UnitPrice $ abs unitprice `withPrecision` unitprecision
fromcount = length $ filter ((==fromcommodity).acommodity) pamounts where
fromamount = head $ filter ((==fromcommodity).acommodity) sumamounts fromamount = head $ filter ((==fromcommodity).acommodity) sumamounts
fromprecision = asprecision $ astyle fromamount fromprecision = asprecision $ astyle fromamount
tocommodity = head $ filter (/=fromcommodity) sumcommodities tocommodity = head $ filter (/=fromcommodity) sumcommodities
toamount = head $ filter ((==tocommodity).acommodity) sumamounts toamount = head $ filter ((==tocommodity).acommodity) sumamounts
toprecision = asprecision $ astyle toamount toprecision = asprecision $ astyle toamount
unitprice = (aquantity fromamount) `divideAmount` toamount unitprice = aquantity fromamount `divideAmount` toamount
-- Sum two display precisions, capping the result at the maximum bound -- Sum two display precisions, capping the result at the maximum bound
unitprecision = case (fromprecision, toprecision) of unitprecision = case (fromprecision, toprecision) of
(Precision a, Precision b) -> Precision $ if maxBound - a < b then maxBound else max 2 (a + b) (Precision a, Precision b) -> Precision $ if maxBound - a < b then maxBound else max 2 (a + b)
_ -> NaturalPrecision _ -> NaturalPrecision
inferprice p = p _ -> p
-- Get a transaction's secondary date, defaulting to the primary date. -- Get a transaction's secondary date, defaulting to the primary date.
transactionDate2 :: Transaction -> Day transactionDate2 :: Transaction -> Day
@ -638,8 +637,8 @@ transactionMapPostings :: (Posting -> Posting) -> Transaction -> Transaction
transactionMapPostings f t@Transaction{tpostings=ps} = t{tpostings=map f ps} transactionMapPostings f t@Transaction{tpostings=ps} = t{tpostings=map f ps}
-- | Apply a transformation to a transaction's posting amounts. -- | Apply a transformation to a transaction's posting amounts.
transactionMapPostingAmounts :: (Amount -> Amount) -> Transaction -> Transaction transactionMapPostingAmounts :: (MixedAmount -> MixedAmount) -> Transaction -> Transaction
transactionMapPostingAmounts f = transactionMapPostings (postingTransformAmount (mapMixedAmount f)) transactionMapPostingAmounts f = transactionMapPostings (postingTransformAmount f)
-- | The file path from which this transaction was parsed. -- | The file path from which this transaction was parsed.
transactionFile :: Transaction -> FilePath transactionFile :: Transaction -> FilePath
@ -655,13 +654,13 @@ tests_Transaction =
tests "Transaction" [ tests "Transaction" [
tests "showPostingLines" [ tests "showPostingLines" [
test "null posting" $ showPostingLines posting @?= [""] test "null posting" $ showPostingLines nullposting @?= [" 0"]
, test "non-null posting" $ , test "non-null posting" $
let p = let p =
posting posting
{ pstatus = Cleared { pstatus = Cleared
, paccount = "a" , paccount = "a"
, pamount = Mixed [usd 1, hrs 2] , pamount = mixed [usd 1, hrs 2]
, pcomment = "pcomment1\npcomment2\n tag3: val3 \n" , pcomment = "pcomment1\npcomment2\n tag3: val3 \n"
, ptype = RegularPosting , ptype = RegularPosting
, ptags = [("ptag1", "val1"), ("ptag2", "val2")] , ptags = [("ptag1", "val1"), ("ptag2", "val2")]
@ -742,7 +741,7 @@ tests_Transaction =
[ nullposting [ nullposting
{ pstatus = Cleared { pstatus = Cleared
, paccount = "a" , paccount = "a"
, pamount = Mixed [usd 1, hrs 2] , pamount = mixed [usd 1, hrs 2]
, pcomment = "\npcomment2\n" , pcomment = "\npcomment2\n"
, ptype = RegularPosting , ptype = RegularPosting
, ptags = [("ptag1", "val1"), ("ptag2", "val2")] , ptags = [("ptag1", "val1"), ("ptag2", "val2")]
@ -771,8 +770,8 @@ tests_Transaction =
"coopportunity" "coopportunity"
"" ""
[] []
[ posting {paccount = "expenses:food:groceries", pamount = Mixed [usd 47.18], ptransaction = Just t} [ posting {paccount = "expenses:food:groceries", pamount = mixedAmount (usd 47.18), ptransaction = Just t}
, posting {paccount = "assets:checking", pamount = Mixed [usd (-47.18)], ptransaction = Just t} , posting {paccount = "assets:checking", pamount = mixedAmount (usd (-47.18)), ptransaction = Just t}
] ]
in showTransaction t) @?= in showTransaction t) @?=
(T.unlines (T.unlines
@ -795,8 +794,8 @@ tests_Transaction =
"coopportunity" "coopportunity"
"" ""
[] []
[ posting {paccount = "expenses:food:groceries", pamount = Mixed [usd 47.18]} [ posting {paccount = "expenses:food:groceries", pamount = mixedAmount (usd 47.18)}
, posting {paccount = "assets:checking", pamount = Mixed [usd (-47.19)]} , posting {paccount = "assets:checking", pamount = mixedAmount (usd (-47.19))}
])) @?= ])) @?=
(T.unlines (T.unlines
[ "2007-01-28 coopportunity" [ "2007-01-28 coopportunity"
@ -834,7 +833,7 @@ tests_Transaction =
"x" "x"
"" ""
[] []
[ posting {paccount = "a", pamount = Mixed [num 1 `at` (usd 2 `withPrecision` Precision 0)]} [ posting {paccount = "a", pamount = mixedAmount $ num 1 `at` (usd 2 `withPrecision` Precision 0)}
, posting {paccount = "b", pamount = missingmixedamt} , posting {paccount = "b", pamount = missingmixedamt}
])) @?= ])) @?=
(T.unlines ["2010-01-01 x", " a 1 @ $2", " b", ""]) (T.unlines ["2010-01-01 x", " a 1 @ $2", " b", ""])
@ -855,7 +854,7 @@ tests_Transaction =
"test" "test"
"" ""
[] []
[posting {paccount = "a", pamount = Mixed [usd 1]}, posting {paccount = "b", pamount = Mixed [usd 1]}])) [posting {paccount = "a", pamount = mixedAmount (usd 1)}, posting {paccount = "b", pamount = mixedAmount (usd 1)}]))
,test "detect unbalanced entry, multiple missing amounts" $ ,test "detect unbalanced entry, multiple missing amounts" $
assertLeft $ assertLeft $
balanceTransaction balanceTransaction
@ -889,8 +888,8 @@ tests_Transaction =
"" ""
"" ""
[] []
[posting {paccount = "a", pamount = Mixed [usd 1]}, posting {paccount = "b", pamount = missingmixedamt}])) @?= [posting {paccount = "a", pamount = mixedAmount (usd 1)}, posting {paccount = "b", pamount = missingmixedamt}])) @?=
Right (Mixed [usd (-1)]) Right (mixedAmount $ usd (-1))
,test "conversion price is inferred" $ ,test "conversion price is inferred" $
(pamount . head . tpostings <$> (pamount . head . tpostings <$>
balanceTransaction balanceTransaction
@ -906,10 +905,10 @@ tests_Transaction =
"" ""
"" ""
[] []
[ posting {paccount = "a", pamount = Mixed [usd 1.35]} [ posting {paccount = "a", pamount = mixedAmount (usd 1.35)}
, posting {paccount = "b", pamount = Mixed [eur (-1)]} , posting {paccount = "b", pamount = mixedAmount (eur (-1))}
])) @?= ])) @?=
Right (Mixed [usd 1.35 @@ (eur 1 `withPrecision` NaturalPrecision)]) Right (mixedAmount $ usd 1.35 @@ (eur 1 `withPrecision` NaturalPrecision))
,test "balanceTransaction balances based on cost if there are unit prices" $ ,test "balanceTransaction balances based on cost if there are unit prices" $
assertRight $ assertRight $
balanceTransaction balanceTransaction
@ -925,8 +924,8 @@ tests_Transaction =
"" ""
"" ""
[] []
[ posting {paccount = "a", pamount = Mixed [usd 1 `at` eur 2]} [ posting {paccount = "a", pamount = mixedAmount $ usd 1 `at` eur 2}
, posting {paccount = "a", pamount = Mixed [usd (-2) `at` eur 1]} , posting {paccount = "a", pamount = mixedAmount $ usd (-2) `at` eur 1}
]) ])
,test "balanceTransaction balances based on cost if there are total prices" $ ,test "balanceTransaction balances based on cost if there are total prices" $
assertRight $ assertRight $
@ -943,8 +942,8 @@ tests_Transaction =
"" ""
"" ""
[] []
[ posting {paccount = "a", pamount = Mixed [usd 1 @@ eur 1]} [ posting {paccount = "a", pamount = mixedAmount $ usd 1 @@ eur 1}
, posting {paccount = "a", pamount = Mixed [usd (-2) @@ eur (-1)]} , posting {paccount = "a", pamount = mixedAmount $ usd (-2) @@ eur (-1)}
]) ])
] ]
, tests "isTransactionBalanced" [ , tests "isTransactionBalanced" [
@ -962,8 +961,8 @@ tests_Transaction =
"a" "a"
"" ""
[] []
[ posting {paccount = "b", pamount = Mixed [usd 1.00]} [ posting {paccount = "b", pamount = mixedAmount (usd 1.00)}
, posting {paccount = "c", pamount = Mixed [usd (-1.00)]} , posting {paccount = "c", pamount = mixedAmount (usd (-1.00))}
] ]
,test "detect unbalanced" $ ,test "detect unbalanced" $
assertBool "" $ assertBool "" $
@ -980,8 +979,8 @@ tests_Transaction =
"a" "a"
"" ""
[] []
[ posting {paccount = "b", pamount = Mixed [usd 1.00]} [ posting {paccount = "b", pamount = mixedAmount (usd 1.00)}
, posting {paccount = "c", pamount = Mixed [usd (-1.01)]} , posting {paccount = "c", pamount = mixedAmount (usd (-1.01))}
] ]
,test "detect unbalanced, one posting" $ ,test "detect unbalanced, one posting" $
assertBool "" $ assertBool "" $
@ -998,7 +997,7 @@ tests_Transaction =
"a" "a"
"" ""
[] []
[posting {paccount = "b", pamount = Mixed [usd 1.00]}] [posting {paccount = "b", pamount = mixedAmount (usd 1.00)}]
,test "one zero posting is considered balanced for now" $ ,test "one zero posting is considered balanced for now" $
assertBool "" $ assertBool "" $
isTransactionBalanced Nothing $ isTransactionBalanced Nothing $
@ -1013,7 +1012,7 @@ tests_Transaction =
"a" "a"
"" ""
[] []
[posting {paccount = "b", pamount = Mixed [usd 0]}] [posting {paccount = "b", pamount = mixedAmount (usd 0)}]
,test "virtual postings don't need to balance" $ ,test "virtual postings don't need to balance" $
assertBool "" $ assertBool "" $
isTransactionBalanced Nothing $ isTransactionBalanced Nothing $
@ -1028,9 +1027,9 @@ tests_Transaction =
"a" "a"
"" ""
[] []
[ posting {paccount = "b", pamount = Mixed [usd 1.00]} [ posting {paccount = "b", pamount = mixedAmount (usd 1.00)}
, posting {paccount = "c", pamount = Mixed [usd (-1.00)]} , posting {paccount = "c", pamount = mixedAmount (usd (-1.00))}
, posting {paccount = "d", pamount = Mixed [usd 100], ptype = VirtualPosting} , posting {paccount = "d", pamount = mixedAmount (usd 100), ptype = VirtualPosting}
] ]
,test "balanced virtual postings need to balance among themselves" $ ,test "balanced virtual postings need to balance among themselves" $
assertBool "" $ assertBool "" $
@ -1047,9 +1046,9 @@ tests_Transaction =
"a" "a"
"" ""
[] []
[ posting {paccount = "b", pamount = Mixed [usd 1.00]} [ posting {paccount = "b", pamount = mixedAmount (usd 1.00)}
, posting {paccount = "c", pamount = Mixed [usd (-1.00)]} , posting {paccount = "c", pamount = mixedAmount (usd (-1.00))}
, posting {paccount = "d", pamount = Mixed [usd 100], ptype = BalancedVirtualPosting} , posting {paccount = "d", pamount = mixedAmount (usd 100), ptype = BalancedVirtualPosting}
] ]
,test "balanced virtual postings need to balance among themselves (2)" $ ,test "balanced virtual postings need to balance among themselves (2)" $
assertBool "" $ assertBool "" $
@ -1065,10 +1064,10 @@ tests_Transaction =
"a" "a"
"" ""
[] []
[ posting {paccount = "b", pamount = Mixed [usd 1.00]} [ posting {paccount = "b", pamount = mixedAmount (usd 1.00)}
, posting {paccount = "c", pamount = Mixed [usd (-1.00)]} , posting {paccount = "c", pamount = mixedAmount (usd (-1.00))}
, posting {paccount = "d", pamount = Mixed [usd 100], ptype = BalancedVirtualPosting} , posting {paccount = "d", pamount = mixedAmount (usd 100), ptype = BalancedVirtualPosting}
, posting {paccount = "3", pamount = Mixed [usd (-100)], ptype = BalancedVirtualPosting} , posting {paccount = "3", pamount = mixedAmount (usd (-100)), ptype = BalancedVirtualPosting}
] ]
] ]
] ]

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

@ -114,13 +114,13 @@ tmPostingRuleToFunction querytxt pr =
Just n -> \p -> Just n -> \p ->
-- Multiply the old posting's amount by the posting rule's multiplier. -- Multiply the old posting's amount by the posting rule's multiplier.
let let
pramount = dbg6 "pramount" $ head $ amounts $ pamount pr pramount = dbg6 "pramount" . head . amountsRaw $ pamount pr
matchedamount = dbg6 "matchedamount" $ pamount p matchedamount = dbg6 "matchedamount" $ pamount p
-- Handle a matched amount with a total price carefully so as to keep the transaction balanced (#928). -- Handle a matched amount with a total price carefully so as to keep the transaction balanced (#928).
-- 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
as = dbg6 "multipliedamount" $ n `multiplyMixedAmount` matchedamount as = dbg6 "multipliedamount" $ multiplyMixedAmount n matchedamount
in in
case acommodity pramount of case acommodity pramount of
"" -> as "" -> as
@ -130,10 +130,9 @@ tmPostingRuleToFunction querytxt pr =
c -> mapMixedAmount (\a -> a{acommodity = c, astyle = astyle pramount, aprice = aprice pramount}) 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 = case amountsRaw $ pamount p of
case amounts $ pamount p of [a] | aismultiplier a -> Just $ aquantity a
[a] | aismultiplier a -> Just $ aquantity a _ -> Nothing
_ -> Nothing
renderPostingCommentDates :: Posting -> Posting renderPostingCommentDates :: Posting -> Posting
renderPostingCommentDates p = p { pcomment = comment' } renderPostingCommentDates p = p { pcomment = comment' }

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

@ -16,12 +16,13 @@ For more detailed documentation on each type, see the corresponding modules.
-} -}
{-# LANGUAGE CPP #-}
-- {-# LANGUAGE DeriveAnyClass #-} -- https://hackage.haskell.org/package/deepseq-1.4.4.0/docs/Control-DeepSeq.html#v:rnf -- {-# LANGUAGE DeriveAnyClass #-} -- https://hackage.haskell.org/package/deepseq-1.4.4.0/docs/Control-DeepSeq.html#v:rnf
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE TypeSynonymInstances #-}
module Hledger.Data.Types module Hledger.Data.Types
@ -38,6 +39,10 @@ import Text.Blaze (ToMarkup(..))
--You will eventually need all the values stored. --You will eventually need all the values stored.
--The stored values don't represent large virtual data structures to be lazily computed. --The stored values don't represent large virtual data structures to be lazily computed.
import qualified Data.Map as M import qualified Data.Map as M
import Data.Ord (comparing)
#if !(MIN_VERSION_base(4,11,0))
import Data.Semigroup ((<>))
#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
@ -230,7 +235,38 @@ data Amount = Amount {
aprice :: !(Maybe AmountPrice) -- ^ the (fixed, transaction-specific) price for this amount, if any aprice :: !(Maybe AmountPrice) -- ^ the (fixed, transaction-specific) price for this amount, if any
} deriving (Eq,Ord,Generic,Show) } deriving (Eq,Ord,Generic,Show)
newtype MixedAmount = Mixed [Amount] deriving (Eq,Ord,Generic,Show) newtype MixedAmount = Mixed (M.Map MixedAmountKey Amount) deriving (Eq,Ord,Generic,Show)
-- | Stores the CommoditySymbol of the Amount, along with the CommoditySymbol of
-- the price, and its unit price if being used.
data MixedAmountKey
= MixedAmountKeyNoPrice !CommoditySymbol
| MixedAmountKeyTotalPrice !CommoditySymbol !CommoditySymbol
| MixedAmountKeyUnitPrice !CommoditySymbol !CommoditySymbol !Quantity
deriving (Eq,Generic,Show)
-- | We don't auto-derive the Ord instance because it would give an undesired ordering.
-- We want the keys to be sorted lexicographically:
-- (1) By the primary commodity of the amount.
-- (2) By the commodity of the price, with no price being first.
-- (3) By the unit price, from most negative to most positive, with total prices
-- before unit prices.
-- For example, we would like the ordering to give
-- MixedAmountKeyNoPrice "X" < MixedAmountKeyTotalPrice "X" "Z" < MixedAmountKeyNoPrice "Y"
instance Ord MixedAmountKey where
compare = comparing commodity <> comparing pCommodity <> comparing pPrice
where
commodity (MixedAmountKeyNoPrice c) = c
commodity (MixedAmountKeyTotalPrice c _) = c
commodity (MixedAmountKeyUnitPrice c _ _) = c
pCommodity (MixedAmountKeyNoPrice _) = Nothing
pCommodity (MixedAmountKeyTotalPrice _ pc) = Just pc
pCommodity (MixedAmountKeyUnitPrice _ pc _) = Just pc
pPrice (MixedAmountKeyNoPrice _) = Nothing
pPrice (MixedAmountKeyTotalPrice _ _) = Nothing
pPrice (MixedAmountKeyUnitPrice _ _ q) = Just q
data PostingType = RegularPosting | VirtualPosting | BalancedVirtualPosting data PostingType = RegularPosting | VirtualPosting | BalancedVirtualPosting
deriving (Eq,Show,Generic) deriving (Eq,Show,Generic)

25
hledger-lib/Hledger/Data/Valuation.hs
View File

@ -17,8 +17,9 @@ module Hledger.Data.Valuation (
,ValuationType(..) ,ValuationType(..)
,PriceOracle ,PriceOracle
,journalPriceOracle ,journalPriceOracle
-- ,amountApplyValuation ,amountApplyCostValuation
-- ,amountValueAtDate ,amountApplyValuation
,amountValueAtDate
,mixedAmountApplyCostValuation ,mixedAmountApplyCostValuation
,mixedAmountApplyValuation ,mixedAmountApplyValuation
,mixedAmountValueAtDate ,mixedAmountValueAtDate
@ -105,12 +106,7 @@ priceDirectiveToMarketPrice PriceDirective{..} =
-- See amountApplyValuation and amountCost. -- See amountApplyValuation and amountCost.
mixedAmountApplyCostValuation :: PriceOracle -> M.Map CommoditySymbol AmountStyle -> Day -> Day -> Day -> Costing -> Maybe ValuationType -> MixedAmount -> MixedAmount mixedAmountApplyCostValuation :: PriceOracle -> M.Map CommoditySymbol AmountStyle -> Day -> Day -> Day -> Costing -> Maybe ValuationType -> MixedAmount -> MixedAmount
mixedAmountApplyCostValuation priceoracle styles periodlast today postingdate cost v = mixedAmountApplyCostValuation priceoracle styles periodlast today postingdate cost v =
valuation . costing mapMixedAmount (amountApplyCostValuation priceoracle styles periodlast today postingdate cost v)
where
valuation = maybe id (mixedAmountApplyValuation priceoracle styles periodlast today postingdate) v
costing = case cost of
Cost -> styleMixedAmount styles . mixedAmountCost
NoCost -> id
-- | Apply a specified valuation to this mixed amount, using the -- | Apply a specified valuation to this mixed amount, using the
-- provided price oracle, commodity styles, and reference dates. -- provided price oracle, commodity styles, and reference dates.
@ -119,6 +115,19 @@ mixedAmountApplyValuation :: PriceOracle -> M.Map CommoditySymbol AmountStyle ->
mixedAmountApplyValuation priceoracle styles periodlast today postingdate v = mixedAmountApplyValuation priceoracle styles periodlast today postingdate v =
mapMixedAmount (amountApplyValuation priceoracle styles periodlast today postingdate v) mapMixedAmount (amountApplyValuation priceoracle styles periodlast today postingdate v)
-- | Apply a specified costing and valuation to this Amount,
-- using the provided price oracle, commodity styles, and reference dates.
-- Costing is done first if requested, and after that any valuation.
-- See amountApplyValuation and amountCost.
amountApplyCostValuation :: PriceOracle -> M.Map CommoditySymbol AmountStyle -> Day -> Day -> Day -> Costing -> Maybe ValuationType -> Amount -> Amount
amountApplyCostValuation priceoracle styles periodlast today postingdate cost v =
valuation . costing
where
valuation = maybe id (amountApplyValuation priceoracle styles periodlast today postingdate) v
costing = case cost of
Cost -> styleAmount styles . amountCost
NoCost -> id
-- | Apply a specified valuation to this amount, using the provided -- | Apply a specified valuation to this amount, using the provided
-- price oracle, reference dates, and whether this is for a -- price oracle, reference dates, and whether this is for a
-- multiperiod report or not. Also fix up its display style using the -- multiperiod report or not. Also fix up its display style using the

19
hledger-lib/Hledger/Query.hs
View File

@ -78,7 +78,7 @@ import Text.Megaparsec.Char (char, string)
import Hledger.Utils hiding (words') import Hledger.Utils hiding (words')
import Hledger.Data.Types import Hledger.Data.Types
import Hledger.Data.AccountName import Hledger.Data.AccountName
import Hledger.Data.Amount (nullamt, usd) import Hledger.Data.Amount (amountsRaw, mixedAmount, nullamt, usd)
import Hledger.Data.Dates import Hledger.Data.Dates
import Hledger.Data.Posting import Hledger.Data.Posting
import Hledger.Data.Transaction import Hledger.Data.Transaction
@ -562,8 +562,9 @@ matchesAccount (Tag _ _) _ = False
matchesAccount _ _ = True matchesAccount _ _ = True
matchesMixedAmount :: Query -> MixedAmount -> Bool matchesMixedAmount :: Query -> MixedAmount -> Bool
matchesMixedAmount q (Mixed []) = q `matchesAmount` nullamt matchesMixedAmount q ma = case amountsRaw ma of
matchesMixedAmount q (Mixed as) = any (q `matchesAmount`) as [] -> q `matchesAmount` nullamt
as -> any (q `matchesAmount`) as
matchesCommodity :: Query -> CommoditySymbol -> Bool matchesCommodity :: Query -> CommoditySymbol -> Bool
matchesCommodity (Sym r) = regexMatchText r matchesCommodity (Sym r) = regexMatchText r
@ -614,8 +615,8 @@ matchesPosting (Date2 span) p = span `spanContainsDate` postingDate2 p
matchesPosting (StatusQ s) p = postingStatus p == s matchesPosting (StatusQ s) p = postingStatus p == s
matchesPosting (Real v) p = v == isReal p matchesPosting (Real v) p = v == isReal p
matchesPosting q@(Depth _) Posting{paccount=a} = q `matchesAccount` a matchesPosting q@(Depth _) Posting{paccount=a} = q `matchesAccount` a
matchesPosting q@(Amt _ _) Posting{pamount=amt} = q `matchesMixedAmount` amt matchesPosting q@(Amt _ _) Posting{pamount=as} = q `matchesMixedAmount` as
matchesPosting (Sym r) Posting{pamount=Mixed as} = any (matchesCommodity (Sym r)) $ map acommodity as matchesPosting (Sym r) Posting{pamount=as} = any (matchesCommodity (Sym r)) . map acommodity $ amountsRaw as
matchesPosting (Tag n v) p = case (reString n, v) of matchesPosting (Tag n v) p = case (reString n, v) of
("payee", Just v) -> maybe False (regexMatchText v . transactionPayee) $ ptransaction p ("payee", Just v) -> maybe False (regexMatchText v . transactionPayee) $ ptransaction p
("note", Just v) -> maybe False (regexMatchText v . transactionNote) $ ptransaction p ("note", Just v) -> maybe False (regexMatchText v . transactionNote) $ ptransaction p
@ -811,10 +812,10 @@ tests_Query = tests "Query" [
,test "a tag match on a posting also sees inherited tags" $ assertBool "" $ (Tag (toRegex' "txntag") Nothing) `matchesPosting` nullposting{ptransaction=Just nulltransaction{ttags=[("txntag","")]}} ,test "a tag match on a posting also sees inherited tags" $ assertBool "" $ (Tag (toRegex' "txntag") Nothing) `matchesPosting` nullposting{ptransaction=Just nulltransaction{ttags=[("txntag","")]}}
,test "cur:" $ do ,test "cur:" $ do
let toSym = either id (const $ error' "No query opts") . either error' id . parseQueryTerm (fromGregorian 2000 01 01) . ("cur:"<>) let toSym = either id (const $ error' "No query opts") . either error' id . parseQueryTerm (fromGregorian 2000 01 01) . ("cur:"<>)
assertBool "" $ not $ toSym "$" `matchesPosting` nullposting{pamount=Mixed [usd 1]} -- becomes "^$$", ie testing for null symbol assertBool "" $ not $ toSym "$" `matchesPosting` nullposting{pamount=mixedAmount $ usd 1} -- becomes "^$$", ie testing for null symbol
assertBool "" $ (toSym "\\$") `matchesPosting` nullposting{pamount=Mixed [usd 1]} -- have to quote $ for regexpr assertBool "" $ (toSym "\\$") `matchesPosting` nullposting{pamount=mixedAmount $ usd 1} -- have to quote $ for regexpr
assertBool "" $ (toSym "shekels") `matchesPosting` nullposting{pamount=Mixed [nullamt{acommodity="shekels"}]} assertBool "" $ (toSym "shekels") `matchesPosting` nullposting{pamount=mixedAmount nullamt{acommodity="shekels"}}
assertBool "" $ not $ (toSym "shek") `matchesPosting` nullposting{pamount=Mixed [nullamt{acommodity="shekels"}]} assertBool "" $ not $ (toSym "shek") `matchesPosting` nullposting{pamount=mixedAmount nullamt{acommodity="shekels"}}
] ]
,test "matchesTransaction" $ do ,test "matchesTransaction" $ do

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

@ -407,7 +407,7 @@ journalCheckAccountsDeclared j = sequence_ $ map checkacct $ journalPostings j
-- | Check that all the commodities used in this journal's postings have been declared -- | Check that all the commodities used in this journal's postings have been declared
-- by commodity directives, returning an error message otherwise. -- by commodity directives, returning an error message otherwise.
journalCheckCommoditiesDeclared :: Journal -> Either String () journalCheckCommoditiesDeclared :: Journal -> Either String ()
journalCheckCommoditiesDeclared j = journalCheckCommoditiesDeclared j =
sequence_ $ map checkcommodities $ journalPostings j sequence_ $ map checkcommodities $ journalPostings j
where where
checkcommodities Posting{..} = checkcommodities Posting{..} =
@ -423,7 +423,7 @@ journalCheckCommoditiesDeclared j =
where where
mfirstundeclaredcomm = mfirstundeclaredcomm =
find (`M.notMember` jcommodities j) . map acommodity $ find (`M.notMember` jcommodities j) . map acommodity $
(maybe id ((:) . baamount) pbalanceassertion) (filter (/= missingamt) $ amounts pamount) (maybe id ((:) . baamount) pbalanceassertion) . filter (/= missingamt) $ amountsRaw pamount
setYear :: Year -> JournalParser m () setYear :: Year -> JournalParser m ()

14
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 $ mixedAmount <$> amountp amount <- optional amountp
lift skipNonNewlineSpaces lift skipNonNewlineSpaces
massertion <- optional balanceassertionp massertion <- optional balanceassertionp
lift skipNonNewlineSpaces lift skipNonNewlineSpaces
@ -721,7 +721,7 @@ postingp mTransactionYear = do
, pdate2=mdate2 , pdate2=mdate2
, pstatus=status , pstatus=status
, paccount=account' , paccount=account'
, pamount=amount , pamount=maybe missingmixedamt mixedAmount amount
, pcomment=comment , pcomment=comment
, ptype=ptype , ptype=ptype
, ptags=tags , ptags=tags
@ -823,7 +823,7 @@ tests_JournalReader = tests "JournalReader" [
" expenses:food:dining $10.00 ; a: a a \n ; b: b b \n" " expenses:food:dining $10.00 ; a: a a \n ; b: b b \n"
posting{ posting{
paccount="expenses:food:dining", paccount="expenses:food:dining",
pamount=Mixed [usd 10], pamount=mixedAmount (usd 10),
pcomment="a: a a\nb: b b\n", pcomment="a: a a\nb: b b\n",
ptags=[("a","a a"), ("b","b b")] ptags=[("a","a a"), ("b","b b")]
} }
@ -832,7 +832,7 @@ tests_JournalReader = tests "JournalReader" [
" a 1. ; date:2012/11/28, date2=2012/11/29,b:b\n" " a 1. ; date:2012/11/28, date2=2012/11/29,b:b\n"
nullposting{ nullposting{
paccount="a" paccount="a"
,pamount=Mixed [num 1] ,pamount=mixedAmount (num 1)
,pcomment="date:2012/11/28, date2=2012/11/29,b:b\n" ,pcomment="date:2012/11/28, date2=2012/11/29,b:b\n"
,ptags=[("date", "2012/11/28"), ("date2=2012/11/29,b", "b")] -- TODO tag name parsed too greedily ,ptags=[("date", "2012/11/28"), ("date2=2012/11/29,b", "b")] -- TODO tag name parsed too greedily
,pdate=Just $ fromGregorian 2012 11 28 ,pdate=Just $ fromGregorian 2012 11 28
@ -843,7 +843,7 @@ tests_JournalReader = tests "JournalReader" [
" a 1. ; [2012/11/28=2012/11/29]\n" " a 1. ; [2012/11/28=2012/11/29]\n"
nullposting{ nullposting{
paccount="a" paccount="a"
,pamount=Mixed [num 1] ,pamount=mixedAmount (num 1)
,pcomment="[2012/11/28=2012/11/29]\n" ,pcomment="[2012/11/28=2012/11/29]\n"
,ptags=[] ,ptags=[]
,pdate= Just $ fromGregorian 2012 11 28 ,pdate= Just $ fromGregorian 2012 11 28
@ -872,7 +872,7 @@ tests_JournalReader = tests "JournalReader" [
"= (some value expr)\n some:postings 1.\n" "= (some value expr)\n some:postings 1.\n"
nulltransactionmodifier { nulltransactionmodifier {
tmquerytxt = "(some value expr)" tmquerytxt = "(some value expr)"
,tmpostingrules = [nullposting{paccount="some:postings", pamount=Mixed[num 1]}] ,tmpostingrules = [nullposting{paccount="some:postings", pamount=mixedAmount (num 1)}]
} }
] ]
@ -905,7 +905,7 @@ tests_JournalReader = tests "JournalReader" [
pdate=Nothing, pdate=Nothing,
pstatus=Cleared, pstatus=Cleared,
paccount="a", paccount="a",
pamount=Mixed [usd 1], pamount=mixedAmount (usd 1),
pcomment="pcomment1\npcomment2\nptag1: val1\nptag2: val2\n", pcomment="pcomment1\npcomment2\nptag1: val1\nptag2: val2\n",
ptype=RegularPosting, ptype=RegularPosting,
ptags=[("ptag1","val1"),("ptag2","val2")], ptags=[("ptag1","val1"),("ptag2","val2")],

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

@ -182,7 +182,7 @@ entryp = do
tstatus = Cleared, tstatus = Cleared,
tpostings = [ tpostings = [
nullposting{paccount=a nullposting{paccount=a
,pamount=Mixed [amountSetPrecision (Precision 2) $ num hours] -- don't assume hours; do set precision to 2 ,pamount=mixedAmount . amountSetPrecision (Precision 2) $ num hours -- don't assume hours; do set precision to 2
,ptype=VirtualPosting ,ptype=VirtualPosting
,ptransaction=Just t ,ptransaction=Just t
} }

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

@ -90,7 +90,7 @@ Right samplejournal2 =
tcomment="", tcomment="",
ttags=[], ttags=[],
tpostings= tpostings=
[posting {paccount="assets:bank:checking", pamount=Mixed [usd 1]} [posting {paccount="assets:bank:checking", pamount=mixedAmount (usd 1)}
,posting {paccount="income:salary", pamount=missingmixedamt} ,posting {paccount="income:salary", pamount=missingmixedamt}
], ],
tprecedingcomment="" tprecedingcomment=""

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

@ -170,7 +170,7 @@ postingsReportItems ((p,menddate):ps) (pprev,menddateprev) wd d b runningcalcfn
isdifferentdate = case wd of PrimaryDate -> postingDate p /= postingDate pprev isdifferentdate = case wd of PrimaryDate -> postingDate p /= postingDate pprev
SecondaryDate -> postingDate2 p /= postingDate2 pprev SecondaryDate -> postingDate2 p /= postingDate2 pprev
p' = p{paccount= clipOrEllipsifyAccountName d $ paccount p} p' = p{paccount= clipOrEllipsifyAccountName d $ paccount p}
b' = runningcalcfn itemnum b (pamount p) b' = runningcalcfn itemnum b $ pamount p
-- | Generate one postings report line item, containing the posting, -- | Generate one postings report line item, containing the posting,
-- the current running balance, and optionally the posting date and/or -- the current running balance, and optionally the posting date and/or
@ -231,7 +231,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 = maNegate $ pamount p } negatePostingAmount = postingTransformAmount negate
-- tests -- tests

2
hledger-ui/Hledger/UI/TransactionScreen.hs
View File

@ -72,7 +72,7 @@ tsDraw UIState{aopts=UIOpts{cliopts_=copts@CliOpts{reportspec_=rspec@ReportSpec{
_ -> [maincontent] _ -> [maincontent]
where where
-- as with print, show amounts with all of their decimal places -- as with print, show amounts with all of their decimal places
t = transactionMapPostingAmounts amountSetFullPrecision t' t = transactionMapPostingAmounts mixedAmountSetFullPrecision t'
maincontent = Widget Greedy Greedy $ do maincontent = Widget Greedy Greedy $ do
let let
prices = journalPriceOracle (infer_value_ ropts) j prices = journalPriceOracle (infer_value_ ropts) j

2
hledger-web/Hledger/Web/Widget/AddForm.hs
View File

@ -158,7 +158,7 @@ validatePostings acctRes amtRes = let
zipRow (Left e) (Left e') = Left (Just e, Just e') zipRow (Left e) (Left e') = Left (Just e, Just e')
zipRow (Left e) (Right _) = Left (Just e, Nothing) zipRow (Left e) (Right _) = Left (Just e, Nothing)
zipRow (Right _) (Left e) = Left (Nothing, Just e) zipRow (Right _) (Left e) = Left (Nothing, Just e)
zipRow (Right acct) (Right amt) = Right (nullposting {paccount = acct, pamount = Mixed [amt]}) zipRow (Right acct) (Right amt) = Right (nullposting {paccount = acct, pamount = mixedAmount amt})
errorToFormMsg = first (("Invalid value: " <>) . T.pack . errorToFormMsg = first (("Invalid value: " <>) . T.pack .
foldl (\s a -> s <> parseErrorTextPretty a) "" . foldl (\s a -> s <> parseErrorTextPretty a) "" .

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

@ -233,7 +233,7 @@ confirmedTransactionWizard prevInput es@EntryState{..} stack@(currentStage : _)
EnterAmountAndComment txnParams account -> amountAndCommentWizard prevInput es >>= \case EnterAmountAndComment txnParams account -> amountAndCommentWizard prevInput es >>= \case
Just (amount, comment) -> do Just (amount, comment) -> do
let posting = nullposting{paccount=T.pack $ stripbrackets account let posting = nullposting{paccount=T.pack $ stripbrackets account
,pamount=Mixed [amount] ,pamount=mixedAmount amount
,pcomment=comment ,pcomment=comment
,ptype=accountNamePostingType $ T.pack account ,ptype=accountNamePostingType $ T.pack account
} }

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

@ -98,7 +98,7 @@ close CliOpts{rawopts_=rawopts, reportspec_=rspec} j = do
closingps = closingps =
concat [ concat [
[posting{paccount = a [posting{paccount = a
,pamount = mixed [precise $ negate b] ,pamount = mixedAmount . precise $ negate b
-- after each commodity's last posting, assert 0 balance (#1035) -- after each commodity's last posting, assert 0 balance (#1035)
-- balance assertion amounts are unpriced (#824) -- balance assertion amounts are unpriced (#824)
,pbalanceassertion = ,pbalanceassertion =
@ -108,11 +108,11 @@ close CliOpts{rawopts_=rawopts, reportspec_=rspec} j = do
} }
] ]
-- maybe an interleaved posting transferring this balance to equity -- maybe an interleaved posting transferring this balance to equity
++ [posting{paccount=closingacct, pamount=Mixed [precise b]} | interleaved] ++ [posting{paccount=closingacct, pamount=mixedAmount $ precise b} | interleaved]
| -- get the balances for each commodity and transaction price | -- get the balances for each commodity and transaction price
(a,_,_,mb) <- acctbals (a,_,_,mb) <- acctbals
, let bs = amounts $ normaliseMixedAmount mb , let bs = amounts mb
-- mark the last balance in each commodity with True -- mark the last balance in each commodity with True
, let bs' = concat [reverse $ zip (reverse bs) (True : repeat False) , let bs' = concat [reverse $ zip (reverse bs) (True : repeat False)
| bs <- groupBy ((==) `on` acommodity) bs] | bs <- groupBy ((==) `on` acommodity) bs]
@ -121,21 +121,21 @@ close CliOpts{rawopts_=rawopts, reportspec_=rspec} j = do
-- or a final multicommodity posting transferring all balances to equity -- or a final multicommodity posting transferring all balances to equity
-- (print will show this as multiple single-commodity postings) -- (print will show this as multiple single-commodity postings)
++ [posting{paccount=closingacct, pamount=if explicit then mapMixedAmount precise totalamt else missingmixedamt} | not interleaved] ++ [posting{paccount=closingacct, pamount=if explicit then mixedAmountSetFullPrecision totalamt else missingmixedamt} | not interleaved]
-- the opening transaction -- the opening transaction
openingtxn = nulltransaction{tdate=openingdate, tdescription=openingdesc, tpostings=openingps} openingtxn = nulltransaction{tdate=openingdate, tdescription=openingdesc, tpostings=openingps}
openingps = openingps =
concat [ concat [
[posting{paccount = a [posting{paccount = a
,pamount = mixed [precise b] ,pamount = mixedAmount $ precise b
,pbalanceassertion = ,pbalanceassertion =
case mcommoditysum of case mcommoditysum of
Just s -> Just nullassertion{baamount=precise s{aprice=Nothing}} Just s -> Just nullassertion{baamount=precise s{aprice=Nothing}}
Nothing -> Nothing Nothing -> Nothing
} }
] ]
++ [posting{paccount=openingacct, pamount=Mixed [precise $ negate b]} | interleaved] ++ [posting{paccount=openingacct, pamount=mixedAmount . precise $ negate b} | interleaved]
| (a,_,_,mb) <- acctbals | (a,_,_,mb) <- acctbals
, let bs = amounts $ normaliseMixedAmount mb , let bs = amounts $ normaliseMixedAmount mb
@ -145,7 +145,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 (maNegate totalamt) else missingmixedamt} | not interleaved] ++ [posting{paccount=openingacct, pamount=if explicit then mixedAmountSetFullPrecision (maNegate totalamt) else missingmixedamt} | not interleaved]
-- print them -- print them
when closing . T.putStr $ showTransaction closingtxn when closing . T.putStr $ showTransaction closingtxn

11
hledger/Hledger/Cli/Commands/Prices.hs
View File

@ -33,7 +33,7 @@ prices opts j = do
ps = filter (matchesPosting q) $ allPostings j ps = filter (matchesPosting q) $ allPostings j
mprices = jpricedirectives j mprices = jpricedirectives j
cprices = map (stylePriceDirectiveExceptPrecision styles) $ concatMap postingsPriceDirectivesFromCosts ps cprices = map (stylePriceDirectiveExceptPrecision styles) $ concatMap postingsPriceDirectivesFromCosts ps
icprices = map (stylePriceDirectiveExceptPrecision styles) $ concatMap postingsPriceDirectivesFromCosts $ mapAmount invertPrice ps icprices = map (stylePriceDirectiveExceptPrecision styles) $ concatMap postingsPriceDirectivesFromCosts $ map (postingTransformAmount $ mapMixedAmount invertPrice) ps
allprices = mprices ++ ifBoolOpt "costs" cprices ++ ifBoolOpt "inverted-costs" icprices allprices = mprices ++ ifBoolOpt "costs" cprices ++ ifBoolOpt "inverted-costs" icprices
mapM_ (T.putStrLn . showPriceDirective) $ mapM_ (T.putStrLn . showPriceDirective) $
sortOn pddate $ sortOn pddate $
@ -71,8 +71,8 @@ invertPrice a =
pa' = pa { aquantity = abs $ aquantity a, acommodity = acommodity a, aprice = Nothing, astyle = astyle a } pa' = pa { aquantity = abs $ aquantity a, acommodity = acommodity a, aprice = Nothing, astyle = astyle a }
postingsPriceDirectivesFromCosts :: Posting -> [PriceDirective] postingsPriceDirectivesFromCosts :: Posting -> [PriceDirective]
postingsPriceDirectivesFromCosts p = mapMaybe (amountPriceDirectiveFromCost date) . amounts $ pamount p where postingsPriceDirectivesFromCosts p = mapMaybe (amountPriceDirectiveFromCost date) . amountsRaw $ pamount p
date = fromMaybe (tdate . fromJust $ ptransaction p) $ pdate p where date = fromMaybe (tdate . fromJust $ ptransaction p) $ pdate p
amountPriceDirectiveFromCost :: Day -> Amount -> Maybe PriceDirective amountPriceDirectiveFromCost :: Day -> Amount -> Maybe PriceDirective
amountPriceDirectiveFromCost d a = amountPriceDirectiveFromCost d a =
@ -92,8 +92,3 @@ stylePriceDirectiveExceptPrecision styles pd@PriceDirective{pdamount=a} =
allPostings :: Journal -> [Posting] allPostings :: Journal -> [Posting]
allPostings = concatMap tpostings . jtxns allPostings = concatMap tpostings . jtxns
mapAmount :: (Amount -> Amount) -> [Posting] -> [Posting]
mapAmount f = map pf where
pf p = p { pamount = mf (pamount p) }
mf = mixed . map f . amounts

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

@ -59,7 +59,7 @@ print' opts j = do
-- that. For now we try to reverse it by increasing all amounts' decimal places -- that. For now we try to reverse it by increasing all amounts' decimal places
-- sufficiently to show the amount exactly. The displayed amounts may have minor -- sufficiently to show the amount exactly. The displayed amounts may have minor
-- differences from the originals, such as trailing zeroes added. -- differences from the originals, such as trailing zeroes added.
let j' = journalMapPostingAmounts amountSetFullPrecision j let j' = journalMapPostingAmounts mixedAmountSetFullPrecision j
case maybestringopt "match" $ rawopts_ opts of case maybestringopt "match" $ rawopts_ opts of
Nothing -> printEntries opts j' Nothing -> printEntries opts j'
Just desc -> printMatch opts j' $ T.pack $ dbg1 "finding best match for description" desc Just desc -> printMatch opts j' $ T.pack $ dbg1 "finding best match for description" desc
@ -181,7 +181,7 @@ 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 $ pamount p . amounts $ pamount p
where where
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)

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

@ -190,7 +190,7 @@ postingsReportItemAsText opts preferredamtwidth preferredbalwidth (mdate, mendda
BalancedVirtualPosting -> (wrap "[" "]", acctwidth-2) BalancedVirtualPosting -> (wrap "[" "]", acctwidth-2)
VirtualPosting -> (wrap "(" ")", acctwidth-2) VirtualPosting -> (wrap "(" ")", acctwidth-2)
_ -> (id,acctwidth) _ -> (id,acctwidth)
amt = showAmountsLinesB dopts . (\x -> if null x then [nullamt] else x) . amounts $ pamount p amt = showAmountsLinesB dopts . (\x -> if null x then [nullamt] else x) . amountsRaw $ pamount p
bal = showAmountsLinesB dopts $ amounts b bal = showAmountsLinesB dopts $ amounts b
-- Since postingsReport strips prices from all Amounts when not used, we can display prices. -- Since postingsReport strips prices from all Amounts when not used, we can display prices.
dopts = oneLine{displayColour=color_, displayPrice=True} dopts = oneLine{displayColour=color_, displayPrice=True}

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

@ -82,7 +82,7 @@ showLedgerStats l today span =
path = journalFilePath j path = journalFilePath j
ts = sortOn tdate $ filter (spanContainsDate span . tdate) $ jtxns j ts = sortOn tdate $ filter (spanContainsDate span . tdate) $ jtxns j
as = nub $ map paccount $ concatMap tpostings ts as = nub $ map paccount $ concatMap tpostings ts
cs = either error' Map.keys $ commodityStylesFromAmounts $ concatMap (amounts . pamount) $ concatMap tpostings ts -- PARTIAL: cs = either error' Map.keys . commodityStylesFromAmounts . concatMap (amountsRaw . pamount) $ concatMap tpostings ts -- PARTIAL:
lastdate | null ts = Nothing lastdate | null ts = Nothing
| otherwise = Just $ tdate $ last ts | otherwise = Just $ tdate $ last ts
lastelapsed = fmap (diffDays today) lastdate lastelapsed = fmap (diffDays today) lastdate