Adding tons of unit tests and revert to double conversion

cardano-wallet.cabal

@@ -153,6 +153,7 @@ test-suite unit
       Cardano.Wallet.BinarySpec
       Cardano.Wallet.Binary.PackfileSpec
       Cardano.Wallet.CoinSelectionSpec
+      Cardano.Wallet.CoinSelection.FeeSpec
       Cardano.Wallet.CoinSelection.LargestFirstSpec
       Cardano.Wallet.CoinSelection.RandomSpec
       Cardano.Wallet.DBSpec

src/Cardano/Wallet/CoinSelection/Fee.hs

@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-type-defaults #-}
 {-# LANGUAGE RankNTypes #-}
 
 -- |
@@ -19,6 +20,8 @@ import Cardano.Wallet.CoinSelection.Random
     ( distance, pickRandom )
 import Cardano.Wallet.Primitive.Types
     ( Coin (..), TxIn, TxOut (..), UTxO (..), invariant, isValidCoin )
+import Control.Monad.IO.Class
+    ( MonadIO, liftIO )
 import Control.Monad.Trans.Class
     ( lift )
 import Control.Monad.Trans.Except
@@ -32,6 +35,8 @@ import Data.Bifunctor
 import Data.Word
     ( Word64 )
 
+import Debug.Trace
+
 import qualified Data.List as L
 
 -- | Given the coin selection result from a policy run, adjust the outputs
@@ -61,14 +66,16 @@ import qualified Data.List as L
 -- percentage of the fee (depending on how many change outputs the
 -- algorithm happened to choose).
 adjustForFees
-    :: forall m. MonadRandom m
+    :: forall m. (MonadRandom m, MonadIO m)
     => FeeOptions
     -> UTxO
     -> CoinSelection
     -> ExceptT FeeError m CoinSelection
 adjustForFees opt utxo coinSel = do
+    liftIO $ print coinSel
     coinSel'@(CoinSelection inps' outs' chgs') <-
         senderPaysFee opt utxo coinSel
+    liftIO $ print coinSel'
     let estimatedFee = feeUpperBound opt coinSel
     let actualFee = computeFee coinSel'
 
@@ -96,7 +103,7 @@ adjustForFees opt utxo coinSel = do
         pure (CoinSelection neInps neOuts chgs')
 
 senderPaysFee
-    :: forall m. MonadRandom m
+    :: forall m. (MonadRandom m, MonadIO m)
     => FeeOptions
     -> UTxO
     -> CoinSelection
@@ -115,8 +122,13 @@ senderPaysFee opt utxo  = go
         reduceChangeOutputs totalFee chgs =
             case (filter (/= Coin 0) . removeDust) chgs of
                 [] ->
-                    (removeDust chgs, totalFee)
-                xs ->
+                    trace ("reduceChangeOutputs - []") $ (removeDust chgs, totalFee)
+                xs -> trace ("reduceChangeOutputs - divvy - totalFee : "
+                             <> (show totalFee)
+                             <> " xs : "
+                             <> (show xs)
+                             <> (" res: ")
+                             <> (show $ divvyFee totalFee xs)) $
                     bimap removeDust (Coin . sum . map getCoin)
                     $ L.unzip
                     $ map reduceSingleChange
@@ -133,18 +145,21 @@ senderPaysFee opt utxo  = go
 
 
         go
-            :: forall m. MonadRandom m
+            :: forall m. (MonadRandom m, MonadIO m)
             => CoinSelection
             -> ExceptT FeeError m CoinSelection
         go coinSel@(CoinSelection inps outs chgs) = do
             -- 1/
             -- We compute fees using all inputs, outputs and changes since
             -- all of them have an influence on the fee calculation.
             let upperBound = feeUpperBound opt coinSel
-
+            liftIO $ print "upperBound:"
+            liftIO $ print upperBound
             -- 2/ Substract fee from all change outputs, proportionally to their value.
-            let (chgs', remainingFee) =
+            let alls@(chgs', remainingFee) =
                     reduceChangeOutputs upperBound chgs
+            liftIO $ print "alls:"
+            liftIO $ print alls
 
             -- 3.1/
             -- Should the change cover the fee, we're (almost) good. By removing
@@ -196,28 +211,26 @@ divvyFee _ outs | (Coin 0) `elem` outs =
 divvyFee fee outs =
     map (\a -> (feeForOut a, a)) outs
   where
-    totalOut :: Word64
-    totalOut = (sum . map getCoin) outs
+    totalOuts :: Word64
+    totalOuts = (sum . map getCoin) outs
 
-    -- The ratio will be between 0 and 1 so cannot overflow
     feeForOut :: Coin -> Coin
-    feeForOut (Coin a) =
-        let res = valueAdjust
-                  (a `div` totalOut, a `quot` totalOut)
-                  fee
+    feeForOut out =
+        let res = valueAdjust (valueRatio out (Coin totalOuts)) fee
         in if isValidCoin res then
             res
         else
             error "feeForOut : fee exceeded maximum valid value for Coin"
 
-    valueAdjust
-        :: (Word64, Word64)
-        -> Coin
-        -> Coin
-    valueAdjust (natural, remainder) (Coin c) =
-        let remainder' = c `quot` remainder
-        in Coin $ natural * c + c `div` remainder + (if remainder' == 0 then 0 else 1)
+    valueRatio :: Coin -> Coin -> Double
+    valueRatio c1 c2 = (coinToDouble c1) / (coinToDouble c2)
+
+    valueAdjust :: Double -> Coin -> Coin
+    valueAdjust d c =
+        Coin $ ceiling (d * (coinToDouble c))
 
+    coinToDouble :: Coin -> Double
+    coinToDouble = fromIntegral . getCoin
 
 coverRemainingFee
     :: forall m. MonadRandom m
@@ -310,7 +323,7 @@ computeFee (CoinSelection inps outs chgs) =
     -- Some remaining inputs together. At this point, we've removed
     -- all outputs and changes, so what's left are simply the actual fees.
     -- It's unrealistic to imagine them being bigger than the max coin value.
-    collapse plus [] =
+    collapse plus [] = trace (("collapse : plus : "<>(show plus))) $
         invariant
         "fees are bigger than max coin value"
         (Coin . sum $ map getCoin plus)
@@ -320,13 +333,13 @@ computeFee (CoinSelection inps outs chgs) =
     -- overflow. Therefore, we remove outputs to inputs until there's no outputs
     -- left to remove.
     collapse (p:ps) (m:ms)
-        | p > m =
+        | p > m = trace (("collapse : p>m : "<>(show p)<>(" > ")<>(show m)<>(" ps:")<>(show ps)<>(" ms")<>(show ms))) $
               let p' = Coin $ distance (getCoin p) (getCoin m)
               in collapse (p':ps) ms
-        | p < m =
+        | p < m = trace (("collapse : p<m : "<>(show p)<>(" < ")<>(show m)<>(" ps:")<>(show ps)<>(" ms")<>(show ms))) $
               let m' = Coin $ distance (getCoin p) (getCoin m)
               in collapse ps (m':ms)
-        | otherwise = collapse ps ms
+        | otherwise = trace (("collapse : p==m : "<>(show p)<>(" ps:")<>(show ps)<>(" ms")<>(show ms))) $ collapse ps ms
 
     -- This branch can only happens if we've depleted all our inputs and there
     -- are still some outputs left to remove from them. If means the total value