Extract goldenJson function and move it to the Tests.Lib

IntersectMBO · Mar 11, 2024 · 4605a2d · 4605a2d
1 parent b2bcbf9
commit 4605a2d
Show file tree

Hide file tree

Showing 2 changed files with 89 additions and 89 deletions.
diff --git a/plutus-tx-plugin/test/Blueprint/Tests.hs b/plutus-tx-plugin/test/Blueprint/Tests.hs
@@ -11,75 +11,63 @@
 
 module Blueprint.Tests where
 
-import PlutusTx.Blueprint
-import Prelude
-
+import Blueprint.Tests.Lib (goldenJson)
 import Blueprint.Tests.Lib qualified as Fixture
-import Control.Monad.Reader (asks)
 import Data.Set qualified as Set
+import PlutusTx.Blueprint
 import PlutusTx.Blueprint.Purpose qualified as Purpose
-import System.FilePath ((</>))
-import Test.Tasty (TestName)
+import Prelude
 import Test.Tasty.Extras (TestNested, testNested)
-import Test.Tasty.Golden (goldenVsFile)
 
 goldenTests :: TestNested
-goldenTests = testNested "Blueprint" [goldenBlueprint "Acme" contractBlueprint]
-
-goldenBlueprint :: TestName -> ContractBlueprint types -> TestNested
-goldenBlueprint name blueprint = do
-  goldenPath <- asks $ foldr (</>) name
-  let actual = goldenPath ++ ".actual.json"
-  let golden = goldenPath ++ ".golden.json"
-  pure $ goldenVsFile name golden actual (writeBlueprint actual blueprint)
+goldenTests = testNested "Blueprint" [goldenJson "Acme" (`writeBlueprint` contractBlueprint)]
 
-{- | All the data types exposed (directly or indirectly) by the type signature of the validator
-This type level list is used to:
-1. derive the schema definitions for the contract.
-2. make "safe" references to the [derived] schema definitions.
--}
+-- | All the data types exposed (directly or indirectly) by the type signature of the validator
+-- This type level list is used to:
+-- 1. derive the schema definitions for the contract.
+-- 2. make "safe" references to the [derived] schema definitions.
 contractBlueprint :: Blueprint [Fixture.Params, Fixture.Redeemer, Fixture.Datum]
 contractBlueprint =
   MkContractBlueprint
-    { contractId = Nothing
-    , contractPreamble =
+    { contractId = Nothing,
+      contractPreamble =
         MkPreamble
-          { preambleTitle = "Acme Contract"
-          , preambleDescription = Just "A contract that does something awesome"
-          , preambleVersion = "1.1.0"
-          , preamblePlutusVersion = PlutusV3
-          , preambleLicense = Just "MIT"
-          }
-    , contractValidators =
+          { preambleTitle = "Acme Contract",
+            preambleDescription = Just "A contract that does something awesome",
+            preambleVersion = "1.1.0",
+            preamblePlutusVersion = PlutusV3,
+            preambleLicense = Just "MIT"
+          },
+      contractValidators =
         Set.singleton
           MkValidatorBlueprint
-            { validatorTitle = "Acme Validator"
-            , validatorDescription = Just "A validator that does something awesome"
-            , validatorParameters =
+            { validatorTitle = "Acme Validator",
+              validatorDescription = Just "A validator that does something awesome",
+              validatorParameters =
                 Just $
                   pure
                     MkParameterBlueprint
-                      { parameterTitle = Just "Acme Parameter"
-                      , parameterDescription = Just "A parameter that does something awesome"
-                      , parameterPurpose = Set.singleton Purpose.Spend
-                      , parameterSchema = definitionRef @Fixture.Params
-                      }
-            , validatorRedeemer =
+                      { parameterTitle = Just "Acme Parameter",
+                        parameterDescription = Just "A parameter that does something awesome",
+                        parameterPurpose = Set.singleton Purpose.Spend,
+                        parameterSchema = definitionRef @Fixture.Params
+                      },
+              validatorRedeemer =
                 MkArgumentBlueprint
-                  { argumentTitle = Just "Acme Redeemer"
-                  , argumentDescription = Just "A redeemer that does something awesome"
-                  , argumentPurpose = Set.fromList [Purpose.Spend, Purpose.Mint]
-                  , argumentSchema = definitionRef @Fixture.Redeemer
-                  }
-            , validatorDatum =
+                  { argumentTitle = Just "Acme Redeemer",
+                    argumentDescription = Just "A redeemer that does something awesome",
+                    argumentPurpose = Set.fromList [Purpose.Spend, Purpose.Mint],
+                    argumentSchema = definitionRef @Fixture.Redeemer
+                  },
+              validatorDatum =
                 Just
                   MkArgumentBlueprint
-                    { argumentTitle = Just "Acme Datum"
-                    , argumentDescription = Just "A datum that contains something awesome"
-                    , argumentPurpose = Set.singleton Purpose.Spend
-                    , argumentSchema = definitionRef @Fixture.Datum
-                    }
-            , validatorCompiledCode = Just Fixture.serialisedScript
-            }
-    , contractDefinitions = deriveSchemaDefinitions
+                    { argumentTitle = Just "Acme Datum",
+                      argumentDescription = Just "A datum that contains something awesome",
+                      argumentPurpose = Set.singleton Purpose.Spend,
+                      argumentSchema = definitionRef @Fixture.Datum
+                    },
+              validatorCompiledCode = Just Fixture.serialisedScript
+            },
+      contractDefinitions = deriveSchemaDefinitions
     }
diff --git a/plutus-tx-plugin/test/Blueprint/Tests/Lib.hs b/plutus-tx-plugin/test/Blueprint/Tests/Lib.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE BangPatterns          #-}
+{-# LANGUAGE BlockArguments        #-}
 {-# LANGUAGE DataKinds             #-}
 {-# LANGUAGE DeriveAnyClass        #-}
 {-# LANGUAGE DerivingStrategies    #-}
@@ -14,31 +15,42 @@
 
 module Blueprint.Tests.Lib where
 
-import PlutusTx hiding (Typeable)
-import Prelude
-
 import Codec.Serialise (serialise)
 import Control.Lens (over, (&))
+import Control.Monad.Reader (asks)
 import Data.ByteString (ByteString)
 import Data.ByteString.Lazy qualified as LBS
 import Data.Kind (Type)
 import Data.Void (Void)
 import Flat qualified
 import GHC.Generics (Generic)
 import PlutusCore.Version (plcVersion110)
+import PlutusTx hiding (Typeable)
 import PlutusTx.Blueprint.Class (HasSchema (..))
 import PlutusTx.Blueprint.Definition (AsDefinitionId, definitionRef)
 import PlutusTx.Blueprint.Schema (Schema (..), SchemaInfo (..), emptyBytesSchema, emptySchemaInfo)
 import PlutusTx.Builtins.Internal (BuiltinByteString, BuiltinString, emptyByteString)
 import PlutusTx.Prelude qualified as PlutusTx
+import Prelude
+import System.FilePath ((</>))
+import Test.Tasty (TestName)
+import Test.Tasty.Extras (TestNested)
+import Test.Tasty.Golden (goldenVsFile)
 import UntypedPlutusCore qualified as UPLC
 
+goldenJson :: TestName -> (FilePath -> IO ()) -> TestNested
+goldenJson name cb = do
+  goldenPath <- asks $ foldr (</>) name
+  let actual = goldenPath ++ ".actual.json"
+  let golden = goldenPath ++ ".golden.json"
+  pure $ goldenVsFile name golden actual (cb actual)
+
 data Params = MkParams
-  { myUnit              :: ()
-  , myBool              :: Bool
-  , myInteger           :: Integer
-  , myBuiltinData       :: BuiltinData
-  , myBuiltinByteString :: BuiltinByteString
+  { myUnit              :: (),
+    myBool              :: Bool,
+    myInteger           :: Integer,
+    myBuiltinData       :: BuiltinData,
+    myBuiltinByteString :: BuiltinByteString
   }
   deriving stock (Generic)
   deriving anyclass (AsDefinitionId)
@@ -52,11 +64,11 @@ newtype Bytes (phantom :: Type) = MkAcmeBytes BuiltinByteString
   deriving newtype (ToData, FromData, UnsafeFromData)
 
 instance HasSchema (Bytes phantom) ts where
-  schema = SchemaBytes emptySchemaInfo{title = Just "SchemaBytes"} emptyBytesSchema
+  schema = SchemaBytes emptySchemaInfo {title = Just "SchemaBytes"} emptyBytesSchema
 
 data DatumPayload = MkDatumPayload
-  { myAwesomeDatum1 :: Integer
-  , myAwesomeDatum2 :: Bytes Void
+  { myAwesomeDatum1 :: Integer,
+    myAwesomeDatum2 :: Bytes Void
   }
   deriving stock (Generic)
   deriving anyclass (AsDefinitionId)
@@ -83,29 +95,29 @@ serialisedScript =
     & Flat.flat
     & serialise
     & LBS.toStrict
- where
-  {-# INLINEABLE typedValidator #-}
-  typedValidator :: Validator
-  typedValidator _params _datum _redeemer _context = False
-
-  {-# INLINEABLE untypedValidator #-}
-  untypedValidator :: Params -> BuiltinData -> BuiltinString -> BuiltinData -> ()
-  untypedValidator params datum redeemer ctx =
-    PlutusTx.check $ typedValidator params acmeDatum acmeRedeemer scriptContext
-   where
-    acmeDatum :: Datum = PlutusTx.unsafeFromBuiltinData datum
-    acmeRedeemer :: Redeemer = redeemer
-    scriptContext :: ScriptContext = PlutusTx.unsafeFromBuiltinData ctx
-
-  validatorScript :: PlutusTx.CompiledCode (BuiltinData -> BuiltinString -> BuiltinData -> ())
-  validatorScript =
-    $$(PlutusTx.compile [||untypedValidator||])
-      `PlutusTx.unsafeApplyCode` PlutusTx.liftCode
-        plcVersion110
-        MkParams
-          { myUnit = ()
-          , myBool = True
-          , myInteger = fromIntegral (maxBound @Int) + 1
-          , myBuiltinData = PlutusTx.toBuiltinData (3 :: Integer)
-          , myBuiltinByteString = emptyByteString
-          }
+  where
+    {-# INLINEABLE typedValidator #-}
+    typedValidator :: Validator
+    typedValidator _params _datum _redeemer _context = False
+
+    {-# INLINEABLE untypedValidator #-}
+    untypedValidator :: Params -> BuiltinData -> BuiltinString -> BuiltinData -> ()
+    untypedValidator params datum redeemer ctx =
+      PlutusTx.check $ typedValidator params acmeDatum acmeRedeemer scriptContext
+      where
+        acmeDatum :: Datum = PlutusTx.unsafeFromBuiltinData datum
+        acmeRedeemer :: Redeemer = redeemer
+        scriptContext :: ScriptContext = PlutusTx.unsafeFromBuiltinData ctx
+
+    validatorScript :: PlutusTx.CompiledCode (BuiltinData -> BuiltinString -> BuiltinData -> ())
+    validatorScript =
+      $$(PlutusTx.compile [||untypedValidator||])
+        `PlutusTx.unsafeApplyCode` PlutusTx.liftCode
+          plcVersion110
+          MkParams
+            { myUnit = (),
+              myBool = True,
+              myInteger = fromIntegral (maxBound @Int) + 1,
+              myBuiltinData = PlutusTx.toBuiltinData (3 :: Integer),
+              myBuiltinByteString = emptyByteString
+            }