Add function subtract to TokenMap.

lib/core/cardano-wallet-core.cabal

@@ -266,6 +266,7 @@ test-suite unit
     , http-media
     , http-types
     , iohk-monitoring
+    , lattices
     , lens
     , memory
     , network

lib/core/src/Cardano/Wallet/Primitive/Types/TokenMap.hs

@@ -51,6 +51,7 @@ module Cardano.Wallet.Primitive.Types.TokenMap
 
     -- * Arithmetic
     , add
+    , subtract
 
     -- * Tests
     , isEmpty
@@ -76,7 +77,7 @@ module Cardano.Wallet.Primitive.Types.TokenMap
     ) where
 
 import Prelude hiding
-    ( negate, null )
+    ( negate, null, subtract )
 
 import Algebra.PartialOrd
     ( PartialOrd (..) )
@@ -437,6 +438,14 @@ add a b = F.foldl' acc a $ toFlatList b
     acc c (asset, quantity) =
         adjustQuantity c asset (`TokenQuantity.add` quantity)
 
+-- | Subtracts one token map from another.
+--
+subtract :: TokenMap -> TokenMap -> TokenMap
+subtract a b = F.foldl' acc a $ toFlatList b
+  where
+    acc c (asset, quantity) =
+        adjustQuantity c asset (`TokenQuantity.subtract` quantity)
+
 --------------------------------------------------------------------------------
 -- Tests
 --------------------------------------------------------------------------------

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

@@ -11,6 +11,8 @@ module Cardano.Wallet.Primitive.Types.TokenMapSpec
 
 import Prelude
 
+import Algebra.PartialOrd
+    ( PartialOrd (..) )
 import Cardano.Wallet.Primitive.Types.TokenMap
     ( AssetId (..), Flat (..), Nested (..), TokenMap )
 import Cardano.Wallet.Primitive.Types.TokenMap.Gen
@@ -66,7 +68,7 @@ import Test.Hspec
 import Test.Hspec.Core.QuickCheck
     ( modifyMaxSuccess )
 import Test.QuickCheck
-    ( Arbitrary (..), Property, checkCoverage, cover, property, (===) )
+    ( Arbitrary (..), Property, checkCoverage, cover, property, (===), (==>) )
 import Test.QuickCheck.Classes
     ( eqLaws, monoidLaws, semigroupLaws, semigroupMonoidLaws )
 import Test.Utils.Laws
@@ -117,6 +119,8 @@ spec =
             property prop_fromNestedList_invariant
         it "prop_add_invariant" $
             property prop_add_invariant
+        it "prop_subtract_invariant" $
+            property prop_subtract_invariant
         it "prop_setQuantity_invariant" $
             property prop_setQuantity_invariant
         it "prop_adjustQuantity_invariant" $
@@ -143,6 +147,10 @@ spec =
             property prop_add_commutative
         it "prop_add_associative" $
             property prop_add_associative
+        it "prop_add_subtract_associative" $
+            property prop_add_subtract_associative
+        it "prop_subtract_null" $
+            property prop_subtract_null
 
     parallel $ describe "Quantities" $ do
 
@@ -214,6 +222,12 @@ prop_fromNestedList_invariant entries =
 prop_add_invariant :: TokenMap -> TokenMap -> Property
 prop_add_invariant b1 b2 = property $ invariantHolds $ TokenMap.add b1 b2
 
+prop_subtract_invariant :: TokenMap -> TokenMap -> Property
+prop_subtract_invariant m1 m2 =
+    -- We must take care to not produce negative quantities:
+    m2 `leq` m1 ==>
+        property $ invariantHolds $ TokenMap.subtract m1 m2
+
 prop_setQuantity_invariant
     :: TokenMap -> AssetId -> TokenQuantity -> Property
 prop_setQuantity_invariant b asset quantity = property $
@@ -301,6 +315,18 @@ prop_add_associative b1 b2 b3 = (===)
     ((b1 `TokenMap.add` b2) `TokenMap.add` b3)
     (b1 `TokenMap.add` (b2 `TokenMap.add` b3))
 
+prop_add_subtract_associative
+    :: TokenMap -> TokenMap -> TokenMap -> Property
+prop_add_subtract_associative m1 m2 m3 =
+    -- We must take care to not produce negative quantities:
+    m3 `leq` m2 ==> (===)
+        ((m1 `TokenMap.add` m2) `TokenMap.subtract` m3)
+        (m1 `TokenMap.add` (m2 `TokenMap.subtract` m3))
+
+prop_subtract_null :: TokenMap -> Property
+prop_subtract_null m =
+    m `TokenMap.subtract` m === TokenMap.empty
+
 --------------------------------------------------------------------------------
 -- Quantity properties
 --------------------------------------------------------------------------------