Fix TxTrace spec in presence of decommit versions

hydra-node/test/Hydra/Chain/Direct/TxTraceSpec.hs

@@ -89,10 +89,8 @@ prop_traces =
       True
         & cover 1 (null steps) "empty"
         & cover 10 (hasFanout steps) "reach fanout"
-        & cover 1 (fanoutWithEmptyUTxO steps) "fanout with empty UTxO"
+        & cover 0.1 (fanoutWithEmptyUTxO steps) "fanout with empty UTxO"
         & cover 5 (fanoutWithSomeUTxO steps) "fanout with some UTxO"
-        & cover 0.5 (fanoutWithDecrement steps) "fanout with something to decrement"
-        & cover 0.5 (fanoutWithSomeUTxOAndDecrement steps) "fanout with some UTxO and something to decrement"
         & cover 1 (countContests steps >= 2) "has multiple contests"
         & cover 5 (closeNonInitial steps) "close with non initial snapshots"
         & cover 5 (closeWithSomeUTxO steps) "close with some UTxO"
@@ -133,23 +131,6 @@ prop_traces =
             && hasSnapshotUTxO snapshot
         _ -> False
 
-  fanoutWithDecrement =
-    any $
-      \(_ := ActionWithPolarity{polarAction, polarity}) -> case polarAction of
-        Fanout{snapshot} ->
-          polarity == PosPolarity
-            && hasDecommitValue snapshot
-        _ -> False
-
-  fanoutWithSomeUTxOAndDecrement =
-    any $
-      \(_ := ActionWithPolarity{polarAction, polarity}) -> case polarAction of
-        Fanout{snapshot} ->
-          polarity == PosPolarity
-            && hasSnapshotUTxO snapshot
-            && hasDecommitValue snapshot
-        _ -> False
-
   countContests =
     length
       . filter
@@ -216,7 +197,7 @@ prop_runActions actions =
 -- * ============================== MODEL WORLD ==========================
 
 data SingleUTxO = A | B | C | D | E
-  deriving (Show, Eq, Ord, Enum, Generic)
+  deriving (Show, Eq, Ord, Enum, Bounded, Generic)
 
 instance Arbitrary SingleUTxO where
   arbitrary = genericArbitrary
@@ -278,6 +259,11 @@ data TxResult = TxResult
 initialAmount :: Natural
 initialAmount = 10
 
+startingUTxO :: ModelUTxO
+startingUTxO =
+  let utxo = [minBound .. maxBound]
+   in map (,initialAmount) utxo & Map.fromList
+
 balanceUTxOInHead :: Ord k => Map k Natural -> Map k Natural -> Map k Natural
 balanceUTxOInHead currentUtxoInHead someUTxOToDecrement =
   currentUtxoInHead `Map.difference` someUTxOToDecrement
@@ -297,7 +283,7 @@ instance StateModel Model where
       { headState = Open
       , latestSnapshot = 0
       , alreadyContested = []
-      , utxoInHead = fromList [(A, initialAmount)]
+      , utxoInHead = startingUTxO
       , decommitUTxOInHead = Map.empty
       }
 
@@ -324,15 +310,21 @@ instance StateModel Model where
                not (null utxoInHead)
                ]
       Closed{} ->
-        oneof $
-          [ do
-              snapshot <- genSnapshot
-              pure $ Some $ Fanout{snapshot}
+        frequency $
+          [
+            ( 5
+            , do
+                snapshot <- genSnapshot
+                pure $ Some $ Fanout{snapshot}
+            )
           ]
-            <> [ do
-                  actor <- elements allActors
-                  snapshot <- genSnapshot
-                  pure $ Some Contest{actor, snapshot}
+            <> [
+                 ( 5
+                 , do
+                    actor <- elements allActors
+                    snapshot <- genSnapshot
+                    pure $ Some Contest{actor, snapshot}
+                 )
                ]
       Final -> pure $ Some Stop
    where
@@ -347,34 +339,34 @@ instance StateModel Model where
               , decommitUTxO = filteredSomeUTxOToDecrement
               }
       oneof
-        [ -- valid
+        [ arbitrary
+        , -- valid
           pure validSnapshot
-        , -- unbalanced
-          pure validSnapshot{snapshotUTxO = utxoInHead}
-        , do
+          , -- unbalanced
+            pure validSnapshot{snapshotUTxO = utxoInHead}
+          , do
             -- old
             let snapshotNumber' = if latestSnapshot == 0 then 0 else latestSnapshot - 1
             pure validSnapshot{snapshotNumber = snapshotNumber'}
-        , -- new
-          pure validSnapshot{snapshotNumber = latestSnapshot + 1}
-        , do
-            -- shuffled
-            someUTxOToDecrement' <- shuffleValues filteredSomeUTxOToDecrement
-            pure validSnapshot{decommitUTxO = someUTxOToDecrement'}
-        , do
-            -- more in head
-            utxoInHead' <- increaseValues utxoInHead
-            pure validSnapshot{snapshotUTxO = utxoInHead'}
-        , do
-            -- more in decommit
-            someUTxOToDecrement' <- increaseValues =<< genSubModelOf utxoInHead
-            let balancedUTxOInHead' = balanceUTxOInHead utxoInHead someUTxOToDecrement'
-            pure
-              validSnapshot
-                { snapshotUTxO = balancedUTxOInHead'
-                , decommitUTxO = someUTxOToDecrement'
-                }
-        , arbitrary
+          , -- new
+            pure validSnapshot{snapshotNumber = latestSnapshot + 1}
+          , do
+              -- shuffled
+              someUTxOToDecrement' <- shuffleValues filteredSomeUTxOToDecrement
+              pure validSnapshot{decommitUTxO = someUTxOToDecrement'}
+          , do
+              -- more in head
+              utxoInHead' <- increaseValues utxoInHead
+              pure validSnapshot{snapshotUTxO = utxoInHead'}
+          , do
+              -- more in decommit
+              someUTxOToDecrement' <- increaseValues =<< genSubModelOf utxoInHead
+              let balancedUTxOInHead' = balanceUTxOInHead utxoInHead someUTxOToDecrement'
+              pure
+                validSnapshot
+                  { snapshotUTxO = balancedUTxOInHead'
+                  , decommitUTxO = someUTxOToDecrement'
+                  }
         ]
 
     genSubModelOf :: ModelUTxO -> Gen ModelUTxO
@@ -431,7 +423,7 @@ instance StateModel Model where
     Contest{actor, snapshot} ->
       headState == Closed
         && actor `notElem` alreadyContested
-        && snapshotNumber snapshot > latestSnapshot
+        -- && snapshotNumber snapshot > latestSnapshot
         -- XXX: you are decrementing from existing utxo in the head
         && all (`elem` Map.keys utxoInHead) (Map.keys (decommitUTxO snapshot) <> Map.keys (snapshotUTxO snapshot))
         -- XXX: your tx is balanced with the utxo in the head