all files have been homogenized import-wise

tweag · May 6, 2024 · fe5759e · fe5759e
1 parent 63c5f41
commit fe5759e
Show file tree

Hide file tree

Showing 20 changed files with 507 additions and 509 deletions.
diff --git a/cooked-validators.cabal b/cooked-validators.cabal
@@ -138,7 +138,6 @@ test-suite spec
       Cooked.ReferenceInputsSpec
       Cooked.ReferenceScriptsSpec
       Cooked.ShowBSSpec
-      Cooked.TestUtils
       Cooked.Tweak.CommonSpec
       Cooked.Tweak.OutPermutationsSpec
       Cooked.Tweak.TamperDatumSpec

diff --git a/src/Cooked/MockChain/Testing.hs b/src/Cooked/MockChain/Testing.hs
@@ -15,9 +15,10 @@ import Ledger qualified
 import Test.QuickCheck qualified as QC
 import Test.Tasty.HUnit qualified as HU
 
--- | This module provides a common interface for HUnit and QuickCheck tests.
--- We do so by abstracting uses of 'HU.Assertion' and 'QC.Property' for @(IsProp prop) => prop@,
--- then provide instances for both @HU.Asserton@ and @QC.Property@.
+-- | This module provides a common interface for HUnit and QuickCheck
+-- tests. We do so by abstracting uses of 'HU.Assertion' and
+-- 'QC.Property' for @(IsProp prop) => prop@, then provide instances
+-- for both @HU.Asserton@ and @QC.Property@.
 class IsProp prop where
   -- | Displays the string to the user in case of failure
   testCounterexample :: String -> prop -> prop
@@ -62,22 +63,22 @@ infixr 2 .||.
 (.||.) :: (IsProp prop) => prop -> prop -> prop
 a .||. b = testDisjoin [a, b]
 
--- | Ensure that all results produced by the staged mockchain /succeed/, starting
--- from the default initial distribution
+-- | Ensure that all results produced by the staged mockchain
+-- /succeed/, starting from the default initial distribution
 testSucceeds :: (IsProp prop) => PrettyCookedOpts -> StagedMockChain a -> prop
 testSucceeds pcOpts = testSucceedsFrom pcOpts def
 
--- | Ensure that all results produced by the staged mockchain /fail/ and that a
--- predicate holds over the error.
+-- | Ensure that all results produced by the staged mockchain /fail/
+-- and that a predicate holds over the error.
 --
 -- To test that validation fails, use
 -- > testFails def (isCekEvaluationFailure def) e
 testFails :: (IsProp prop, Show a) => PrettyCookedOpts -> (MockChainError -> prop) -> StagedMockChain a -> prop
 testFails pcOpts predi = testFailsFrom pcOpts predi def
 
--- | Ensure that all results produced by the staged mockchain succeed starting
--- from some initial distribution but doesn't impose any additional condition on success.
--- Use 'testSucceedsFrom'' for that.
+-- | Ensure that all results produced by the staged mockchain succeed
+-- starting from some initial distribution but doesn't impose any
+-- additional condition on success.  Use 'testSucceedsFrom'' for that.
 testSucceedsFrom ::
   (IsProp prop) =>
   PrettyCookedOpts ->
@@ -86,9 +87,9 @@ testSucceedsFrom ::
   prop
 testSucceedsFrom pcOpts = testSucceedsFrom' pcOpts (\_ _ -> testSuccess)
 
--- | Ensure that all results produced by the staged mockchain succeed starting
--- from some initial distribution. Additionally impose a condition over the
--- resulting state and value.
+-- | Ensure that all results produced by the staged mockchain succeed
+-- starting from some initial distribution. Additionally impose a
+-- condition over the resulting state and value.
 testSucceedsFrom' ::
   (IsProp prop) =>
   PrettyCookedOpts ->
@@ -98,8 +99,8 @@ testSucceedsFrom' ::
   prop
 testSucceedsFrom' pcOpts prop = testAllSatisfiesFrom pcOpts (either (testFailureMsg . renderString (prettyCookedOpt pcOpts)) (uncurry prop))
 
--- | Ensure that all results produced by the staged mockchain /fail/ starting
--- from some initial distribution.
+-- | Ensure that all results produced by the staged mockchain /fail/
+-- starting from some initial distribution.
 testFailsFrom ::
   (IsProp prop, Show a) =>
   PrettyCookedOpts ->
@@ -112,25 +113,30 @@ testFailsFrom pcOpts predi =
     pcOpts
     (either predi (testFailureMsg . renderString (prettyCookedOpt pcOpts)))
 
--- | Is satisfied when the given 'MockChainError' is wrapping a @CekEvaluationFailure@.
--- This is particularly important when writing negative tests. For example, if we are simulating
--- an attack and writing a test with 'testFailsFrom', we might have made a mistake in the attack,
--- yielding a test that fails for reasons such as @ValueLessThanMinAda@ or @ValueNotPreserved@, which
--- does not rule out the attack being caught by the validator script. For these scenarios it is
--- paramount to rely on @testFailsFrom' isCekEvaluationFailure@ instead.
+-- | Is satisfied when the given 'MockChainError' is wrapping a
+-- @CekEvaluationFailure@.  This is particularly important when
+-- writing negative tests. For example, if we are simulating an attack
+-- and writing a test with 'testFailsFrom', we might have made a
+-- mistake in the attack, yielding a test that fails for reasons such
+-- as @ValueLessThanMinAda@ or @ValueNotPreserved@, which does not
+-- rule out the attack being caught by the validator script. For these
+-- scenarios it is paramount to rely on @testFailsFrom'
+-- isCekEvaluationFailure@ instead.
 isCekEvaluationFailure :: (IsProp prop) => PrettyCookedOpts -> MockChainError -> prop
 isCekEvaluationFailure _ (MCEValidationError _ (Ledger.ScriptFailure _)) = testSuccess
 isCekEvaluationFailure pcOpts e = testFailureMsg $ "Expected 'CekEvaluationFailure', got: " ++ renderString (prettyCookedOpt pcOpts) e
 
--- | Similar to 'isCekEvaluationFailure', but enables us to check for a specific error message in the error.
+-- | Similar to 'isCekEvaluationFailure', but enables us to check for
+-- a specific error message in the error.
 isCekEvaluationFailureWithMsg :: (IsProp prop) => PrettyCookedOpts -> (String -> Bool) -> MockChainError -> prop
 isCekEvaluationFailureWithMsg _ f (MCEValidationError _ (Ledger.ScriptFailure (Ledger.EvaluationError msgs _)))
   | any (f . T.unpack) msgs = testSuccess
 isCekEvaluationFailureWithMsg pcOpts _ e = testFailureMsg $ "Expected 'CekEvaluationFailure' with specific messages, got: " ++ renderString (prettyCookedOpt pcOpts) e
 
--- | Ensure that all results produced by the set of traces encoded by the 'StagedMockChain'
--- satisfy the given predicate. If you wish to build custom predicates
--- you can use 'testSatisfiesFrom'' directly and see 'testBinaryRelatedBy' as an example.
+-- | Ensure that all results produced by the set of traces encoded by
+-- the 'StagedMockChain' satisfy the given predicate. If you wish to
+-- build custom predicates you can use 'testSatisfiesFrom'' directly
+-- and see 'testBinaryRelatedBy' as an example.
 testAllSatisfiesFrom ::
   forall prop a.
   (IsProp prop) =>
@@ -144,9 +150,10 @@ testAllSatisfiesFrom pcOpts f = testSatisfiesFrom' (testAll go)
     go :: (Either MockChainError (a, UtxoState), MockChainLog) -> prop
     go (prop, mcLog) = testCounterexample (renderString (prettyCookedOpt pcOpts) mcLog) (f prop)
 
--- | Asserts that the given 'StagedMockChain' produces exactly two outcomes, both of which
--- are successful and have their resulting states related by a given predicate. A typical
--- usage would look like:
+-- | Asserts that the given 'StagedMockChain' produces exactly two
+-- outcomes, both of which are successful and have their resulting
+-- states related by a given predicate. A typical usage would look
+-- like:
 --
 -- > testBinaryRelatedBy equalModuloAda myInitDistr $ do
 -- >   x <- trPrepare
@@ -179,14 +186,17 @@ testBinaryRelatedBy pcOpts rel = testSatisfiesFrom' $ \case
           ]
   xs -> testFailureMsg $ "Expected exactly two outcomes, received: " ++ show (length xs)
 
--- | Generalizes 'testBinaryRelatedBy', asserting that the given 'StagedMockChain' produces
--- more than two outcomes, say @[x,y,z,w]@, all of which are successful (i.e. are not a 'MockChainError')
--- and these states are in the same equivalence class of (~); that is, they satisfy:
+-- | Generalizes 'testBinaryRelatedBy', asserting that the given
+-- 'StagedMockChain' produces more than two outcomes, say @[x,y,z,w]@,
+-- all of which are successful (i.e. are not a 'MockChainError') and
+-- these states are in the same equivalence class of (~); that is,
+-- they satisfy:
 --
 -- > x ~ y && x ~ z && x ~ z && x ~ w
 --
--- Because @(~)@ should be symmetric and transitive we can estabilish that these states all belong
--- to the same equivalence class. This function does /not/ check each pointwise case.
+-- Because @(~)@ should be symmetric and transitive we can estabilish
+-- that these states all belong to the same equivalence class. This
+-- function does /not/ check each pointwise case.
 testOneEquivClass ::
   (IsProp prop) =>
   PrettyCookedOpts ->
@@ -200,20 +210,23 @@ testOneEquivClass pcOpts rel = testSatisfiesFrom' $ \case
   ((Left errX, tx) : _) -> testFailureMsg $ concat ["First outcome is a failure: ", renderString (prettyCookedOpt pcOpts) errX, "\n", renderString (prettyCookedOpt pcOpts) tx]
   ((Right resX, _) : xs) -> go (snd resX) xs
   where
-    -- we can flag a success here because 'xs' above is guarnateed to have at least
-    -- one element since we ruled out the empty and the singleton lists in the \case
+    -- we can flag a success here because 'xs' above is guarnateed to
+    -- have at least one element since we ruled out the empty and the
+    -- singleton lists in the \case
     go _resX [] = testSuccess
     go _resX ((Left errY, ty) : _) = testFailureMsg $ concat ["An outcome is a failure: ", renderString (prettyCookedOpt pcOpts) errY, "\n", renderString (prettyCookedOpt pcOpts) ty]
     go resX ((Right (_, resY), _) : ys) = testConjoin [rel resX resY, go resX ys]
 
--- | Asserts that the results produced by running the given 'StagedMockChain' from
--- some speficied 'InitialDistribution' satisfy a given assertion. In this case,
--- the predicate gets the trace descriptions that led to each potential outcome
--- and is responsible for calling 'testCounterexample' communicate these to the user.
+-- | Asserts that the results produced by running the given
+-- 'StagedMockChain' from some speficied 'InitialDistribution' satisfy
+-- a given assertion. In this case, the predicate gets the trace
+-- descriptions that led to each potential outcome and is responsible
+-- for calling 'testCounterexample' communicate these to the user.
 --
--- Although this function is mainly used internally, as a building block for the simpler predicates,
--- it can be useful in building some custom predicates. Check 'testAllSatisfiesFrom'
--- or 'testBinaryRelatedBy' for examples on using this.
+-- Although this function is mainly used internally, as a building
+-- block for the simpler predicates, it can be useful in building some
+-- custom predicates. Check 'testAllSatisfiesFrom' or
+-- 'testBinaryRelatedBy' for examples on using this.
 testSatisfiesFrom' ::
   ([(Either MockChainError (a, UtxoState), MockChainLog)] -> prop) ->
   InitialDistribution ->
@@ -254,16 +267,41 @@ instance IsProp QC.Property where
   testConjoin = QC.conjoin
   testDisjoin = QC.disjoin
 
--- | Here we provide our own universsal quantifier instead of 'QC.forAll', so we can monomorphize
---  it to returning a 'QC.Property'
+-- | Here we provide our own universsal quantifier instead of
+--  'QC.forAll', so we can monomorphize it to returning a
+--  'QC.Property'
 forAll :: (Show a) => QC.Gen a -> (a -> QC.Property) -> QC.Property
 forAll = QC.forAll
 
--- TODO: Discuss this instance; its here to enable us to easily
--- run things in a repl but I'm not sure whether to ignore the counterexample
--- messages or not.
+-- TODO: Discuss this instance; its here to enable us to easily run
+-- things in a repl but I'm not sure whether to ignore the
+-- counterexample messages or not.
 instance IsProp Bool where
   testCounterexample msg False = trace msg False
   testCounterexample _ True = True
   testConjoin = and
   testDisjoin = or
+
+assertSubset :: (Show a, Eq a) => [a] -> [a] -> HU.Assertion
+assertSubset l r =
+  testConjoin
+    ( map
+        ( \x ->
+            HU.assertBool
+              ( "not a subset:\n\n"
+                  ++ show x
+                  ++ "\n\nis not an element of\n\n"
+                  ++ show r
+              )
+              $ x `elem` r
+        )
+        l
+    )
+
+assertSameSets :: (Show a, Eq a) => [a] -> [a] -> HU.Assertion
+assertSameSets l r =
+  HU.assertBool
+    ("expected lists of the same length, got " ++ show (length l) ++ " and " ++ show (length r))
+    (length l == length r)
+    .&&. assertSubset l r
+    .&&. assertSubset r l
diff --git a/src/Cooked/Tweak/ValidityRange.hs b/src/Cooked/Tweak/ValidityRange.hs
@@ -5,8 +5,8 @@ import Control.Monad
 import Cooked.MockChain
 import Cooked.Skeleton
 import Cooked.Tweak.Common
-import Ledger qualified
-import PlutusLedgerApi.V3 qualified as Api
+import Ledger.Slot qualified as Ledger
+import PlutusLedgerApi.V1.Interval qualified as Api
 
 getValidityRangeTweak :: (MonadTweak m) => m Ledger.SlotRange
 getValidityRangeTweak = viewTweak txSkelValidityRangeL
@@ -36,19 +36,19 @@ validityRangeSatisfiesTweak = (<$> getValidityRangeTweak)
 
 -- | Checks if a given time belongs to the validity range of a transaction
 isValidAtTweak :: (MonadTweak m) => Ledger.Slot -> m Bool
-isValidAtTweak = validityRangeSatisfiesTweak . Ledger.member
+isValidAtTweak = validityRangeSatisfiesTweak . Api.member
 
 -- | Checks if the current validity range includes the current time
 isValidNowTweak :: (MonadTweak m) => m Bool
 isValidNowTweak = currentSlot >>= isValidAtTweak
 
 -- | Checks if a given range is included in the validity range of a transaction
 isValidDuringTweak :: (MonadTweak m) => Ledger.SlotRange -> m Bool
-isValidDuringTweak = validityRangeSatisfiesTweak . flip Ledger.contains
+isValidDuringTweak = validityRangeSatisfiesTweak . flip Api.contains
 
 -- | Checks if the validity range is empty
 hasEmptyTimeRangeTweak :: (MonadTweak m) => m Bool
-hasEmptyTimeRangeTweak = validityRangeSatisfiesTweak Ledger.isEmpty
+hasEmptyTimeRangeTweak = validityRangeSatisfiesTweak Api.isEmpty
 
 -- | Checks if the validity range is unconstrained
 hasFullTimeRangeTweak :: (MonadTweak m) => m Bool
@@ -59,8 +59,8 @@ hasFullTimeRangeTweak = validityRangeSatisfiesTweak (Api.always ==)
 intersectValidityRangeTweak :: (MonadTweak m) => Ledger.SlotRange -> m Ledger.SlotRange
 intersectValidityRangeTweak newRange = do
   oldRange <- viewTweak txSkelValidityRangeL
-  let combinedRange = Ledger.intersection newRange oldRange
-  guard (combinedRange /= Ledger.never)
+  let combinedRange = Api.intersection newRange oldRange
+  guard (combinedRange /= Api.never)
   setTweak txSkelValidityRangeL combinedRange
   return oldRange
 
@@ -70,12 +70,12 @@ centerAroundValidityRangeTweak t r = do
   let radius = Ledger.Slot r
       left = t - radius
       right = t + radius
-      newRange = Ledger.interval left right
+      newRange = Api.interval left right
   setValidityRangeTweak newRange
 
 -- | Makes a transaction range equal to a singleton
 makeValidityRangeSingletonTweak :: (MonadTweak m) => Ledger.Slot -> m Ledger.SlotRange
-makeValidityRangeSingletonTweak = setValidityRangeTweak . Ledger.singleton
+makeValidityRangeSingletonTweak = setValidityRangeTweak . Api.singleton
 
 -- | Makes the transaction validity range comply with the current time
 makeValidityRangeNowTweak :: (MonadTweak m) => m Ledger.SlotRange
@@ -88,11 +88,11 @@ waitUntilValidTweak :: (MonadTweak m) => m Ledger.Slot
 waitUntilValidTweak = do
   now <- currentSlot
   vRange <- getValidityRangeTweak
-  if Ledger.member now vRange
+  if Api.member now vRange
     then return now
     else do
-      guard $ Ledger.before now vRange
-      guard $ not $ Ledger.isEmpty vRange
+      guard $ Api.before now vRange
+      guard $ not $ Api.isEmpty vRange
       later <- case Api.ivFrom vRange of
         Api.LowerBound (Api.Finite left) isClosed ->
           return $ left + Ledger.Slot (toInteger $ fromEnum $ not isClosed)