CIP-0057: TH to derive argument and parameter blueprints. (#5831)

* Derive validator blueprints, extend blueprint test to use 2 validators.

* Compile typed validator

* Example with 2 parameters

* fail fast in case of duplicate annotations

plutus-tx-plugin/test/Blueprint/Acme.golden.json

@@ -15,17 +15,12 @@
   },
   "validators": [
     {
-      "title": "Acme Validator",
+      "title": "Acme Validator #1",
       "description": "A validator that does something awesome",
       "redeemer": {
         "title": "Acme Redeemer",
         "description": "A redeemer that does something awesome",
-        "purpose": {
-          "oneOf": [
-            "spend",
-            "mint"
-          ]
-        },
+        "purpose": "spend",
         "schema": {
           "$ref": "#/definitions/String"
         }
@@ -48,8 +43,40 @@
           }
         }
       ],
-      "compiledCode": "58ec01010032222323232300349103505435003232325333573466e1d200000218000a999ab9a3370e90010010c00cc8c8c94ccd5cd19b874800000860026eb4d5d0800cdd71aba13574400213008491035054310035573c0046aae74004dd51aba100109802a481035054310035573c0046aae74004dd50029919192999ab9a3370e90000010c0004c0112401035054310035573c0046aae74004dd5001119319ab9c001800199999a8911199a891199a89100111111400401600900380140044252005001001400084a400a0020038004008848a400e0050012410101010101010101000498101030048810001",
-      "hash": "21a5bbebc42a3d916719c975f622508a2c940ced5cd867cd3d87a019"
+      "compiledCode": "584f01010032222801199999a8911199a891199a89100111111400401600900380140044252005001001400084a400a0020038004008848a400e0050012410101010101010101000498101030048810001",
+      "hash": "a0a2b4161839094c666e8ea1952510e7f337aa10786cef62706244ba"
+    },
+    {
+      "title": "Acme Validator #2",
+      "description": "Another validator that does something awesome",
+      "redeemer": {
+        "purpose": "mint",
+        "schema": {
+          "$ref": "#/definitions/Integer"
+        }
+      },
+      "datum": {
+        "purpose": "mint",
+        "schema": {
+          "$ref": "#/definitions/Integer"
+        }
+      },
+      "parameters": [
+        {
+          "purpose": "spend",
+          "schema": {
+            "$ref": "#/definitions/Param2a"
+          }
+        },
+        {
+          "purpose": "mint",
+          "schema": {
+            "$ref": "#/definitions/Param2b"
+          }
+        }
+      ],
+      "compiledCode": "58290101003322222800199a89110014002004424520070028008ccd4488800e0010022122900380140041",
+      "hash": "67923a88b5dfccdef62abd8b3f4ff857d7582b52cde4c07b8cd34175"
     }
   ],
   "definitions": {
@@ -104,6 +131,24 @@
     "Integer": {
       "dataType": "integer"
     },
+    "Param2a": {
+      "dataType": "constructor",
+      "fields": [
+        {
+          "$ref": "#/definitions/Bool"
+        }
+      ],
+      "index": 0
+    },
+    "Param2b": {
+      "dataType": "constructor",
+      "fields": [
+        {
+          "$ref": "#/definitions/Bool"
+        }
+      ],
+      "index": 0
+    },
     "Params": {
       "dataType": "constructor",
       "fields": [

plutus-tx-plugin/test/Blueprint/Tests.hs

@@ -1,20 +1,22 @@
 {-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE TypeApplications  #-}
 
 module Blueprint.Tests where
 
 import Prelude
 
-import Blueprint.Tests.Lib (Datum, Params, Redeemer, goldenJson, serialisedScript)
+import Blueprint.Tests.Lib (Datum, Datum2, Param2a, Param2b, Params, Redeemer, Redeemer2,
+                            goldenJson, serialisedScript, validatorScript1, validatorScript2)
 import Data.Set qualified as Set
-import PlutusTx.Blueprint.Argument (ArgumentBlueprint (..))
 import PlutusTx.Blueprint.Contract (ContractBlueprint (..))
 import PlutusTx.Blueprint.Definition (definitionRef, deriveDefinitions)
-import PlutusTx.Blueprint.Parameter (ParameterBlueprint (..))
 import PlutusTx.Blueprint.PlutusVersion (PlutusVersion (PlutusV3))
 import PlutusTx.Blueprint.Preamble (Preamble (..))
 import PlutusTx.Blueprint.Purpose qualified as Purpose
+import PlutusTx.Blueprint.Schema.Annotation (SchemaDescription (..), SchemaTitle (..))
+import PlutusTx.Blueprint.TH (deriveArgumentBlueprint, deriveParameterBlueprint)
 import PlutusTx.Blueprint.Validator (ValidatorBlueprint (..))
 import PlutusTx.Blueprint.Write (writeBlueprint)
 import Test.Tasty.Extras (TestNested, testNested)
@@ -35,34 +37,38 @@ contractBlueprint =
           , preambleLicense = Just "MIT"
           }
     , contractValidators =
-        Set.singleton
-          MkValidatorBlueprint
-            { validatorTitle = "Acme Validator"
-            , validatorDescription = Just "A validator that does something awesome"
-            , validatorParameters =
-                [ MkParameterBlueprint
-                    { parameterTitle = Just "Acme Parameter"
-                    , parameterDescription = Just "A parameter that does something awesome"
-                    , parameterPurpose = Set.singleton Purpose.Spend
-                    , parameterSchema = definitionRef @Params
-                    }
-                ]
-            , validatorRedeemer =
-                MkArgumentBlueprint
-                  { argumentTitle = Just "Acme Redeemer"
-                  , argumentDescription = Just "A redeemer that does something awesome"
-                  , argumentPurpose = Set.fromList [Purpose.Spend, Purpose.Mint]
-                  , argumentSchema = definitionRef @Redeemer
-                  }
-            , validatorDatum =
-                Just
-                  MkArgumentBlueprint
-                    { argumentTitle = Just "Acme Datum"
-                    , argumentDescription = Just "A datum that contains something awesome"
-                    , argumentPurpose = Set.singleton Purpose.Spend
-                    , argumentSchema = definitionRef @Datum
-                    }
-            , validatorCompiledCode = Just serialisedScript
-            }
-    , contractDefinitions = deriveDefinitions @[Params, Redeemer, Datum]
+        Set.fromList
+          [ MkValidatorBlueprint
+              { validatorTitle =
+                  "Acme Validator #1"
+              , validatorDescription =
+                  Just "A validator that does something awesome"
+              , validatorParameters =
+                  [$(deriveParameterBlueprint ''Params (Set.singleton Purpose.Spend))]
+              , validatorRedeemer =
+                  $(deriveArgumentBlueprint ''Redeemer (Set.singleton Purpose.Spend))
+              , validatorDatum =
+                  Just $(deriveArgumentBlueprint ''Datum (Set.singleton Purpose.Spend))
+              , validatorCompiledCode =
+                  Just (serialisedScript validatorScript1)
+              }
+          , MkValidatorBlueprint
+              { validatorTitle =
+                  "Acme Validator #2"
+              , validatorDescription =
+                  Just "Another validator that does something awesome"
+              , validatorParameters =
+                  [ $(deriveParameterBlueprint ''Param2a (Set.singleton Purpose.Spend))
+                  , $(deriveParameterBlueprint ''Param2b (Set.singleton Purpose.Mint))
+                  ]
+              , validatorRedeemer =
+                  $(deriveArgumentBlueprint ''Redeemer2 (Set.singleton Purpose.Mint))
+              , validatorDatum =
+                  Just $(deriveArgumentBlueprint ''Datum2 (Set.singleton Purpose.Mint))
+              , validatorCompiledCode =
+                  Just (serialisedScript validatorScript2)
+              }
+          ]
+    , contractDefinitions =
+        deriveDefinitions @[Params, Redeemer, Datum, Param2a, Param2b, Redeemer2, Datum2]
     }

plutus-tx-plugin/test/Blueprint/Tests/Lib.hs

@@ -24,35 +24,35 @@ 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 (..), emptyBytesSchema)
 import PlutusTx.Blueprint.Schema.Annotation (SchemaComment (..), SchemaDescription (..),
                                              SchemaInfo (..), SchemaTitle (..), emptySchemaInfo)
-import PlutusTx.Builtins.Internal (BuiltinByteString, BuiltinString, emptyByteString)
-import PlutusTx.Prelude qualified as PlutusTx
+import PlutusTx.Blueprint.TH (makeIsDataSchemaIndexed)
+import PlutusTx.Builtins.Internal (BuiltinByteString, BuiltinData, BuiltinString, emptyByteString)
+import PlutusTx.Code qualified as PlutusTx
+import PlutusTx.IsData (FromData, ToData (..), UnsafeFromData (..))
+import PlutusTx.Lift qualified as PlutusTx
+import PlutusTx.TH 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)
+----------------------------------------------------------------------------------------------------
+-- Validator 1 for testing blueprints --------------------------------------------------------------
 
+{-# ANN type Params (SchemaTitle "Acme Parameter") #-}
+{-# ANN type Params (SchemaDescription "A parameter that does something awesome") #-}
 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)
@@ -66,66 +66,104 @@ 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
 
 {-# ANN MkDatumPayload (SchemaComment "MkDatumPayload") #-}
+
 data DatumPayload = MkDatumPayload
-  { myAwesomeDatum1 :: Integer
-  , myAwesomeDatum2 :: Bytes Void
+  { myAwesomeDatum1 :: Integer,
+    myAwesomeDatum2 :: Bytes Void
   }
   deriving stock (Generic)
   deriving anyclass (AsDefinitionId)
 
+{-# ANN type Datum (SchemaTitle "Acme Datum") #-}
+{-# ANN type Datum (SchemaDescription "A datum that contains something awesome") #-}
+
 {-# ANN DatumLeft (SchemaTitle "Datum") #-}
 {-# ANN DatumLeft (SchemaDescription "DatumLeft") #-}
 {-# ANN DatumLeft (SchemaComment "This constructor is parameterless") #-}
+
 {-# ANN DatumRight (SchemaTitle "Datum") #-}
 {-# ANN DatumRight (SchemaDescription "DatumRight") #-}
 {-# ANN DatumRight (SchemaComment "This constructor has a payload") #-}
+
 data Datum = DatumLeft | DatumRight DatumPayload
   deriving stock (Generic)
   deriving anyclass (AsDefinitionId)
 
+{-# ANN type Redeemer (SchemaTitle "Acme Redeemer") #-}
+{-# ANN type Redeemer (SchemaDescription "A redeemer that does something awesome") #-}
+
 type Redeemer = BuiltinString
 
 type ScriptContext = ()
 
-type Validator = Params -> Datum -> Redeemer -> ScriptContext -> Bool
-
 $(makeIsDataSchemaIndexed ''DatumPayload [('MkDatumPayload, 0)])
 $(makeIsDataSchemaIndexed ''Datum [('DatumLeft, 0), ('DatumRight, 1)])
 
-serialisedScript :: ByteString
-serialisedScript =
+{-# INLINEABLE typedValidator1 #-}
+typedValidator1 :: Params -> Datum -> Redeemer -> ScriptContext -> Bool
+typedValidator1 _params _datum _redeemer _context = False
+
+validatorScript1 :: PlutusTx.CompiledCode (Datum -> Redeemer -> ScriptContext -> Bool)
+validatorScript1 =
+  $$(PlutusTx.compile [||typedValidator1||])
+    `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef
+      MkParams
+        { myUnit = (),
+          myBool = True,
+          myInteger = fromIntegral (maxBound @Int) + 1,
+          myBuiltinData = toBuiltinData (3 :: Integer),
+          myBuiltinByteString = emptyByteString
+        }
+
+----------------------------------------------------------------------------------------------------
+-- Validator 2 for testing blueprints --------------------------------------------------------------
+
+newtype Param2a = MkParam2a Bool
+  deriving stock (Generic)
+  deriving anyclass (AsDefinitionId)
+
+$(PlutusTx.makeLift ''Param2a)
+$(makeIsDataSchemaIndexed ''Param2a [('MkParam2a, 0)])
+
+newtype Param2b = MkParam2b Bool
+  deriving stock (Generic)
+  deriving anyclass (AsDefinitionId)
+
+$(PlutusTx.makeLift ''Param2b)
+$(makeIsDataSchemaIndexed ''Param2b [('MkParam2b, 0)])
+
+type Datum2 = Integer
+
+type Redeemer2 = Integer
+
+{-# INLINEABLE typedValidator2 #-}
+typedValidator2 :: Param2a -> Param2b -> Datum2 -> Redeemer2 -> ScriptContext -> Bool
+typedValidator2 _p1 _p2 _datum _redeemer _context = True
+
+validatorScript2 :: PlutusTx.CompiledCode (Datum2 -> Redeemer2 -> ScriptContext -> Bool)
+validatorScript2 =
+  $$(PlutusTx.compile [||typedValidator2||])
+    `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef (MkParam2a False)
+    `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef (MkParam2b True)
+
+----------------------------------------------------------------------------------------------------
+-- Helper functions --------------------------------------------------------------------------------
+
+serialisedScript :: PlutusTx.CompiledCode t -> ByteString
+serialisedScript validatorScript =
   PlutusTx.getPlcNoAnn validatorScript
     & over UPLC.progTerm (UPLC.termMapNames UPLC.unNameDeBruijn)
     & UPLC.UnrestrictedProgram
     & 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
-          }
+
+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)

plutus-tx/src/PlutusTx/Blueprint/Argument.hs

@@ -28,7 +28,7 @@ data ArgumentBlueprint (referencedTypes :: [Type]) = MkArgumentBlueprint
   , argumentSchema      :: Schema referencedTypes
   -- ^ A Plutus Data Schema.
   }
-  deriving stock (Show, Eq)
+  deriving stock (Show, Eq, Ord)
 
 instance ToJSON (ArgumentBlueprint referencedTypes) where
   toJSON MkArgumentBlueprint{..} =

plutus-tx/src/PlutusTx/Blueprint/Parameter.hs

@@ -34,7 +34,7 @@ data ParameterBlueprint (referencedTypes :: [Type]) = MkParameterBlueprint
   , parameterSchema      :: Schema referencedTypes
   -- ^ A Plutus Data Schema.
   }
-  deriving stock (Show, Eq)
+  deriving stock (Show, Eq, Ord)
 
 instance ToJSON (ParameterBlueprint referencedTypes) where
   toJSON MkParameterBlueprint{..} =