diff --git a/hydra-node/test/Hydra/Chain/Direct/TxTraceSpec.hs b/hydra-node/test/Hydra/Chain/Direct/TxTraceSpec.hs index 74f2ea2328f..8d8561f701b 100644 --- a/hydra-node/test/Hydra/Chain/Direct/TxTraceSpec.hs +++ b/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