Custom equality and mappending

IntersectMBO · Mar 28, 2023 · 65794ec · 65794ec
1 parent 7fa2872
commit 65794ec
Show file tree

Hide file tree

Showing 3 changed files with 41 additions and 30 deletions.
diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudget.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudget.hs
@@ -234,7 +234,7 @@ enormousBudget = ExRestrictingBudget $ ExBudget maxBound maxBound
 data ExBudgetStream
     = ExBudgetLast ExBudget
     | ExBudgetCons ExBudget ~ExBudgetStream
-    deriving stock (Show, Eq)
+    deriving stock (Show)
 
 -- | Convert a 'CostStream' to an 'ExBudgetStream' by applying a function to each element.
 costToExBudgetStream :: (CostingInteger -> ExBudget) -> CostStream -> ExBudgetStream

diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExMemory.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExMemory.hs
@@ -36,7 +36,6 @@ import Data.Aeson
 import Data.ByteString qualified as BS
 import Data.Proxy
 import Data.SatInt
-import Data.Semigroup
 import Data.Text qualified as T
 import GHC.Exts (Int (I#))
 import GHC.Integer
@@ -209,22 +208,6 @@ traversing the list), while we of course want it to be O(1).
 data CostRose = CostRose {-# UNPACK #-} !CostingInteger ![CostRose]
     deriving stock (Show)
 
-instance Semigroup CostRose where
-    -- Only used in the 'Data' instance below, so we make it strict.
-    CostRose cost1 forest1 <> CostRose cost2 forest2 =
-        CostRose (cost1 + cost2) (forest1 ++ forest2)
-    {-# INLINE (<>) #-}
-
-    sconcat (rose :| forest) = CostRose 0 $ rose : forest
-    {-# INLINE sconcat #-}
-
-instance Monoid CostRose where
-    mempty = CostRose 0 []
-    {-# INLINE mempty #-}
-
-    mconcat = CostRose 0
-    {-# INLINE mconcat #-}
-
 class ExMemoryUsage a where
     -- Inlining the implementations of this method gave us a 1-2% speedup.
     memoryUsage :: a -> CostRose -- ^ How much memory does 'a' use?
@@ -323,7 +306,11 @@ instance ExMemoryUsage Data where
         nodeMem = CostRose 4 []
         {-# INLINE nodeMem #-}
 
-        sizeData d = nodeMem <> case d of
+        combine (CostRose cost1 forest1) (CostRose cost2 forest2) =
+            CostRose (cost1 + cost2) (forest1 ++ forest2)
+        {-# INLINE combine #-}
+
+        sizeData d = combine nodeMem $ case d of
             -- TODO: include the size of the tag, but not just yet.  See SCP-3677.
             Constr _ l -> CostRose 0 $ l <&> sizeData
             Map l      -> CostRose 0 $ l <&> \(d1, d2) -> CostRose 0 $ [d1, d2] <&> sizeData
@@ -340,7 +327,7 @@ instance ExMemoryUsage Data where
 data CostStream
     = CostLast {-# UNPACK #-} !CostingInteger
     | CostCons {-# UNPACK #-} !CostingInteger CostStream
-    deriving stock (Show, Eq)
+    deriving stock (Show)
 
 -- TODO: (# CostingInteger, (# (# #) | CostStream #) #)?
 -- | Uncons an element from a 'CostStream' and return the rest of the stream, if not empty.

diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Costing.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Costing.hs
@@ -20,6 +20,22 @@ import Test.Tasty.QuickCheck
 
 deriving newtype instance Foldable NonEmptyList  -- QuickCheck...
 
+sumExBudgetStream :: ExBudgetStream -> ExBudget
+sumExBudgetStream (ExBudgetLast budget)         = budget
+sumExBudgetStream (ExBudgetCons budget budgets) = budget <> sumExBudgetStream budgets
+
+eqCostStream :: CostStream -> CostStream -> Bool
+eqCostStream (CostLast cost1) (CostLast cost2) = cost1 == cost2
+eqCostStream (CostCons cost1 costs1) (CostCons cost2 costs2) =
+    cost1 == cost2 && eqCostStream costs1 costs2
+eqCostStream _ _ = False
+
+eqExBudgetStream :: ExBudgetStream -> ExBudgetStream -> Bool
+eqExBudgetStream (ExBudgetLast budget1) (ExBudgetLast budget2) = budget1 == budget2
+eqExBudgetStream (ExBudgetCons budget1 budgets1) (ExBudgetCons budget2 budgets2) =
+    budget1 == budget2 && eqExBudgetStream budgets1 budgets2
+eqExBudgetStream _ _ = False
+
 fromCostList :: NonEmptyList CostingInteger -> CostStream
 fromCostList (NonEmpty [])               = error "cannot be empty"
 fromCostList (NonEmpty (cost0 : costs0)) = go cost0 costs0 where
@@ -31,10 +47,6 @@ toCostList = NonEmpty . go where
     go (CostLast cost)       = [cost]
     go (CostCons cost costs) = cost : go costs
 
-sumExBudgetStream :: ExBudgetStream -> ExBudget
-sumExBudgetStream (ExBudgetLast budget)         = budget
-sumExBudgetStream (ExBudgetCons budget budgets) = budget <> sumExBudgetStream budgets
-
 toExBudgetList :: ExBudgetStream -> NonEmptyList ExBudget
 toExBudgetList = NonEmpty . go where
     go (ExBudgetLast budget)         = [budget]
@@ -74,6 +86,14 @@ instance CoArbitrary SatInt where
 instance Function SatInt where
     function = functionMap fromIntegral $ fromIntegral @Int64
 
+checkEqualsVia :: Show a => (a -> a -> Bool) -> a -> a -> Property
+checkEqualsVia eq x y =
+    counterexample (show x ++ interpret res ++ show y) res
+  where
+    res = eq x y
+    interpret True  = " === "
+    interpret False = " =/= "
+
 bottom :: a
 bottom = error "this value wasn't supposed to be forced"
 
@@ -95,7 +115,8 @@ test_CostStreamDistribution =
 test_toCostListRoundtrip :: TestTree
 test_toCostListRoundtrip =
     testProperty "fromCostList cancels toCostList" . withMaxSuccess 5000 $ \costs ->
-        fromCostList (toCostList costs) ===
+        checkEqualsVia eqCostStream
+            (fromCostList $ toCostList costs)
             costs
 
 test_fromCostListRoundtrip :: TestTree
@@ -107,7 +128,8 @@ test_fromCostListRoundtrip =
 test_unconsCostRoundtrip :: TestTree
 test_unconsCostRoundtrip =
     testProperty "reconsCost cancels unconsCost" . withMaxSuccess 5000 $ \costs ->
-        uncurry reconsCost (unconsCost costs) ===
+        checkEqualsVia eqCostStream
+            (uncurry reconsCost $ unconsCost costs)
             costs
 
 test_sumCostStreamIsSum :: TestTree
@@ -119,8 +141,9 @@ test_sumCostStreamIsSum =
 test_mapCostStreamIsMap :: TestTree
 test_mapCostStreamIsMap =
     testProperty "mapCostStream is map" . withMaxSuccess 500 $ \(Fun _ f) costs ->
-        mapCostStream f (fromCostList costs) ===
-            fromCostList (fmap f costs)
+        checkEqualsVia eqCostStream
+            (mapCostStream f $ fromCostList costs)
+            (fromCostList $ fmap f costs)
 
 test_addCostStreamIsAdd :: TestTree
 test_addCostStreamIsAdd =
@@ -365,8 +388,9 @@ test_flattenCostRoseSound =
             -- This assumes that 'flattenCostRose' is left-biased, which isn't really
             -- necessarily, but it doesn't seem like we're giving up on the assumption any time soon
             -- anyway, so why not keep it simple instead of sorting the results.
-            flattenCostRose rose ===
-                fromCostList (fromCostRose rose)
+            checkEqualsVia eqCostStream
+                (flattenCostRose rose)
+                (fromCostList $ fromCostRose rose)
 
 test_costing :: TestTree
 test_costing = testGroup "costing"