From c3b3ceadbb4cdab38c369b1e30ac7d3ad6b46fa7 Mon Sep 17 00:00:00 2001 From: Yura Lazarev Date: Mon, 18 Mar 2024 14:42:58 +0100 Subject: [PATCH] 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 --- .../test/Blueprint/Acme.golden.json | 63 ++++++-- plutus-tx-plugin/test/Blueprint/Tests.hs | 72 +++++----- plutus-tx-plugin/test/Blueprint/Tests/Lib.hs | 134 +++++++++++------- plutus-tx/src/PlutusTx/Blueprint/Argument.hs | 2 +- plutus-tx/src/PlutusTx/Blueprint/Parameter.hs | 2 +- plutus-tx/src/PlutusTx/Blueprint/Purpose.hs | 3 +- plutus-tx/src/PlutusTx/Blueprint/Schema.hs | 14 +- .../PlutusTx/Blueprint/Schema/Annotation.hs | 8 +- plutus-tx/src/PlutusTx/Blueprint/TH.hs | 56 +++++++- plutus-tx/src/PlutusTx/Blueprint/Validator.hs | 8 +- 10 files changed, 249 insertions(+), 113 deletions(-) diff --git a/plutus-tx-plugin/test/Blueprint/Acme.golden.json b/plutus-tx-plugin/test/Blueprint/Acme.golden.json index 5ceb986e363..65eab6052a5 100644 --- a/plutus-tx-plugin/test/Blueprint/Acme.golden.json +++ b/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": [ diff --git a/plutus-tx-plugin/test/Blueprint/Tests.hs b/plutus-tx-plugin/test/Blueprint/Tests.hs index 0fcbb6e9dae..6d3c748bf1f 100644 --- a/plutus-tx-plugin/test/Blueprint/Tests.hs +++ b/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] } diff --git a/plutus-tx-plugin/test/Blueprint/Tests/Lib.hs b/plutus-tx-plugin/test/Blueprint/Tests/Lib.hs index 065a2b6221d..14af690e9a4 100644 --- a/plutus-tx-plugin/test/Blueprint/Tests/Lib.hs +++ b/plutus-tx-plugin/test/Blueprint/Tests/Lib.hs @@ -24,15 +24,17 @@ 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) @@ -40,19 +42,17 @@ 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) diff --git a/plutus-tx/src/PlutusTx/Blueprint/Argument.hs b/plutus-tx/src/PlutusTx/Blueprint/Argument.hs index 9d8d8bb8e18..0f2ccf35ca2 100644 --- a/plutus-tx/src/PlutusTx/Blueprint/Argument.hs +++ b/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{..} = diff --git a/plutus-tx/src/PlutusTx/Blueprint/Parameter.hs b/plutus-tx/src/PlutusTx/Blueprint/Parameter.hs index 85963eded69..b8377e180ed 100644 --- a/plutus-tx/src/PlutusTx/Blueprint/Parameter.hs +++ b/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{..} = diff --git a/plutus-tx/src/PlutusTx/Blueprint/Purpose.hs b/plutus-tx/src/PlutusTx/Blueprint/Purpose.hs index 74795c6e30c..d066370311a 100644 --- a/plutus-tx/src/PlutusTx/Blueprint/Purpose.hs +++ b/plutus-tx/src/PlutusTx/Blueprint/Purpose.hs @@ -9,13 +9,14 @@ import Prelude import Data.Aeson (ToJSON (..)) import Data.Aeson qualified as Json import Data.Text (Text) +import Language.Haskell.TH.Syntax (Lift) {- | As per CIP-57, a validator arguments (redeemer, datum) and validator parameters all must specify a purpose that indicates in which context they are used. -} data Purpose = Spend | Mint | Withdraw | Publish - deriving stock (Eq, Ord, Show) + deriving stock (Eq, Ord, Show, Lift) instance ToJSON Purpose where toJSON = Json.String . purposeToText diff --git a/plutus-tx/src/PlutusTx/Blueprint/Schema.hs b/plutus-tx/src/PlutusTx/Blueprint/Schema.hs index 571be5bfb77..5bf77fcd595 100644 --- a/plutus-tx/src/PlutusTx/Blueprint/Schema.hs +++ b/plutus-tx/src/PlutusTx/Blueprint/Schema.hs @@ -59,7 +59,7 @@ data Schema (referencedTypes :: [Type]) | SchemaAllOf (NonEmpty (Schema referencedTypes)) | SchemaNot (Schema referencedTypes) | SchemaDefinitionRef DefinitionId - deriving stock (Eq, Show, Generic, Data) + deriving stock (Eq, Ord, Show, Generic, Data) deriving anyclass instance (Typeable referencedTypes) => Plated (Schema referencedTypes) @@ -155,7 +155,7 @@ data IntegerSchema = MkIntegerSchema , exclusiveMaximum :: Maybe Integer -- ^ An instance is valid only if it is strictly less than "exclusiveMaximum". } - deriving stock (Eq, Show, Generic, Data) + deriving stock (Eq, Ord, Show, Generic, Data) emptyIntegerSchema :: IntegerSchema emptyIntegerSchema = @@ -176,7 +176,7 @@ data BytesSchema = MkBytesSchema , maxLength :: Maybe Natural -- ^ An instance is valid if its length is less than, or equal to, this value. } - deriving stock (Eq, Show, Generic, Data) + deriving stock (Eq, Ord, Show, Generic, Data) emptyBytesSchema :: BytesSchema emptyBytesSchema = MkBytesSchema{enum = [], minLength = Nothing, maxLength = Nothing} @@ -192,7 +192,7 @@ data ListSchema (referencedTypes :: [Type]) = MkListSchema -- ^ If this value is false, the instance validates successfully. -- If it is set to True, the instance validates successfully if all of its elements are unique. } - deriving stock (Eq, Show, Generic, Data) + deriving stock (Eq, Ord, Show, Generic, Data) mkListSchema :: Schema referencedTypes -> ListSchema referencedTypes mkListSchema schema = @@ -213,7 +213,7 @@ data MapSchema (referencedTypes :: [Type]) = MkMapSchema , maxItems :: Maybe Natural -- ^ A map instance is valid if its size is less than, or equal to, this value. } - deriving stock (Eq, Show, Generic, Data) + deriving stock (Eq, Ord, Show, Generic, Data) data ConstructorSchema (referencedTypes :: [Type]) = MkConstructorSchema { index :: Natural @@ -221,7 +221,7 @@ data ConstructorSchema (referencedTypes :: [Type]) = MkConstructorSchema , fieldSchemas :: [Schema referencedTypes] -- ^ Field schemas } - deriving stock (Eq, Show, Generic, Data) + deriving stock (Eq, Ord, Show, Generic, Data) data PairSchema (referencedTypes :: [Type]) = MkPairSchema { left :: Schema referencedTypes @@ -229,4 +229,4 @@ data PairSchema (referencedTypes :: [Type]) = MkPairSchema , right :: Schema referencedTypes -- ^ Schema of the second element } - deriving stock (Eq, Show, Generic, Data) + deriving stock (Eq, Ord, Show, Generic, Data) diff --git a/plutus-tx/src/PlutusTx/Blueprint/Schema/Annotation.hs b/plutus-tx/src/PlutusTx/Blueprint/Schema/Annotation.hs index 193069cfb72..29b78f4178b 100644 --- a/plutus-tx/src/PlutusTx/Blueprint/Schema/Annotation.hs +++ b/plutus-tx/src/PlutusTx/Blueprint/Schema/Annotation.hs @@ -27,7 +27,7 @@ data SchemaInfo = MkSchemaInfo , description :: Maybe String , comment :: Maybe String } - deriving stock (Eq, Show, Generic, Data, Lift) + deriving stock (Eq, Ord, Show, Generic, Data, Lift) emptySchemaInfo :: SchemaInfo emptySchemaInfo = MkSchemaInfo Nothing Nothing Nothing @@ -69,7 +69,7 @@ This annotation could be attached to a type or constructor: newtype MyFoo = MkMyFoo Int @ -} -newtype SchemaTitle = SchemaTitle String +newtype SchemaTitle = SchemaTitle {schemaTitleToString :: String} deriving newtype (Eq, Ord, Show, Typeable, ToJSON) deriving stock (Data, Lift) @@ -82,7 +82,7 @@ This annotation could be attached to a type or constructor: newtype MyFoo = MkMyFoo Int @ -} -newtype SchemaDescription = SchemaDescription String +newtype SchemaDescription = SchemaDescription {schemaDescriptionToString :: String} deriving newtype (Eq, Ord, Show, Typeable, ToJSON) deriving stock (Data, Lift) @@ -95,6 +95,6 @@ This annotation could be attached to a type or constructor: newtype MyFoo = MkMyFoo Int @ -} -newtype SchemaComment = SchemaComment String +newtype SchemaComment = SchemaComment {schemaCommentToString :: String} deriving newtype (Eq, Ord, Show, Typeable, ToJSON) deriving stock (Data, Lift) diff --git a/plutus-tx/src/PlutusTx/Blueprint/TH.hs b/plutus-tx/src/PlutusTx/Blueprint/TH.hs index ad39aff0f77..53bc9ee8adb 100644 --- a/plutus-tx/src/PlutusTx/Blueprint/TH.hs +++ b/plutus-tx/src/PlutusTx/Blueprint/TH.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyCase #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} @@ -14,16 +15,22 @@ import Prelude import Data.Data (Data) import Data.List (nub) import Data.List.NonEmpty qualified as NE +import Data.Set (Set) +import Data.Text qualified as Text import GHC.Natural (naturalToInteger) import Language.Haskell.TH qualified as TH import Language.Haskell.TH.Datatype qualified as TH import Numeric.Natural (Natural) -import PlutusPrelude (for, (<<$>>)) +import PlutusPrelude (for, (<&>), (<<$>>)) +import PlutusTx.Blueprint.Argument (ArgumentBlueprint (..)) import PlutusTx.Blueprint.Class (HasSchema (..)) import PlutusTx.Blueprint.Definition (HasSchemaDefinition) +import PlutusTx.Blueprint.Parameter (ParameterBlueprint (..)) +import PlutusTx.Blueprint.Purpose (Purpose) import PlutusTx.Blueprint.Schema (ConstructorSchema (..), Schema (..)) import PlutusTx.Blueprint.Schema.Annotation (SchemaAnn (..), SchemaComment, SchemaDescription, - SchemaInfo (..), SchemaTitle, annotationsToSchemaInfo) + SchemaInfo (..), SchemaTitle, annotationsToSchemaInfo, + schemaDescriptionToString, schemaTitleToString) import PlutusTx.IsData.TH (makeIsDataIndexed) {- | @@ -85,9 +92,6 @@ makeHasSchemaInstance dataTypeName indices = do description <- MkSchemaAnnDescription <<$>> lookupAnn @SchemaDescription name comment <- MkSchemaAnnComment <<$>> lookupAnn @SchemaComment name pure $ title ++ description ++ comment - where - lookupAnn :: (Data a) => TH.Name -> TH.Q [a] - lookupAnn = TH.reifyAnnotations . TH.AnnLookupName -- | Make SchemaInfo from a list of schema annotations, failing in case of ambiguity. schemaInfoFromAnns :: [SchemaAnn] -> TH.Q SchemaInfo @@ -117,3 +121,45 @@ mkSchemaClause ts ctorIndexes = mkSchemaConstructor (TH.ConstructorInfo{..}, info, naturalToInteger -> ctorIndex) = do fields <- for constructorFields $ \t -> [|definitionRef @($(pure t)) @($(pure ts))|] [|SchemaConstructor info (MkConstructorSchema ctorIndex $(pure (TH.ListE fields)))|] + +deriveParameterBlueprint :: TH.Name -> Set Purpose -> TH.ExpQ +deriveParameterBlueprint tyName purpose = do + title <- Text.pack . schemaTitleToString <<$>> lookupSchemaTitle tyName + description <- Text.pack . schemaDescriptionToString <<$>> lookupSchemaDescription tyName + [| MkParameterBlueprint + { parameterTitle = title + , parameterDescription = description + , parameterPurpose = purpose + , parameterSchema = definitionRef @($(TH.conT tyName)) + } + |] + +deriveArgumentBlueprint :: TH.Name -> Set Purpose -> TH.ExpQ +deriveArgumentBlueprint tyName purpose = do + title <- Text.pack . schemaTitleToString <<$>> lookupSchemaTitle tyName + description <- Text.pack . schemaDescriptionToString <<$>> lookupSchemaDescription tyName + [| MkArgumentBlueprint + { argumentTitle = title + , argumentDescription = description + , argumentPurpose = purpose + , argumentSchema = definitionRef @($(TH.conT tyName)) + } + |] + +---------------------------------------------------------------------------------------------------- +-- TH Utilities ------------------------------------------------------------------------------------ + +lookupAnn :: (Data a) => TH.Name -> TH.Q [a] +lookupAnn = TH.reifyAnnotations . TH.AnnLookupName + +lookupSchemaTitle :: TH.Name -> TH.Q (Maybe SchemaTitle) +lookupSchemaTitle tyName = lookupAnn @SchemaTitle tyName <&> \case + [x] -> Just x + [] -> Nothing + _ -> fail $ "Multiple SchemTitle annotations found for " <> show tyName + +lookupSchemaDescription :: TH.Name -> TH.Q (Maybe SchemaDescription) +lookupSchemaDescription tyName = lookupAnn @SchemaDescription tyName <&> \case + [x] -> Just x + [] -> Nothing + _ -> fail $ "Multiple SchemaDescription annotations found for " <> show tyName diff --git a/plutus-tx/src/PlutusTx/Blueprint/Validator.hs b/plutus-tx/src/PlutusTx/Blueprint/Validator.hs index 030d3d9ff80..bd18fbfa84b 100644 --- a/plutus-tx/src/PlutusTx/Blueprint/Validator.hs +++ b/plutus-tx/src/PlutusTx/Blueprint/Validator.hs @@ -22,9 +22,9 @@ import PlutusTx.Blueprint.Parameter (ParameterBlueprint) {- | A blueprint of a validator, as defined by the CIP-0057 - The 'referencedTypes' phantom type parameter is used to track the types used in the contract - making sure their schemas are included in the blueprint and that they are referenced - in a type-safe way. +The 'referencedTypes' phantom type parameter is used to track the types used in the contract +making sure their schemas are included in the blueprint and that they are referenced +in a type-safe way. -} data ValidatorBlueprint (referencedTypes :: [Type]) = MkValidatorBlueprint { validatorTitle :: Text @@ -40,7 +40,7 @@ data ValidatorBlueprint (referencedTypes :: [Type]) = MkValidatorBlueprint , validatorCompiledCode :: Maybe ByteString -- ^ A full compiled and CBOR-encoded serialized flat script. } - deriving stock (Show, Eq) + deriving stock (Show, Eq, Ord) instance ToJSON (ValidatorBlueprint referencedTypes) where toJSON MkValidatorBlueprint{..} =