Add test suite for type UTxOSelection.

lib/core/cardano-wallet-core.cabal

@@ -416,6 +416,7 @@ test-suite unit
       Cardano.Wallet.Primitive.Types.UTxOSpec
       Cardano.Wallet.Primitive.Types.UTxOIndexSpec
       Cardano.Wallet.Primitive.Types.UTxOIndex.TypeErrorSpec
+      Cardano.Wallet.Primitive.Types.UTxOSelectionSpec
       Cardano.Wallet.Primitive.TypesSpec
       Cardano.Wallet.TokenMetadataSpec
       Cardano.Wallet.RegistrySpec

lib/core/test/unit/Cardano/Wallet/Primitive/Types/UTxOSelectionSpec.hs

@@ -0,0 +1,351 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeApplications #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Cardano.Wallet.Primitive.Types.UTxOSelectionSpec
+    ( spec
+    ) where
+
+import Prelude
+
+import Cardano.Wallet.Primitive.Types.Tx
+    ( TxIn )
+import Cardano.Wallet.Primitive.Types.Tx.Gen
+    ( coarbitraryTxIn, genTxIn, shrinkTxIn )
+import Cardano.Wallet.Primitive.Types.UTxOIndex
+    ( UTxOIndex )
+import Cardano.Wallet.Primitive.Types.UTxOIndex.Gen
+    ( genUTxOIndex, shrinkUTxOIndex )
+import Cardano.Wallet.Primitive.Types.UTxOSelection
+    ( IsUTxOSelection, UTxOSelection, UTxOSelectionNonEmpty )
+import Cardano.Wallet.Primitive.Types.UTxOSelection.Gen
+    ( genUTxOSelection
+    , genUTxOSelectionNonEmpty
+    , shrinkUTxOSelection
+    , shrinkUTxOSelectionNonEmpty
+    )
+import Test.Hspec
+    ( Spec, describe, it )
+import Test.Hspec.Extra
+    ( parallel )
+import Test.QuickCheck
+    ( Arbitrary (..)
+    , CoArbitrary (..)
+    , Property
+    , Testable
+    , checkCoverage
+    , conjoin
+    , cover
+    , forAll
+    , property
+    , (===)
+    )
+
+import qualified Cardano.Wallet.Primitive.Types.TokenBundle as TokenBundle
+import qualified Cardano.Wallet.Primitive.Types.UTxOIndex as UTxOIndex
+import qualified Cardano.Wallet.Primitive.Types.UTxOSelection as UTxOSelection
+
+spec :: Spec
+spec =
+    describe "Cardano.Wallet.Primitive.Types.UTxOSelectionSpec" $ do
+
+    parallel $ describe "Generators and shrinkers" $ do
+
+        it "prop_genUTxOSelection" $
+            property prop_genUTxOSelection
+        it "prop_genUTxOSelectionNonEmpty" $
+            property prop_genUTxOSelectionNonEmpty
+        it "prop_shrinkUTxOSelection" $
+            property prop_shrinkUTxOSelection
+        it "prop_shrinkUTxOSelectionNonEmpty" $
+            property prop_shrinkUTxOSelectionNonEmpty
+
+    parallel $ describe "Construction and deconstruction" $ do
+
+        it "prop_fromIndex_isValid" $
+            property prop_fromIndex_isValid
+        it "prop_fromIndexFiltered_isValid" $
+            property prop_fromIndexFiltered_isValid
+        it "prop_fromIndexPair_isValid" $
+            property prop_fromIndexPair_isValid
+        it "prop_fromIndex_toIndexPair" $
+            property prop_fromIndex_toIndexPair
+        it "prop_fromIndexFiltered_toIndexPair" $
+            property prop_fromIndexFiltered_toIndexPair
+        it "prop_fromIndexPair_toIndexPair" $
+            property prop_fromIndexPair_toIndexPair
+
+    parallel $ describe "Promotion and demotion" $ do
+
+        it "prop_fromNonEmpty_toNonEmpty" $
+            property prop_fromNonEmpty_toNonEmpty
+        it "prop_toNonEmpty_fromNonEmpty" $
+            property prop_toNonEmpty_fromNonEmpty
+
+    parallel $ describe "Queries" $ do
+
+        it "prop_isNonEmpty_selectedCount" $
+            property prop_isNonEmpty_selectedCount
+        it "prop_isNonEmpty_selectedIndex" $
+            property prop_isNonEmpty_selectedIndex
+        it "prop_isNonEmpty_selectedList" $
+            property prop_isNonEmpty_selectedList
+        it "prop_leftoverBalance_selectedBalance" $
+            property prop_leftoverBalance_selectedBalance
+        it "prop_leftoverCount_selectedCount" $
+            property prop_leftoverCount_selectedCount
+
+    parallel $ describe "Modification" $ do
+
+        it "prop_select_empty" $
+            property prop_select_empty
+        it "prop_select_isValid" $
+            property prop_select_isValid
+        it "prop_select_isLeftover" $
+            property prop_select_isLeftover
+        it "prop_select_isSelected" $
+            property prop_select_isSelected
+        it "prop_select_leftoverCount" $
+            property prop_select_leftoverCount
+        it "prop_select_selectedCount" $
+            property prop_select_selectedCount
+        it "prop_selectMany_all" $
+            property prop_selectMany_all
+
+--------------------------------------------------------------------------------
+-- Generators and shrinkers
+--------------------------------------------------------------------------------
+
+prop_genUTxOSelection :: (TxIn -> Bool) -> Property
+prop_genUTxOSelection f =
+    forAll (genUTxOSelection f) $ \s ->
+    checkCoverage_UTxOSelection s $
+    isValidSelection s === True
+
+prop_genUTxOSelectionNonEmpty :: (TxIn -> Bool) -> Property
+prop_genUTxOSelectionNonEmpty f =
+    forAll (genUTxOSelectionNonEmpty f) $ \s ->
+    checkCoverage_UTxOSelection s $
+    isValidSelectionNonEmpty s === True
+
+prop_shrinkUTxOSelection :: (TxIn -> Bool) -> Property
+prop_shrinkUTxOSelection f =
+    forAll (genUTxOSelection f) $ \s ->
+    conjoin (isValidSelection <$> shrinkUTxOSelection s)
+
+prop_shrinkUTxOSelectionNonEmpty :: (TxIn -> Bool) -> Property
+prop_shrinkUTxOSelectionNonEmpty f =
+    forAll (genUTxOSelectionNonEmpty f) $ \s ->
+    conjoin (isValidSelectionNonEmpty <$> shrinkUTxOSelectionNonEmpty s)
+
+checkCoverage_UTxOSelection
+    :: Testable prop => IsUTxOSelection s => s -> (prop -> Property)
+checkCoverage_UTxOSelection s
+    = checkCoverage
+    . cover 4 (leftoverCount s == 1) "leftoverCount s == 1"
+    . cover 4 (leftoverCount s >= 2) "leftoverCount s >= 2"
+    . cover 4 (selectedCount s == 1) "selectedCount s == 1"
+    . cover 4 (selectedCount s >= 2) "selectedCount s >= 2"
+    . cover 4
+        (selectedCount s > 0 && leftoverCount s > 0)
+        "selectedCount s > 0 && leftoverCount s > 0"
+  where
+    leftoverCount = UTxOSelection.leftoverCount
+    selectedCount = UTxOSelection.selectedCount
+
+--------------------------------------------------------------------------------
+-- Construction and deconstruction
+--------------------------------------------------------------------------------
+
+prop_fromIndex_isValid :: UTxOIndex -> Property
+prop_fromIndex_isValid u =
+    isValidSelection (UTxOSelection.fromIndex u)
+    === True
+
+prop_fromIndexFiltered_isValid :: UTxOIndex -> (TxIn -> Bool) -> Property
+prop_fromIndexFiltered_isValid u f =
+    isValidSelection (UTxOSelection.fromIndexFiltered u f)
+    === True
+
+prop_fromIndexPair_isValid :: (UTxOIndex, UTxOIndex) -> Property
+prop_fromIndexPair_isValid (u1, u2) =
+    isValidSelection (UTxOSelection.fromIndexPair (u1, u2))
+    === True
+
+prop_fromIndex_toIndexPair :: UTxOIndex -> Property
+prop_fromIndex_toIndexPair u =
+    UTxOSelection.toIndexPair (UTxOSelection.fromIndex u)
+    === (UTxOIndex.empty, u)
+
+prop_fromIndexFiltered_toIndexPair :: UTxOIndex -> (TxIn -> Bool) ->Property
+prop_fromIndexFiltered_toIndexPair u f =
+    UTxOSelection.toIndexPair (UTxOSelection.fromIndexFiltered u f)
+    === (UTxOIndex.filter f u, UTxOIndex.filter (not . f) u)
+
+prop_fromIndexPair_toIndexPair :: UTxOSelection -> Property
+prop_fromIndexPair_toIndexPair s =
+    UTxOSelection.fromIndexPair (UTxOSelection.toIndexPair s)
+    === s
+
+--------------------------------------------------------------------------------
+-- Promotion and demotion
+--------------------------------------------------------------------------------
+
+prop_fromNonEmpty_toNonEmpty :: UTxOSelectionNonEmpty -> Property
+prop_fromNonEmpty_toNonEmpty s =
+    UTxOSelection.toNonEmpty (UTxOSelection.fromNonEmpty s)
+    === Just s
+
+prop_toNonEmpty_fromNonEmpty :: UTxOSelection -> Property
+prop_toNonEmpty_fromNonEmpty s =
+    (UTxOSelection.fromNonEmpty <$> UTxOSelection.toNonEmpty s)
+    === (if UTxOSelection.isNonEmpty s then Just s else Nothing)
+
+--------------------------------------------------------------------------------
+-- Queries
+--------------------------------------------------------------------------------
+
+prop_isNonEmpty_selectedCount :: UTxOSelection -> Property
+prop_isNonEmpty_selectedCount s =
+    UTxOSelection.isNonEmpty s
+    === (UTxOSelection.selectedCount s > 0)
+
+prop_isNonEmpty_selectedIndex :: UTxOSelection -> Property
+prop_isNonEmpty_selectedIndex s =
+    UTxOSelection.isNonEmpty s
+    === not (UTxOIndex.null (UTxOSelection.selectedIndex s))
+
+prop_isNonEmpty_selectedList :: UTxOSelection -> Property
+prop_isNonEmpty_selectedList s =
+    UTxOSelection.isNonEmpty s
+    === not (null (UTxOSelection.selectedList s))
+
+prop_leftoverBalance_selectedBalance :: UTxOSelection -> Property
+prop_leftoverBalance_selectedBalance s =
+    (UTxOSelection.leftoverBalance s <> UTxOSelection.selectedBalance s)
+    ===
+    TokenBundle.add
+        (UTxOIndex.balance (UTxOSelection.leftoverIndex s))
+        (UTxOIndex.balance (UTxOSelection.selectedIndex s))
+
+prop_leftoverCount_selectedCount :: UTxOSelection -> Property
+prop_leftoverCount_selectedCount s =
+    (UTxOSelection.leftoverCount s + UTxOSelection.selectedCount s)
+    ===
+    (+)
+        (UTxOIndex.size (UTxOSelection.leftoverIndex s))
+        (UTxOIndex.size (UTxOSelection.selectedIndex s))
+
+--------------------------------------------------------------------------------
+-- Modification
+--------------------------------------------------------------------------------
+
+prop_select_empty :: TxIn -> Property
+prop_select_empty i =
+    UTxOSelection.select i UTxOSelection.empty === Nothing
+
+prop_select_isValid :: TxIn -> UTxOSelection -> Property
+prop_select_isValid i s = property $
+    checkCoverage_select i s $
+    maybe True isValidSelection (UTxOSelection.select i s)
+
+prop_select_isLeftover :: TxIn -> UTxOSelection -> Property
+prop_select_isLeftover i s =
+    checkCoverage_select i s $
+    (UTxOSelection.isLeftover i <$> UTxOSelection.select i s)
+    ===
+    if UTxOSelection.isLeftover i s then Just False else Nothing
+
+prop_select_isSelected :: TxIn -> UTxOSelection -> Property
+prop_select_isSelected i s =
+    checkCoverage_select i s $
+    (UTxOSelection.isSelected i <$> UTxOSelection.select i s)
+    ===
+    if UTxOSelection.isLeftover i s then Just True else Nothing
+
+prop_select_leftoverCount :: TxIn -> UTxOSelection -> Property
+prop_select_leftoverCount i s =
+    checkCoverage_select i s $
+    (UTxOSelection.leftoverCount <$> UTxOSelection.select i s)
+    ===
+    if UTxOSelection.isLeftover i s
+    then Just (UTxOSelection.leftoverCount s - 1)
+    else Nothing
+
+prop_select_selectedCount :: TxIn -> UTxOSelection -> Property
+prop_select_selectedCount i s =
+    checkCoverage_select i s $
+    (UTxOSelection.selectedCount <$> UTxOSelection.select i s)
+    ===
+    if UTxOSelection.isLeftover i s
+    then Just (UTxOSelection.selectedCount s + 1)
+    else Nothing
+
+prop_selectMany_all :: UTxOSelection -> Property
+prop_selectMany_all s =
+    checkCoverage_UTxOSelection s $
+    UTxOSelection.leftoverCount
+        (UTxOSelection.selectMany (fst <$> UTxOSelection.leftoverList s) s)
+    === 0
+
+checkCoverage_select
+    :: Testable prop => TxIn -> UTxOSelection -> (prop -> Property)
+checkCoverage_select i s
+    = checkCoverage
+    . cover 10 (UTxOSelection.isLeftover i s)
+        "in leftover set"
+    . cover 10 (UTxOSelection.isSelected i s)
+        "in selected set"
+    . cover 10 (not (UTxOSelection.isMember i s))
+        "in neither set"
+
+--------------------------------------------------------------------------------
+-- Validity
+--------------------------------------------------------------------------------
+
+isValidSelection :: IsUTxOSelection s => s -> Bool
+isValidSelection s = UTxOIndex.disjoint
+    (UTxOSelection.selectedIndex s)
+    (UTxOSelection.leftoverIndex s)
+
+isValidSelectionNonEmpty :: UTxOSelectionNonEmpty -> Bool
+isValidSelectionNonEmpty s = True
+    && (isValidSelection s)
+    && (UTxOSelection.isNonEmpty s)
+    && (UTxOSelection.selectedCount s > 0)
+    && (UTxOSelection.selectedIndex s /= UTxOIndex.empty)
+    && (not (null (UTxOSelection.selectedList s)))
+
+--------------------------------------------------------------------------------
+-- Arbitrary instances
+--------------------------------------------------------------------------------
+
+instance Arbitrary TxIn where
+    arbitrary = genTxIn
+    shrink = shrinkTxIn
+
+instance Arbitrary UTxOIndex where
+    arbitrary = genUTxOIndex
+    shrink = shrinkUTxOIndex
+
+instance Arbitrary UTxOSelection where
+    arbitrary = genUTxOSelection =<< arbitrary @(TxIn -> Bool)
+    shrink = shrinkUTxOSelection
+
+instance Arbitrary UTxOSelectionNonEmpty where
+    arbitrary = genUTxOSelectionNonEmpty =<< arbitrary @(TxIn -> Bool)
+    shrink = shrinkUTxOSelectionNonEmpty
+
+--------------------------------------------------------------------------------
+-- CoArbitrary instances
+--------------------------------------------------------------------------------
+
+instance CoArbitrary TxIn where
+    coarbitrary = coarbitraryTxIn
+
+--------------------------------------------------------------------------------
+-- Show instances
+--------------------------------------------------------------------------------
+
+instance Show (TxIn -> Bool) where
+    show = const "(TxIn -> Bool)"