Use ValidContract arbitrary instance when required

input-output-hk · Apr 11, 2024 · e84bffa · e84bffa
1 parent 093d307
commit e84bffa
Show file tree

Hide file tree

Showing 7 changed files with 22 additions and 10 deletions.
diff --git a/marlowe-cli/tests/Spec/Format.hs b/marlowe-cli/tests/Spec/Format.hs
@@ -16,9 +16,9 @@ module Spec.Format (
 
 import Data.Text (pack)
 import Language.Marlowe.CLI.Format
-import Language.Marlowe.Core.V1.Semantics.Types
+import Language.Marlowe.Core.V1.Semantics.Types ()
 import Language.Marlowe.Pretty
-import Spec.Marlowe.Semantics.Arbitrary ()
+import Spec.Marlowe.Semantics.Arbitrary (ValidContractStructure (ValidContractStructure))
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.QuickCheck (Property, testProperty, (===))
 import Text.Megaparsec
@@ -38,6 +38,6 @@ testPrettyUnPretty :: TestTree
 testPrettyUnPretty =
   testProperty "Pretty print and parse contract" prop
 
-prop :: Contract -> Property
-prop c =
+prop :: ValidContractStructure -> Property
+prop (ValidContractStructure c) =
   pure c === runParser contractParser "string" (pack . show $ pretty c)
diff --git a/marlowe-object/gen/Language/Marlowe/Object/Gen.hs b/marlowe-object/gen/Language/Marlowe/Object/Gen.hs
@@ -9,10 +9,11 @@ import Control.Monad (replicateM)
 import qualified Data.ByteString as BS
 import Data.Foldable (Foldable (fold))
 import Data.Function ((&))
+import Data.Functor ((<&>))
 import Language.Marlowe.Object.Bundler (BundlerT (..))
 import Language.Marlowe.Object.Link
 import Language.Marlowe.Object.Types
-import Spec.Marlowe.Semantics.Arbitrary ()
+import Spec.Marlowe.Semantics.Arbitrary (unValidContractStructure)
 import Test.Gen.Cardano.Api.Typed (genAddressShelley)
 import Test.QuickCheck hiding (label)
 import Test.QuickCheck.Hedgehog (hedgehog)
@@ -35,7 +36,7 @@ instance Arbitrary LinkedObject where
   arbitrary =
     oneof
       [ LinkedAction <$> arbitrary
-      , LinkedContract <$> arbitrary
+      , LinkedContract <$> (arbitrary <&> unValidContractStructure)
       , LinkedObservation <$> arbitrary
       , LinkedParty <$> arbitrary
       , LinkedToken <$> arbitrary

diff --git a/marlowe-object/marlowe-object.cabal b/marlowe-object/marlowe-object.cabal
@@ -114,6 +114,7 @@ test-suite marlowe-object-test
     , binary ^>=0.8.8
     , hspec
     , marlowe-object:{marlowe-object, gen}
+    , marlowe-test
     , QuickCheck >=2.14 && <3
     , quickcheck-classes
     , unordered-containers ^>=0.2.19

diff --git a/marlowe-object/test/Language/Marlowe/Object/TypesSpec.hs b/marlowe-object/test/Language/Marlowe/Object/TypesSpec.hs
@@ -8,6 +8,7 @@ import Data.Foldable (traverse_)
 import Data.Proxy (Proxy (..))
 import Language.Marlowe.Object.Gen ()
 import Language.Marlowe.Object.Types
+import Spec.Marlowe.Semantics.Arbitrary (ValidContractStructure (..))
 import Test.Hspec
 import Test.Hspec.QuickCheck (prop)
 import Test.QuickCheck hiding (Success, label)
@@ -28,7 +29,7 @@ spec = do
     checkLaws $ showReadLaws $ Proxy @LabelledObject
 
   describe "Contract" do
-    prop "Can decode JSON generated from core contracts" \contract ->
+    prop "Can decode JSON generated from core contracts" \(ValidContractStructure contract) ->
       fromJSON (toJSON contract) === Success (fromCoreContract contract)
 
 binaryLaws :: forall a. (Binary a, Show a, Arbitrary a, Eq a) => Proxy a -> Laws

diff --git a/marlowe-runtime-web/test/Spec.hs b/marlowe-runtime-web/test/Spec.hs
@@ -16,6 +16,7 @@ import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder)
 import qualified Data.ByteString as BS
 import Data.Coerce (coerce)
 import Data.Data (Typeable)
+import Data.Functor ((<&>))
 import qualified Data.HashMap.Strict.InsOrd as IOHM
 import Data.Kind (Type)
 import Data.OpenApi (
@@ -83,6 +84,9 @@ import Servant.API (
  )
 import Servant.OpenApi (validateEveryToJSONWithPatternChecker)
 import Spec.Marlowe.Semantics.Arbitrary ()
+import Servant.API
+import Servant.OpenApi
+import Spec.Marlowe.Semantics.Arbitrary (ValidContractStructure (unValidContractStructure))
 import Spec.Marlowe.Semantics.Next.Arbitrary ()
 import Test.Hspec (Spec, describe, hspec, it, shouldBe)
 import Test.Hspec.Golden (defaultGolden)
@@ -584,7 +588,12 @@ instance Arbitrary Web.Party where
   shrink = genericShrink
 
 instance Arbitrary Web.ContractOrSourceId where
-  arbitrary = ContractOrSourceId <$> oneof [Right <$> arbitrary, Left <$> resize 6 arbitrary]
+  arbitrary =
+    ContractOrSourceId
+      <$> oneof
+        [ Right <$> arbitrary
+        , Left <$> resize 6 (arbitrary <&> unValidContractStructure)
+        ]
   shrink = genericShrink
 
 instance Arbitrary Web.PostTransactionsRequest where

diff --git a/marlowe-test/marlowe-test.cabal b/marlowe-test/marlowe-test.cabal
@@ -156,7 +156,7 @@ library
   if flag(trace-plutus)
     cpp-options: -DTRACE_PLUTUS
 
-test-suite marlowe-test
+executable test-suite
   import:         lang
   hs-source-dirs: test
   type:           exitcode-stdio-1.0

diff --git a/marlowe-test/src/Spec/Marlowe/Semantics/Arbitrary.hs b/marlowe-test/src/Spec/Marlowe/Semantics/Arbitrary.hs
@@ -1341,7 +1341,7 @@ instance (Arbitrary a) => Arbitrary (Transaction a) where
       <> [transaction{txInput = input} | input <- shrink txInput]
       <> [transaction{txOutput = output} | output <- shrink txOutput]
 
-newtype ValidContractStructure = ValidContractStructure Contract
+newtype ValidContractStructure = ValidContractStructure {unValidContractStructure :: Contract}
   deriving (Eq, Show)
 
 instance Arbitrary ValidContractStructure where