Fix isReducible isIrreducible and isReducibleToClose by calling fixIn…

…terval
input-output-hk · Sep 27, 2023 · 1d54eb7 · 1d54eb7
1 parent 15cbc2b
commit 1d54eb7
Show file tree

Hide file tree

Showing 2 changed files with 24 additions and 18 deletions.
diff --git a/marlowe-test/test/Spec/Marlowe/Semantics/Next.hs b/marlowe-test/test/Spec/Marlowe/Semantics/Next.hs
@@ -40,7 +40,7 @@ import Spec.Marlowe.Semantics.Next.Contract.Generator (
 import Spec.Marlowe.Semantics.Next.Contract.When.Choice (onlyIndexedChoices)
 import Spec.Marlowe.Semantics.Next.Contract.When.Deposit (evaluateDeposits, hasNoIdenticalEvaluatedDeposits)
 import Spec.Marlowe.Semantics.Next.Contract.When.Notify (firstNotifyTrueIndex)
-import Test.QuickCheck (Arbitrary (..), forAllShrink, withMaxSuccess)
+import Test.QuickCheck (Arbitrary (..), forAllShrink, withMaxSuccess, (===))
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.QuickCheck (testProperty)
 
@@ -54,20 +54,20 @@ tests =
             "Can Reduce when contract is reducible"
             $ forAllSuchThat (getAll . on (<>) (fmap All . uncurry3) hasValidEnvironment isReducible)
             $ \(environment', state, contract) ->
-              Right (coerce True) == (canReduce <$> next environment' state contract)
+              Right (coerce True) === (canReduce <$> next environment' state contract)
         , testProperty
             "Can't Reduce when the contract provided is irreducible"
             $ forAllSuchThat (getAll . on (<>) (fmap All . uncurry3) hasValidEnvironment isIrreducible)
             $ \(environment', state, contract) ->
-              Right (coerce False) == (canReduce <$> next environment' state contract)
+              Right (coerce False) === (canReduce <$> next environment' state contract)
         ]
     , testGroup
         "Applicability"
         [ testProperty
             "\"Close\" is not applicable"
             $ forAllSuchThat (getAll . on (<>) (fmap All . uncurry3) hasValidEnvironment isReducibleToClose)
             $ \(environment', state, contract) ->
-              Right emptyApplicables == (applicables <$> next environment' state contract)
+              Right emptyApplicables === (applicables <$> next environment' state contract)
         , testGroup
             "Notify"
             [ testProperty
@@ -80,7 +80,7 @@ tests =
                 $ forAllShrink anyWithAtLeastOneNotifyTrue (filter (uncurry3 atLeastOneTrueNotify) . shrink)
                 $ \(environment', state, caseContracts) -> do
                   let expectedCaseIndex = fromJust . firstNotifyTrueIndex environment' state $ caseContracts
-                  Just expectedCaseIndex == ((getCaseIndex <$>) . notifyMaybe . mkApplicablesWhen environment' state $ caseContracts)
+                  Just expectedCaseIndex === ((getCaseIndex <$>) . notifyMaybe . mkApplicablesWhen environment' state $ caseContracts)
             ]
         , testGroup
             "Deposit"
@@ -89,14 +89,14 @@ tests =
                 $ forAllSuchThat (uncurry3 hasNoIdenticalEvaluatedDeposits)
                 $ \(environment', state, caseContracts) -> do
                   let evaluatedDeposits = evaluateDeposits environment' state caseContracts
-                  evaluatedDeposits == (to . deposits . mkApplicablesWhen environment' state $ caseContracts)
+                  evaluatedDeposits === (to . deposits . mkApplicablesWhen environment' state $ caseContracts)
             , testProperty
                 "Shadowing : Following Identical Evaluated Deposits are not applicable"
                 $ forAllShrink anyCaseContractsWithIdenticalEvaluatedDeposits (filter (uncurry3 hasDuplicateDeposits) . shrink)
                 $ \(environment', state, caseContracts) -> do
                   let evaluatedDeposits = evaluateDeposits environment' state caseContracts
                       canDeposits = to . deposits . mkApplicablesWhen environment' state $ caseContracts
-                  canDeposits == nubBy sameIndexedValue evaluatedDeposits
+                  canDeposits === nubBy sameIndexedValue evaluatedDeposits
             ]
         , testGroup
             "Choice"
@@ -120,15 +120,15 @@ tests =
                     $ forAllShrink anyCaseContractsWithChoiceOnlyNotShadowed shrink
                     $ \(environment', state, caseContracts) -> do
                       let indexedChoices = onlyIndexedChoices environment' state caseContracts
-                      indexedChoices == (to . choices . mkApplicablesWhen environment' state $ caseContracts)
+                      indexedChoices === (to . choices . mkApplicablesWhen environment' state $ caseContracts)
                 , testProperty
                     "\"[Indexed CanChoose]\" and [Choice] on the same id have the same merged Bounds "
                     $ withMaxSuccess 50
                     $ forAllShrink anyCaseContractsWithChoiceOnTheSameChoiceIdAndNonEmptyBounds shrink
                     $ \(environment', state, caseContracts) -> do
                       let indexedChoices = to . onlyIndexedChoices environment' state $ caseContracts
                           canChooseList = choices . mkApplicablesWhen environment' state $ caseContracts
-                      compactAdjoinedBounds indexedChoices == compactAdjoinedBounds canChooseList
+                      compactAdjoinedBounds indexedChoices === compactAdjoinedBounds canChooseList
                 ]
             ]
         ]

diff --git a/marlowe-test/test/Spec/Marlowe/Semantics/Next/Contract.hs b/marlowe-test/test/Spec/Marlowe/Semantics/Next/Contract.hs
@@ -12,19 +12,23 @@ import Spec.Marlowe.Semantics.Arbitrary ()
 
 isIrreducible :: Environment -> State -> Contract -> Bool
 isIrreducible environment' state contract =
-  case reduceContractUntilQuiescent environment' state contract of
-    ContractQuiescent False _ _ _ _ -> True
-    _otherwise -> False
+  case fixInterval (timeInterval environment') state of
+    IntervalTrimmed e s -> case reduceContractUntilQuiescent e s contract of
+      ContractQuiescent False _ _ _ _ -> True
+      _otherwise -> False
+    _ -> False
 
 isNotClose :: Environment -> State -> Contract -> Bool
 isNotClose _ _ Close = False
 isNotClose _ _ _ = True
 
 isReducible :: Environment -> State -> Contract -> Bool
 isReducible environment' state contract =
-  case reduceContractUntilQuiescent environment' state contract of
-    ContractQuiescent True _ _ _ _ -> True
-    _otherwise -> False
+  case fixInterval (timeInterval environment') state of
+    IntervalTrimmed e s -> case reduceContractUntilQuiescent e s contract of
+      ContractQuiescent True _ _ _ _ -> True
+      _otherwise -> False
+    _ -> False
 
 hasValidEnvironment :: Environment -> State -> Contract -> Bool
 hasValidEnvironment environment state contract =
@@ -37,6 +41,8 @@ hasValidEnvironment environment state contract =
 
 isReducibleToClose :: Environment -> State -> Contract -> Bool
 isReducibleToClose environment' state contract =
-  case reduceContractUntilQuiescent environment' state contract of
-    ContractQuiescent _ _ _ _ Close -> True
-    _otherwise -> False
+  case fixInterval (timeInterval environment') state of
+    IntervalTrimmed e s -> case reduceContractUntilQuiescent e s contract of
+      ContractQuiescent _ _ _ _ Close -> True
+      _otherwise -> False
+    _ -> False