Add property tests

cardano-wallet.cabal

@@ -111,6 +111,7 @@ test-suite unit
     , cardano-crypto
     , cardano-wallet
     , cborg
+    , cryptonite
     , containers
     , deepseq
     , exceptions

test/unit/Cardano/Wallet/CoinSelection/RandomSpec.hs

@@ -10,27 +10,47 @@ import Prelude
 
 import Cardano.Wallet.CoinSelection
     ( CoinSelection (..), CoinSelectionError (..), CoinSelectionOptions (..) )
+import Cardano.Wallet.CoinSelection.LargestFirst
+    ( largestFirst )
 import Cardano.Wallet.CoinSelection.Random
     ( random )
 import Cardano.Wallet.Primitive.Types
     ( Address (..), Coin (..), Hash (..), TxIn (..), TxOut (..), UTxO (..) )
 import Control.Monad.Trans.Except
     ( runExceptT )
+import Crypto.Random.Types
+    ( MonadRandom, getRandomBytes )
+import Data.Either
+    ( isLeft, isRight )
+import Data.Functor.Identity
+    ( Identity (..) )
 import Data.List.NonEmpty
     ( NonEmpty (..) )
 import Data.Word
     ( Word64, Word8 )
 import Test.Hspec
-    ( Expectation, Spec, describe, it, shouldBe )
+    ( Expectation, Spec, describe, it, shouldBe, shouldSatisfy, xit )
 import Test.QuickCheck
-    ( Arbitrary (..), Gen, generate, oneof, scale, vectorOf )
-
+    ( Arbitrary (..)
+    , Gen
+    , Property
+    , choose
+    , generate
+    , oneof
+    , property
+    , scale
+    , vectorOf
+    , (===)
+    , (==>)
+    )
 
 import qualified Data.ByteString as BS
 import qualified Data.List as L
 import qualified Data.List.NonEmpty as NE
 import qualified Data.Map.Strict as Map
 
+import Debug.Trace
+
 spec :: Spec
 spec = do
     describe "Coin selection : Random algorithm unit tests" $ do
@@ -123,6 +143,18 @@ spec = do
                 , expectedResult = Left $ UtxoNotEnoughFragmented 3 4
                 })
 
+    describe "Coin selection properties : Random algorithm" $ do
+        xit "forall (UTxO, NonEmpty TxOut), \
+           \ running algorithm gives not less UTxO fragmentation than LargestFirst algorithm"
+            (property propFragmentation)
+        xit "forall (UTxO, NonEmpty TxOut), \
+           \ running algorithm gives the same errors as LargestFirst algorithm"
+            (property propErrors)
+
+
+{-------------------------------------------------------------------------------
+                 Properties and unit test generic scenario
+-------------------------------------------------------------------------------}
 
 data Fixture = Fixture
     { maxNumOfInputs :: Word64
@@ -167,6 +199,53 @@ coinSelectionUnitTest (Fixture n utxoCoins txOutsCoins expected) = do
             pure (utxo, txOuts)
 
 
+propFragmentation
+    :: CoveringCase
+    -> Property
+propFragmentation (CoveringCase (utxo, txOuts)) = do
+    isRight selection1 && isRight selection2 ==>
+        let (Right s1, Right s2) = trace ("selection1" <> show selection1 <> " selection2:"<> show selection2) $
+                (selection1, selection2)
+        in prop (s1, s2)
+  where
+    prop (CoinSelection inps1 _ _, CoinSelection inps2 _ _) =
+        L.length inps1 `shouldSatisfy` (>= L.length inps2)
+    selection1 = runIdentity $ runExceptT $
+        random (defaultCoinSelectionOptions 100) utxo txOuts
+    selection2 = runIdentity $ runExceptT $
+        largestFirst (defaultCoinSelectionOptions 100) utxo txOuts
+
+propErrors
+    :: CoveringCase
+    -> Property
+propErrors (CoveringCase (utxo, txOuts)) = do
+    isLeft selection1 && isLeft selection2 ==>
+        let (Left s1, Left s2) =
+                (selection1, selection2)
+        in prop (s1, s2)
+  where
+    prop (err1, err2) =
+        err1 === err2
+    selection1 = runIdentity $ runExceptT $
+        random (defaultCoinSelectionOptions 100) utxo txOuts
+    selection2 = runIdentity $ runExceptT $
+        largestFirst (defaultCoinSelectionOptions 100) utxo txOuts
+
+
+{-------------------------------------------------------------------------------
+                                  Test Data
+-------------------------------------------------------------------------------}
+
+newtype CoveringCase = CoveringCase { getCoveringCase :: (UTxO, NonEmpty TxOut)}
+    deriving Show
+
+instance Arbitrary CoveringCase where
+    arbitrary = do
+        n <- choose (1, 10)
+        txOutsNonEmpty <- NE.fromList <$> vectorOf n arbitrary
+        utxo <- arbitrary
+        return $ CoveringCase (utxo, txOutsNonEmpty)
+
 instance Arbitrary Address where
     -- No Shrinking
     arbitrary = oneof
@@ -175,6 +254,10 @@ instance Arbitrary Address where
         , pure $ Address "ADDR03"
         ]
 
+instance Arbitrary Coin where
+    -- No Shrinking
+    arbitrary = Coin <$> choose (1, 100000)
+
 instance Arbitrary TxIn where
     -- No Shrinking
     arbitrary = TxIn
@@ -187,3 +270,21 @@ instance Arbitrary (Hash "Tx") where
         wds <- vectorOf 10 arbitrary :: Gen [Word8]
         let bs = BS.pack wds
         pure $ Hash bs
+
+instance Arbitrary TxOut where
+    -- No Shrinking
+    arbitrary = TxOut
+        <$> arbitrary
+        <*> arbitrary
+
+instance Arbitrary UTxO where
+    shrink (UTxO utxo) = UTxO <$> shrink utxo
+    arbitrary = do
+        n <- choose (1, 100)
+        utxo <- zip
+            <$> vectorOf n arbitrary
+            <*> vectorOf n arbitrary
+        return $ UTxO $ Map.fromList utxo
+
+instance MonadRandom Identity where
+    getRandomBytes x = Identity $ (runIdentity . getRandomBytes) x