Waypoint: both versions of addValueToOutputs.

cardano-foundation · Apr 15, 2021 · 53718e3 · 53718e3
1 parent 0915e3d
commit 53718e3
Show file tree

Hide file tree

Showing 2 changed files with 109 additions and 10 deletions.
diff --git a/lib/core/src/Cardano/Wallet/Primitive/Migration.hs b/lib/core/src/Cardano/Wallet/Primitive/Migration.hs
@@ -24,7 +24,7 @@ module Cardano.Wallet.Primitive.Migration
 
       -- * Utility functions
     , addValueToOutputs
-
+    , splitOutputIfLimitsExceeded
     ) where
 
 import Prelude
@@ -346,29 +346,69 @@ uncategorizeUTxOEntries utxo = mconcat
 --------------------------------------------------------------------------------
 -- Adding value to outputs
 --------------------------------------------------------------------------------
-
+{-
 addValueToOutputs
     :: TxSize s
     => TxConstraints s
     -> TokenBundle
     -- ^ Value to add
+    -> [TokenBundle]
+    -- ^ Existing set of outputs
     -> NonEmpty TokenBundle
+    -- ^ Set of outputs with the value added
+addValueToOutputs constraints valueUnchecked outputs
+    | output : remainder <- outputs, value :| [] <- checkedValues =
+        -- Just one value to add: try to merge this to the output at the start:
+        case safeMergeOutputValue value output of
+            Nothing -> value :| outputs
+            Just mergedValue -> mergedValue :| remainder
+    | output : remainder <- outputs =
+        -- Multiple values to add: put these at the end:
+        (output :| remainder) <> checkedValues
+    | [output] <- outputs =
+        output `NE.cons` checkedValues
+    | otherwise =
+        checkedValues
+
+  where
+    checkedValues :: NonEmpty TokenBundle
+    checkedValues = splitOutputIfLimitsExceeded constraints valueUnchecked
+
+    safeMergeOutputValue :: TokenBundle -> TokenBundle -> Maybe TokenBundle
+    safeMergeOutputValue a b
+        | txOutputIsValid constraints valueWithMaxAda =
+            Just value
+        | otherwise =
+            Nothing
+      where
+        value = a <> b
+        valueWithMaxAda = TokenBundle.setCoin value maxBound
+-}
+
+addValueToOutputs
+    :: TxSize s
+    => TxConstraints s
+    -> [TokenBundle]
     -- ^ Existing set of outputs
+    -> TokenBundle
+    -- ^ Value to add
     -> NonEmpty TokenBundle
     -- ^ Set of outputs with the value added
-addValueToOutputs constraints valueUnchecked outputs =
-    F.foldl' (flip addToOutputs) outputs $
-        splitOutputIfLimitsExceeded constraints valueUnchecked
+addValueToOutputs constraints outputs =
+    NE.fromList
+        . F.foldl' (flip addToOutputs) outputs
+        . NE.toList
+        . splitOutputIfLimitsExceeded constraints
   where
-    addToOutputs :: TokenBundle -> NonEmpty TokenBundle -> NonEmpty TokenBundle
-    addToOutputs value = NE.fromList . add [] . NE.toList
+    addToOutputs :: TokenBundle -> [TokenBundle] -> [TokenBundle]
+    addToOutputs value = add []
       where
         add considered (candidate : unconsidered) =
             case safeMergeOutputValue value candidate of
                 Just merged ->
                     merged : (considered <> unconsidered)
                 Nothing ->
-                    add unconsidered (candidate : considered)
+                    add (candidate : considered) unconsidered
         add considered [] =
             value : considered
 

diff --git a/lib/core/test/unit/Cardano/Wallet/Primitive/MigrationSpec.hs b/lib/core/test/unit/Cardano/Wallet/Primitive/MigrationSpec.hs
@@ -20,6 +20,7 @@ import Cardano.Wallet.Primitive.Migration
     , categorizeUTxOEntry
     , createPlan
     --, uncategorizeUTxOEntries
+    , addValueToOutputs
     )
 import Cardano.Wallet.Primitive.Migration.Selection
     ( Selection (..) )
@@ -37,6 +38,11 @@ import Cardano.Wallet.Primitive.Types.Coin
     ( Coin (..) )
 import Cardano.Wallet.Primitive.Types.TokenBundle
     ( TokenBundle (..) )
+import Cardano.Wallet.Primitive.Types.Tx
+    ( TxConstraints
+    , txOutputHasValidSize
+    , txOutputHasValidTokenQuantities
+    )
 import Control.Monad
     ( replicateM )
 import Data.Either
@@ -45,6 +51,8 @@ import Data.Either
 --    ( view )
 import Data.Generics.Labels
     ()
+import Data.List.NonEmpty
+    ( NonEmpty (..) )
 --import Data.Set
 --    ( Set )
 import Test.Hspec
@@ -69,14 +77,15 @@ import Test.QuickCheck
     )
 
 import qualified Cardano.Wallet.Primitive.Migration.Selection as Selection
+import qualified Cardano.Wallet.Primitive.Types.TokenBundle as TokenBundle
 import qualified Data.Foldable as F
---import qualified Data.List.NonEmpty as NE
+import qualified Data.List.NonEmpty as NE
 --import qualified Data.Set as Set
 
 spec :: Spec
 spec = describe "Cardano.Wallet.Primitive.MigrationSpec" $
 
-    modifyMaxSuccess (const 1000) $ do
+    modifyMaxSuccess (const 100) $ do
 
     parallel $ describe "Creating migration plans" $ do
 
@@ -88,6 +97,11 @@ spec = describe "Cardano.Wallet.Primitive.MigrationSpec" $
         it "prop_categorizeUTxOEntry" $
             property prop_categorizeUTxOEntry
 
+    parallel $ describe "Adding value to outputs" $ do
+
+        it "prop_addValueToOutputs" $
+            property prop_addValueToOutputs
+
 --------------------------------------------------------------------------------
 -- Creating migration plans
 --------------------------------------------------------------------------------
@@ -228,6 +242,51 @@ prop_categorizeUTxOEntry mockArgs =
         Freerider -> isLeft
         Ignorable -> isLeft
 
+--------------------------------------------------------------------------------
+-- Adding value to outputs
+--------------------------------------------------------------------------------
+
+data MockAddValueToOutputsArguments = MockAddValueToOutputsArguments
+    { mockConstraints :: MockTxConstraints
+    , mockOutputs :: NonEmpty TokenBundle
+    }
+
+instance Arbitrary MockAddValueToOutputsArguments where
+    arbitrary = genMockAddValueToOutputsArguments
+
+genMockAddValueToOutputsArguments :: Gen MockAddValueToOutputsArguments
+genMockAddValueToOutputsArguments = do
+    mockConstraints <- genMockTxConstraints
+    mockOutputCount <- choose (1, 128)
+    mockOutputs <- (:|)
+        <$> genTokenBundle mockConstraints
+        <*> replicateM (mockOutputCount - 1) (genTokenBundle mockConstraints)
+    pure MockAddValueToOutputsArguments {..}
+
+prop_addValueToOutputs :: Blind MockAddValueToOutputsArguments -> Property
+prop_addValueToOutputs mockArgs =
+    conjoin
+        [ F.fold result == F.fold mockOutputs
+        , all (txOutputHasValidSizeIfAdaMaximized constraints) result
+        , all (txOutputHasValidTokenQuantities constraints) result
+        ]
+  where
+    Blind MockAddValueToOutputsArguments
+        { mockConstraints
+        , mockOutputs
+        } = mockArgs
+    constraints = unMockTxConstraints mockConstraints
+    result :: NonEmpty TokenBundle
+    result = F.foldl'
+        (addValueToOutputs constraints . NE.toList)
+        [NE.head mockOutputs]
+        (NE.tail mockOutputs)
+
+txOutputHasValidSizeIfAdaMaximized
+    :: Ord s => TxConstraints s -> TokenBundle -> Bool
+txOutputHasValidSizeIfAdaMaximized constraints b =
+    txOutputHasValidSize constraints $ TokenBundle.setCoin b maxBound
+
 --------------------------------------------------------------------------------
 -- Miscellaneous types and functions
 --------------------------------------------------------------------------------