87: fix an arithmetic and transaction balancing bug with multiple total-priced amounts

hledger-lib/Hledger/Data/Amount.hs

@@ -51,6 +51,7 @@ module Hledger.Data.Amount (
   -- ** arithmetic
   costOfAmount,
   divideAmount,
+  sumAmounts,
   -- ** rendering
   showAmount,
   showAmountDebug,
@@ -62,6 +63,7 @@ module Hledger.Data.Amount (
   missingmixedamt,
   amounts,
   normaliseMixedAmountPreservingFirstPrice,
+  normaliseMixedAmountPreservingPrices,
   canonicaliseMixedAmountCommodity,
   mixedAmountWithCommodity,
   setMixedAmountPrecision,
@@ -77,6 +79,7 @@ module Hledger.Data.Amount (
   showMixedAmountWithoutPrice,
   showMixedAmountWithPrecision,
   -- * misc.
+  ltraceamount,
   tests_Hledger_Data_Amount
 ) where
 
@@ -125,6 +128,24 @@ similarAmountsOp op a@(Amount Commodity{precision=ap} _ _) (Amount bc@Commodity{
 amountWithCommodity :: Commodity -> Amount -> Amount
 amountWithCommodity c (Amount _ q _) = Amount c q Nothing
 
+-- | A more complete amount adding operation.
+sumAmounts :: [Amount] -> MixedAmount
+sumAmounts = normaliseMixedAmountPreservingPrices . Mixed
+
+tests_sumAmounts = [
+  "sumAmounts" ~: do
+    -- when adding, we don't convert to the price commodity - just
+    -- combine what amounts we can.
+    -- amounts with same unit price
+    (sumAmounts [(Amount dollar 1 (Just $ UnitPrice $ Mixed [euros 1])), (Amount dollar 1 (Just $ UnitPrice $ Mixed [euros 1]))])
+     `is` (Mixed [Amount dollar 2 (Just $ UnitPrice $ Mixed [euros 1])])
+    -- amounts with different unit prices
+    -- amounts with total prices
+    (sumAmounts  [(Amount dollar 1 (Just $ TotalPrice $ Mixed [euros 1])), (Amount dollar 1 (Just $ TotalPrice $ Mixed [euros 1]))])
+     `is` (Mixed [(Amount dollar 1 (Just $ TotalPrice $ Mixed [euros 1])), (Amount dollar 1 (Just $ TotalPrice $ Mixed [euros 1]))])
+    -- amounts with no, unit, and/or total prices
+ ]
+
 -- | Convert an amount to the commodity of its assigned price, if any.  Notes:
 --
 -- - price amounts must be MixedAmounts with exactly one component Amount (or there will be a runtime error)
@@ -284,9 +305,9 @@ missingamt = Amount unknown{symbol="AUTO"} 0 Nothing
 missingmixedamt :: MixedAmount
 missingmixedamt = Mixed [missingamt]
 
--- | Simplify a mixed amount's component amounts: combine amounts with the
+-- | Simplify a mixed amount's component amounts: we can combine amounts
--- same commodity and price. Also remove any zero or missing amounts and
+-- with the same commodity and unit price. Also remove any zero or missing
--- replace an empty amount list with a single zero amount.
+-- amounts and replace an empty amount list with a single zero amount.
 normaliseMixedAmountPreservingPrices :: MixedAmount -> MixedAmount
 normaliseMixedAmountPreservingPrices (Mixed as) = Mixed as''
     where
@@ -294,13 +315,29 @@ normaliseMixedAmountPreservingPrices (Mixed as) = Mixed as''
       (_,nonzeros) = partition isReallyZeroAmount $ filter (/= missingamt) as'
       as' = map sumAmountsUsingFirstPrice $ group $ sort as
       sort = sortBy (\a1 a2 -> compare (sym a1,price a1) (sym a2,price a2))
-      group = groupBy (\a1 a2 -> sym a1 == sym a2 && price a1 == price a2)
       sym = symbol . commodity
+      group = groupBy (\a1 a2 -> sym a1 == sym a2 && sameunitprice a1 a2)
+        where
+          sameunitprice a1 a2 =
+            case (price a1, price a2) of
+              (Nothing, Nothing) -> True
+              (Just (UnitPrice p1), Just (UnitPrice p2)) -> p1 == p2
+              _ -> False
 
 tests_normaliseMixedAmountPreservingPrices = [
   "normaliseMixedAmountPreservingPrices" ~: do
-   -- assertEqual "" (Mixed [dollars 2]) (normaliseMixedAmountPreservingPrices $ Mixed [dollars 0, dollars 2])
+   assertEqual "discard missing amount" (Mixed [nullamt]) (normaliseMixedAmountPreservingPrices $ Mixed [dollars 0, missingamt])
-   assertEqual "" (Mixed [nullamt]) (normaliseMixedAmountPreservingPrices $ Mixed [dollars 0, missingamt])
+   assertEqual "combine unpriced same-commodity amounts" (Mixed [dollars 2]) (normaliseMixedAmountPreservingPrices $ Mixed [dollars 0, dollars 2])
+   assertEqual "don't combine total-priced amounts"
+     (Mixed
+      [Amount dollar 1    (Just $ TotalPrice $ Mixed [euros 1])
+      ,Amount dollar (-2) (Just $ TotalPrice $ Mixed [euros 1])
+      ])
+     (normaliseMixedAmountPreservingPrices $ Mixed
+      [Amount dollar 1    (Just $ TotalPrice $ Mixed [euros 1])
+      ,Amount dollar (-2) (Just $ TotalPrice $ Mixed [euros 1])
+      ])
+
  ]
 
 -- | Simplify a mixed amount's component amounts: combine amounts with
@@ -379,6 +416,10 @@ mixedAmountWithCommodity c (Mixed as) = Amount c total Nothing
 showMixedAmount :: MixedAmount -> String
 showMixedAmount m = vConcatRightAligned $ map showAmount $ amounts $ normaliseMixedAmountPreservingFirstPrice m
 
+-- | Compact labelled trace of a mixed amount.
+ltraceamount :: String -> MixedAmount -> MixedAmount
+ltraceamount s = tracewith (((s ++ ": ") ++).showMixedAmount)
+
 -- | Set the display precision in the amount's commodities.
 setMixedAmountPrecision :: Int -> MixedAmount -> MixedAmount
 setMixedAmountPrecision p (Mixed as) = Mixed $ map (setAmountPrecision p) as
@@ -416,6 +457,7 @@ canonicaliseMixedAmountCommodity canonicalcommoditymap (Mixed as) = Mixed $ map
 
 tests_Hledger_Data_Amount = TestList $
      tests_normaliseMixedAmountPreservingPrices
+  ++ tests_sumAmounts
   ++ [
 
   -- Amount
@@ -436,7 +478,7 @@ tests_Hledger_Data_Amount = TestList $
     let b = (dollars 1){price=Just $ UnitPrice $ Mixed [euros 2]}
     negate b `is` b{quantity=(-1)}
 
-  ,"adding amounts" ~: do
+  ,"adding amounts without prices" ~: do
     let a1 = dollars 1.23
     let a2 = dollars (-1.23)
     let a3 = dollars (-1.23)
@@ -474,6 +516,15 @@ tests_Hledger_Data_Amount = TestList $
               Amount dollar (-0.25) Nothing])
       `is` Mixed [Amount unknown 0 Nothing]
 
+  ,"adding mixed amounts with total prices" ~: do
+    (sum $ map (Mixed . (\a -> [a]))
+     [Amount dollar 1    (Just $ TotalPrice $ Mixed [euros 1])
+     ,Amount dollar (-2) (Just $ TotalPrice $ Mixed [euros 1])
+     ])
+      `is` (Mixed [Amount dollar 1    (Just $ TotalPrice $ Mixed [euros 1])
+                  ,Amount dollar (-2) (Just $ TotalPrice $ Mixed [euros 1])
+                  ])
+
   ,"showMixedAmount" ~: do
     showMixedAmount (Mixed [dollars 1]) `is` "$1.00"
     showMixedAmount (Mixed [(dollars 1){price=Just $ UnitPrice $ Mixed [euros 2]}]) `is` "$1.00 @ €2.00"

hledger-lib/Hledger/Data/Transaction.hs

@@ -455,12 +455,14 @@ tests_Hledger_Data_Transaction = TestList $ concat [
                             [Posting False "a" (Mixed [dollars 1]) "" RegularPosting [] Nothing,
                              Posting False "b" (Mixed [dollars 1]) "" RegularPosting [] Nothing
                             ] ""))
+
      assertBool "detect unbalanced entry, multiple missing amounts"
                     (isLeft $ balanceTransaction Nothing
                            (Transaction (parsedate "2007/01/28") Nothing False "" "test" "" []
                             [Posting False "a" missingmixedamt "" RegularPosting [] Nothing,
                              Posting False "b" missingmixedamt "" RegularPosting [] Nothing
                             ] ""))
+
      let e = balanceTransaction Nothing (Transaction (parsedate "2007/01/28") Nothing False "" "" "" []
                            [Posting False "a" (Mixed [dollars 1]) "" RegularPosting [] Nothing,
                             Posting False "b" missingmixedamt "" RegularPosting [] Nothing
@@ -471,6 +473,7 @@ tests_Hledger_Data_Transaction = TestList $ concat [
                      (case e of
                         Right e' -> (pamount $ last $ tpostings e')
                         Left _ -> error' "should not happen")
+
      let e = balanceTransaction Nothing (Transaction (parsedate "2011/01/01") Nothing False "" "" "" []
                            [Posting False "a" (Mixed [dollars 1.35]) "" RegularPosting [] Nothing,
                             Posting False "b" (Mixed [euros   (-1)]) "" RegularPosting [] Nothing
@@ -486,6 +489,18 @@ tests_Hledger_Data_Transaction = TestList $ concat [
                         Right e' -> (pamount $ head $ tpostings e')
                         Left _ -> error' "should not happen")
 
+     assertBool "balanceTransaction balances based on cost if there are unit prices" (isRight $
+       balanceTransaction Nothing (Transaction (parsedate "2011/01/01") Nothing False "" "" "" []
+                           [Posting False "a" (Mixed [Amount dollar 1    (Just $ UnitPrice $ Mixed [euros 2])]) "" RegularPosting [] Nothing
+                           ,Posting False "a" (Mixed [Amount dollar (-2) (Just $ UnitPrice $ Mixed [euros 1])]) "" RegularPosting [] Nothing
+                           ] ""))
+
+     assertBool "balanceTransaction balances based on cost if there are total prices" (isRight $
+       balanceTransaction Nothing (Transaction (parsedate "2011/01/01") Nothing False "" "" "" []
+                           [Posting False "a" (Mixed [Amount dollar 1    (Just $ TotalPrice $ Mixed [euros 1])]) "" RegularPosting [] Nothing
+                           ,Posting False "a" (Mixed [Amount dollar (-2) (Just $ TotalPrice $ Mixed [euros 1])]) "" RegularPosting [] Nothing
+                           ] ""))
+
   ,"isTransactionBalanced" ~: do
      let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" []
              [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting [] (Just t)

tests/87-wrong-balance.test

@@ -0,0 +1,53 @@
+# 1. issue 87, hledger should give this balance.
+hledgerdev -f - balance --no-total b
+<<<
+1/1
+    a  -553.653 X @@ 2609.92
+    a    -5.684 X @@ 26.10
+    a   -50.833 X @@ 234.90
+    a   -49.714 X @@ 234.90
+    a   -49.957 X @@ 234.90
+    a   -49.778 X @@ 234.90
+    a  -142.316 X @@ 674.01
+    a   -49.029 X @@ 234.90
+    a   -51.233 X @@ 234.90
+    a   -49.204 X @@ 234.90
+    a   -49.474 X @@ 234.90
+    a   -47.773 X @@ 234.90
+    a  -109.439 X @@ 576.96
+    a   -31.133 X @@ 171.51
+    a  -438.249 X @@ 2537.90
+    a   -11.927 X @@ 72.03
+    a  -170.721 X @@ 990.18
+    a  1910.117 X @@ 10742.52
+    b
+>>>
+             -969.81  b
+>>>= 0
+
+# 2. As above, but the prices have a commodity - should work the same.
+hledgerdev -f - balance --no-total b
+<<<
+1/1
+    a  -553.653 X @@ 2609.92 Y
+    a    -5.684 X @@ 26.10 Y
+    a   -50.833 X @@ 234.90 Y
+    a   -49.714 X @@ 234.90 Y
+    a   -49.957 X @@ 234.90 Y
+    a   -49.778 X @@ 234.90 Y
+    a  -142.316 X @@ 674.01 Y
+    a   -49.029 X @@ 234.90 Y
+    a   -51.233 X @@ 234.90 Y
+    a   -49.204 X @@ 234.90 Y
+    a   -49.474 X @@ 234.90 Y
+    a   -47.773 X @@ 234.90 Y
+    a  -109.439 X @@ 576.96 Y
+    a   -31.133 X @@ 171.51 Y
+    a  -438.249 X @@ 2537.90 Y
+    a   -11.927 X @@ 72.03 Y
+    a  -170.721 X @@ 990.18 Y
+    a  1910.117 X @@ 10742.52 Y
+    b
+>>>
+           -969.81 Y  b
+>>>= 0

tests/prices.test

@@ -76,7 +76,179 @@ hledgerdev -f - print
 
 >>>=0
 
-# # 6. when the *cost-basis* balance has exactly two commodities, both
+## 6. another, from ledger tests. Just one posting to price so uses @@.
+hledgerdev -f - print
+<<<
+2002/09/30 * 1a1a6305d06ce4b284dba0d267c23f69d70c20be
+    c56a21d23a6535184e7152ee138c28974f14280c  866.231000 GGGGG
+    a35e82730cf91569c302b313780e5895f75a62b9   $-17,783.72
+>>>
+2002/09/30 * 1a1a6305d06ce4b284dba0d267c23f69d70c20be
+    c56a21d23a6535184e7152ee138c28974f14280c  866.231000 GGGGG @@ $17,783.72
+    a35e82730cf91569c302b313780e5895f75a62b9   $-17,783.72
+
+>>>=0
+
+# 7. when the balance has more than two commodities, don't bother
+hledgerdev -f - print
+<<<
+2011/01/01
+    expenses:foreign currency       €100
+    assets                         $-135
+    expenses:other                  £200
+>>>= !0
+
+# 8. another
+hledgerdev -f - balance -B
+<<<
+2011/01/01
+    expenses:foreign currency        €99
+    assets                         $-130
+    expenses:foreign currency         €1
+    assets                           $-5
+>>>
+               $-135  assets
+                $135  expenses:foreign currency
+--------------------
+                   0
+>>>=0
+
+# 9. transaction in two commodities should balance out properly
+hledgerdev -f - balance --cost
+<<<
+2011/01/01 x
+  a  10£ @@ 16$
+  b
+>>>
+                 16$  a
+                -16$  b
+--------------------
+                   0
+>>>=0
+
+# 10. When commodity price is specified implicitly, transaction should
+#     be considered balanced out even when first amount is negative
+#     (that is, price for it should be determined properly, with proper sign)
+hledgerdev -f - balance
+<<<
+2011/01/01 x
+  a  -10£
+  b  16$
+>>>
+                -10£  a
+                 16$  b
+--------------------
+                 16$
+                -10£
+>>>=0
+
+# 11. When commodity price is specified implicitly, transaction should
+#     NOT be considered balanced out when BOTH amounts are negative
+hledgerdev -f - balance
+<<<
+2011/01/01 x
+  a  -10£
+  b  -16$
+>>>
+>>>=1
+
+# 12. Differently-priced lots of a commodity should be merged in balance report
+hledgerdev -f - balance
+<<<
+2011/1/1
+  (a)   £1 @ $2
+
+2011/1/1
+  (a)   £1 @ $3
+>>>
+                  £2  a
+--------------------
+                  £2
+>>>=0
+
+# 13. this should balance
+hledgerdev -f - balance
+<<<
+2011/1/1
+    a  1h @ $10
+    b  1h @ $20
+    c  $-30
+>>>= 0
+
+# 14. this should balance, ignoring the P
+hledgerdev -f - balance
+<<<
+P 2011/11/15 EUR CHF 1.234
+2011/11/19
+    a                             EUR 1000.00
+    b                             CHF -1254
+>>>= 0
+
+# 15. these balance because of the unit prices, and should parse successfully
+hledgerdev -f - balance --no-total
+<<<
+1/1
+    a   1X @ 2Y
+    a  -2X @ 1Y
+>>>
+                 -1X  a
+>>>= 0
+
+# 16.
+hledgerdev -f - balance --no-total -B
+<<<
+1/1
+    a   1X @ 2Y
+    a  -2X @ 1Y
+>>>
+>>>= 0
+
+# 17. likewise with total prices. Note how the primary amount's sign is used.
+hledgerdev -f - balance --no-total
+<<<
+1/1
+    a   1X @@ 1Y
+    a  -2X @@ 1Y
+>>>
+                 -1X  a
+>>>= 0
+
+# 18. 
+hledgerdev -f - balance --no-total -B
+<<<
+1/1
+    a   1X @@ 1Y
+    a  -2X @@ 1Y
+>>>
+>>>= 0
+
+# 19. here, a's primary amount is 0, and its cost is 1Y; b is the assigned auto-balancing amount of -1Y (per issue 69)
+hledgerdev -f - balance --no-total -E
+<<<
+1/1
+    a   1X @@ 1Y
+    a   1X @@ 1Y
+    a  -2X @@ 1Y
+    b
+>>>
+                   0  a
+                 -1Y  b
+>>>= 0
+
+# 20. the above with -B
+hledgerdev -f - balance --no-total -E -B
+<<<
+1/1
+    a   1X @@ 1Y
+    a   1X @@ 1Y
+    a  -2X @@ 1Y
+    b
+>>>
+                  1Y  a
+                 -1Y  b
+>>>= 0
+
+# # when the *cost-basis* balance has exactly two commodities, both
 # # unpriced, infer an implicit conversion price for the first one in terms
 # # of the second.
 # hledgerdev -f - print
@@ -97,106 +269,3 @@ hledgerdev -f - print
 #     misc                          £1 @@ 2 shekels
 #     misc                         £-1 @@ 2 shekels
 #
-## 7. another, from ledger tests. Just one posting to price so uses @@.
-hledgerdev -f - print
-<<<
-2002/09/30 * 1a1a6305d06ce4b284dba0d267c23f69d70c20be
-    c56a21d23a6535184e7152ee138c28974f14280c  866.231000 GGGGG
-    a35e82730cf91569c302b313780e5895f75a62b9   $-17,783.72
->>>
-2002/09/30 * 1a1a6305d06ce4b284dba0d267c23f69d70c20be
-    c56a21d23a6535184e7152ee138c28974f14280c  866.231000 GGGGG @@ $17,783.72
-    a35e82730cf91569c302b313780e5895f75a62b9   $-17,783.72
-
->>>=0
-
-# 8. when the balance has more than two commodities, don't bother
-hledgerdev -f - print
-<<<
-2011/01/01
-    expenses:foreign currency       €100
-    assets                         $-135
-    expenses:other                  £200
->>>= !0
-# 9. another
-hledgerdev -f - balance -B
-<<<
-2011/01/01
-    expenses:foreign currency        €99
-    assets                         $-130
-    expenses:foreign currency         €1
-    assets                           $-5
->>>
-               $-135  assets
-                $135  expenses:foreign currency
---------------------
-                   0
->>>=0
-# 10. transaction in two commodities should balance out properly
-hledgerdev -f - balance --cost
-<<<
-2011/01/01 x
-  a  10£ @@ 16$
-  b
->>>
-                 16$  a
-                -16$  b
---------------------
-                   0
->>>=0
-# 11. When commodity price is specified implicitly, transaction should
-#     be considered balanced out even when first amount is negative
-#     (that is, price for it should be determined properly, with proper sign)
-hledgerdev -f - balance
-<<<
-2011/01/01 x
-  a  -10£
-  b  16$
->>>
-                -10£  a
-                 16$  b
---------------------
-                 16$
-                -10£
->>>=0
-# 12. When commodity price is specified implicitly, transaction should
-#     NOT be considered balanced out when BOTH amounts are negative
-hledgerdev -f - balance
-<<<
-2011/01/01 x
-  a  -10£
-  b  -16$
->>>
->>>=1
-
-# 13. Differently-priced lots of a commodity should be merged in balance report
-hledgerdev -f - balance
-<<<
-2011/1/1
-  (a)   £1 @ $2
-
-2011/1/1
-  (a)   £1 @ $3
->>>
-                  £2  a
---------------------
-                  £2
->>>=0
-
-# 14. this should balance
-hledgerdev -f - balance
-<<<
-2011/1/1
-    a  1h @ $10
-    b  1h @ $20
-    c  $-30
->>>= 0
-
-# 15. this should balance, ignoring the P
-hledgerdev -f - balance
-<<<
-P 2011/11/15 EUR CHF 1.234
-2011/11/19
-    a                             EUR 1000.00
-    b                             CHF -1254
->>>= 0