CIP-0057 Annotations for the PlutusTx.Blueprint.Schema

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

@@ -67,13 +67,17 @@
     "Datum": {
       "oneOf": [
         {
-          "$comment": "DatumLeft",
+          "title": "Datum",
+          "description": "DatumLeft",
+          "$comment": "This constructor is parameterless",
           "dataType": "constructor",
           "fields": [],
           "index": 0
         },
         {
-          "$comment": "DatumRight",
+          "title": "Datum",
+          "description": "DatumRight",
+          "$comment": "This constructor has a payload",
           "dataType": "constructor",
           "fields": [
             {
@@ -101,7 +105,6 @@
       "dataType": "integer"
     },
     "Params": {
-      "$comment": "MkParams",
       "dataType": "constructor",
       "fields": [
         {

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

@@ -27,7 +27,9 @@ 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.Blueprint.Schema (Schema (SchemaBytes), emptyBytesSchema)
+import PlutusTx.Blueprint.Schema.Annotation (SchemaComment (..), SchemaDescription (..),
+                                             SchemaInfo (..), SchemaTitle (..), emptySchemaInfo)
 import PlutusTx.Builtins (BuiltinByteString, BuiltinString, emptyByteString)
 import PlutusTx.Prelude qualified as PlutusTx
 import UntypedPlutusCore qualified as UPLC
@@ -49,27 +51,33 @@ newtype Bytes (phantom :: Type) = MkAcmeBytes BuiltinByteString
   deriving anyclass (AsDefinitionId)
 
 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
   }
   deriving anyclass (AsDefinitionId)
 
-$(makeIsDataSchemaIndexed ''DatumPayload [('MkDatumPayload, 0)])
-
+{-# 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 anyclass (AsDefinitionId)
 
-$(makeIsDataSchemaIndexed ''Datum [('DatumLeft, 0), ('DatumRight, 1)])
-
 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 =
   PlutusTx.getPlcNoAnn validatorScript

plutus-tx/plutus-tx.cabal

@@ -62,6 +62,7 @@ library
     PlutusTx.Blueprint.Preamble
     PlutusTx.Blueprint.Purpose
     PlutusTx.Blueprint.Schema
+    PlutusTx.Blueprint.Schema.Annotation
     PlutusTx.Blueprint.TH
     PlutusTx.Blueprint.Validator
     PlutusTx.Blueprint.Write

plutus-tx/src/PlutusTx/Blueprint.hs

@@ -9,5 +9,6 @@ import PlutusTx.Blueprint.PlutusVersion as X
 import PlutusTx.Blueprint.Preamble as X
 import PlutusTx.Blueprint.Purpose as X
 import PlutusTx.Blueprint.Schema as X
+import PlutusTx.Blueprint.Schema.Annotation as X
 import PlutusTx.Blueprint.Validator as X
 import PlutusTx.Blueprint.Write as X

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

@@ -12,7 +12,8 @@ import Prelude hiding (maximum, minimum)
 
 import Data.Kind (Type)
 import PlutusTx.Blueprint.Schema (PairSchema (..), Schema (..), emptyBytesSchema,
-                                  emptyIntegerSchema, emptySchemaInfo)
+                                  emptyIntegerSchema)
+import PlutusTx.Blueprint.Schema.Annotation (emptySchemaInfo)
 import PlutusTx.Builtins (BuiltinByteString, BuiltinData, BuiltinString)
 
 {- |

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

@@ -8,7 +8,6 @@ module PlutusTx.Blueprint.Contract where
 
 import Prelude
 
-import Control.Applicative (Alternative (empty))
 import Data.Aeson (ToJSON (..), (.=))
 import Data.Aeson qualified as Aeson
 import Data.Aeson.Extra (optionalField, requiredField)
@@ -18,6 +17,7 @@ import Data.Map (Map)
 import Data.Map qualified as Map
 import Data.Set (Set)
 import Data.Text (Text)
+import PlutusPrelude (ensure)
 import PlutusTx.Blueprint.Definition (DefinitionId)
 import PlutusTx.Blueprint.Preamble (Preamble)
 import PlutusTx.Blueprint.Schema (Schema)
@@ -43,24 +43,21 @@ data ContractBlueprint (referencedTypes :: [Type]) = MkContractBlueprint
 
 instance ToJSON (ContractBlueprint referencedTypes) where
   toJSON MkContractBlueprint{..} =
-    Aeson.buildObject $
-      requiredField "$schema" schemaUrl
-        . requiredField
-          "$vocabulary"
-          ( Aeson.object
-              [ "https://json-schema.org/draft/2020-12/vocab/core" .= True
-              , "https://json-schema.org/draft/2020-12/vocab/applicator" .= True
-              , "https://json-schema.org/draft/2020-12/vocab/validation" .= True
-              , "https://cips.cardano.org/cips/cip57" .= True
-              ]
-          )
-        . requiredField "preamble" contractPreamble
-        . requiredField "validators" contractValidators
-        . optionalField "$id" contractId
-        . optionalField "definitions" (guarded (not . Map.null) contractDefinitions)
+    Aeson.buildObject
+      $ requiredField "$schema" schemaUrl
+      . requiredField
+        "$vocabulary"
+        ( Aeson.object
+            [ "https://json-schema.org/draft/2020-12/vocab/core" .= True
+            , "https://json-schema.org/draft/2020-12/vocab/applicator" .= True
+            , "https://json-schema.org/draft/2020-12/vocab/validation" .= True
+            , "https://cips.cardano.org/cips/cip57" .= True
+            ]
+        )
+      . requiredField "preamble" contractPreamble
+      . requiredField "validators" contractValidators
+      . optionalField "$id" contractId
+      . optionalField "definitions" (ensure (not . Map.null) contractDefinitions)
    where
     schemaUrl :: String
     schemaUrl = "https://cips.cardano.org/cips/cip57/schemas/plutus-blueprint.json"
-
-    guarded :: (Alternative f) => (a -> Bool) -> a -> f a
-    guarded p a = if p a then pure a else empty

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

@@ -30,6 +30,7 @@ import Data.Text.Encoding qualified as Text
 import GHC.Generics (Generic)
 import Numeric.Natural (Natural)
 import PlutusTx.Blueprint.Definition.Id (DefinitionId, definitionIdToText)
+import PlutusTx.Blueprint.Schema.Annotation (SchemaInfo, comment, description, title)
 import Prelude hiding (max, maximum, min, minimum)
 
 {- | Blueprint schema definition, as defined by the CIP-0057:
@@ -136,22 +137,11 @@ instance ToJSON (Schema referencedTypes) where
     dataType info ty = requiredField "dataType" ty (infoFields info)
 
     infoFields :: SchemaInfo -> Aeson.Object
-    infoFields MkSchemaInfo{title, description, comment} =
+    infoFields info =
       KeyMap.empty
-        & optionalField "title" title
-        & optionalField "description" description
-        & optionalField "$comment" comment
-
--- | Additional information optionally attached to any datatype schema definition.
-data SchemaInfo = MkSchemaInfo
-  { title       :: Maybe String
-  , description :: Maybe String
-  , comment     :: Maybe String
-  }
-  deriving stock (Eq, Show, Generic, Data)
-
-emptySchemaInfo :: SchemaInfo
-emptySchemaInfo = MkSchemaInfo{title = Nothing, description = Nothing, comment = Nothing}
+        & optionalField "title" (title info)
+        & optionalField "description" (description info)
+        & optionalField "$comment" (comment info)
 
 data IntegerSchema = MkIntegerSchema
   { multipleOf       :: Maybe Integer

plutus-tx/src/PlutusTx/Blueprint/Schema/Annotation.hs

@@ -0,0 +1,100 @@
+{-# LANGUAGE BlockArguments     #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE LambdaCase         #-}
+{-# LANGUAGE NoStrict           #-}
+
+module PlutusTx.Blueprint.Schema.Annotation (
+  SchemaInfo (..),
+  emptySchemaInfo,
+  annotationsToSchemaInfo,
+  SchemaAnn (..),
+  SchemaTitle (..),
+  SchemaDescription (..),
+  SchemaComment (..),
+) where
+
+import Control.Monad.State (execStateT, get, lift, put)
+import Data.Aeson (ToJSON (..))
+import Data.Data (Data, Typeable)
+import GHC.Generics (Generic)
+import Language.Haskell.TH.Syntax (Lift)
+import Prelude hiding (max, maximum, min, minimum)
+
+-- | Additional information optionally attached to any datatype schema definition.
+data SchemaInfo = MkSchemaInfo
+  { title       :: Maybe String
+  , description :: Maybe String
+  , comment     :: Maybe String
+  }
+  deriving stock (Eq, Show, Generic, Data, Lift)
+
+emptySchemaInfo :: SchemaInfo
+emptySchemaInfo = MkSchemaInfo Nothing Nothing Nothing
+
+type SchemaInfoError = String
+
+annotationsToSchemaInfo :: [SchemaAnn] -> Either SchemaInfoError SchemaInfo
+annotationsToSchemaInfo =
+  (`execStateT` emptySchemaInfo) . traverse \case
+    MkSchemaAnnTitle (SchemaTitle t) ->
+      get >>= \info -> case title info of
+        Nothing -> put $ info{title = Just t}
+        Just t' -> failOverride "SchemaTitle" t' t
+    MkSchemaAnnDescription (SchemaDescription d) ->
+      get >>= \info -> case description info of
+        Nothing -> put $ info{description = Just d}
+        Just d' -> failOverride "SchemaDescription" d' d
+    MkSchemaAnnComment (SchemaComment c) ->
+      get >>= \info -> case comment info of
+        Nothing -> put $ info{comment = Just c}
+        Just c' -> failOverride "SchemaComment" c' c
+ where
+  failOverride label old new =
+    lift . Left $ concat [label, " annotation error: ", show old, " is overridden with ", show new]
+
+-- | Annotation that can be attached to a schema definition.
+data SchemaAnn
+  = MkSchemaAnnTitle SchemaTitle
+  | MkSchemaAnnDescription SchemaDescription
+  | MkSchemaAnnComment SchemaComment
+  deriving stock (Eq, Ord, Show, Generic, Typeable, Data, Lift)
+
+{- | An annotation for the "title" schema attribute.
+
+This annotation could be attached to a type or constructor:
+@
+{\-# ANN type MyFoo (SchemaTitle "My Foo Title") #-\}
+{\-# ANN MkMyFoo (SchemaTitle "Title") #-\}
+newtype MyFoo = MkMyFoo Int
+@
+-}
+newtype SchemaTitle = SchemaTitle String
+  deriving newtype (Eq, Ord, Show, Typeable, ToJSON)
+  deriving stock (Data, Lift)
+
+{- | An annotation for the "description" schema attribute.
+
+This annotation could be attached to a type or constructor:
+@
+{\-# ANN type MyFoo (SchemaDescription "My Foo Description") #-\}
+{\-# ANN MkMyFoo (SchemaDescription "Description") #-\}
+newtype MyFoo = MkMyFoo Int
+@
+-}
+newtype SchemaDescription = SchemaDescription String
+  deriving newtype (Eq, Ord, Show, Typeable, ToJSON)
+  deriving stock (Data, Lift)
+
+{- | An annotation for the "$comment" schema attribute.
+
+This annotation could be attached to a type or constructor:
+@
+{\-# ANN type MyFoo (SchemaComment "My Foo Comment") #-\}
+{\-# ANN MkMyFoo (SchemaComment "Comment") #-\}
+newtype MyFoo = MkMyFoo Int
+@
+-}
+newtype SchemaComment = SchemaComment String
+  deriving newtype (Eq, Ord, Show, Typeable, ToJSON)
+  deriving stock (Data, Lift)

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

@@ -11,15 +11,19 @@ module PlutusTx.Blueprint.TH where
 
 import Prelude
 
+import Data.Data (Data)
 import Data.List (nub)
 import Data.List.NonEmpty qualified as NE
-import Data.Traversable (for)
-import GHC.Natural (Natural, naturalToInteger)
+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 PlutusTx.Blueprint.Class (HasSchema (..))
 import PlutusTx.Blueprint.Definition (HasSchemaDefinition)
-import PlutusTx.Blueprint.Schema (ConstructorSchema (..), Schema (..), SchemaInfo (..))
+import PlutusTx.Blueprint.Schema (ConstructorSchema (..), Schema (..))
+import PlutusTx.Blueprint.Schema.Annotation (SchemaAnn (..), SchemaComment, SchemaDescription,
+                                             SchemaInfo (..), SchemaTitle, annotationsToSchemaInfo)
 import PlutusTx.IsData.TH (makeIsDataIndexed)
 
 {- |
@@ -40,10 +44,15 @@ makeHasSchemaInstance dataTypeName indices = do
   let nonOverlapInstance = TH.InstanceD Nothing
 
   -- Lookup indices for all constructors of a data type.
-  indexedCons <- for (TH.datatypeCons dataTypeInfo) $ \ctorInfo ->
-    case lookup (TH.constructorName ctorInfo) indices of
-      Just index -> pure (ctorInfo, index)
-      Nothing    -> fail $ "No index given for constructor " ++ show (TH.constructorName ctorInfo)
+  indexedCons :: [(TH.ConstructorInfo, SchemaInfo, Natural)] <- do
+    for (TH.datatypeCons dataTypeInfo) $ \ctorInfo -> do
+      let ctorName = TH.constructorName ctorInfo
+      case lookup ctorName indices of
+        Nothing -> fail $ "No index given for constructor " ++ show (TH.constructorName ctorInfo)
+        Just index -> do
+          ctorSchemaAnns <- lookupSchemaAnns ctorName
+          schemaInfo <- schemaInfoFromAnns ctorSchemaAnns
+          pure (ctorInfo, schemaInfo, index)
 
   let tsType = TH.VarT (TH.mkName "referencedTypes")
 
@@ -52,7 +61,7 @@ makeHasSchemaInstance dataTypeName indices = do
         nub
           -- Every type in the constructor fields must have a schema definition.
           [ TH.classPred ''HasSchemaDefinition [fieldType, tsType]
-          | (TH.ConstructorInfo{constructorFields}, _index) <- indexedCons
+          | (TH.ConstructorInfo{constructorFields}, _info, _index) <- indexedCons
           , fieldType <- constructorFields
           ]
   -- Generate a 'schema' function for the instance with one clause.
@@ -68,9 +77,30 @@ makeHasSchemaInstance dataTypeName indices = do
       constraints
       (TH.classPred ''HasSchema [appliedType, tsType])
       [schemaPrag, schemaDecl]
+ where
+  -- Lookup all annotations (SchemaTitle, SchemdDescription, SchemaComment) attached to a name.
+  lookupSchemaAnns :: TH.Name -> TH.Q [SchemaAnn]
+  lookupSchemaAnns name = do
+    title <- MkSchemaAnnTitle <<$>> lookupAnn @SchemaTitle name
+    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
+  schemaInfoFromAnns = either fail pure . annotationsToSchemaInfo
 
 -- | Make a clause for the 'schema' function.
-mkSchemaClause :: TH.Type -> [(TH.ConstructorInfo, Natural)] -> TH.ClauseQ
+mkSchemaClause ::
+  -- | The type for the 'HasSchema' instance.
+  TH.Type ->
+  -- | The constructors of the type with their schema infos and indices.
+  [(TH.ConstructorInfo, SchemaInfo, Natural)] ->
+  -- | The clause for the 'schema' function.
+  TH.ClauseQ
 mkSchemaClause ts ctorIndexes =
   case ctorIndexes of
     [] -> fail "At least one constructor index must be specified."
@@ -83,12 +113,7 @@ mkSchemaClause ts ctorIndexes =
     let whereDecls = []
     TH.clause patterns (TH.normalB body) whereDecls
 
-  mkSchemaConstructor :: (TH.ConstructorInfo, Natural) -> TH.ExpQ
-  mkSchemaConstructor (TH.ConstructorInfo{..}, naturalToInteger -> ctorIndex) = do
+  mkSchemaConstructor :: (TH.ConstructorInfo, SchemaInfo, Natural) -> TH.ExpQ
+  mkSchemaConstructor (TH.ConstructorInfo{..}, info, naturalToInteger -> ctorIndex) = do
     fields <- for constructorFields $ \t -> [|definitionRef @($(pure t)) @($(pure ts))|]
-    let name = TH.nameBase constructorName
-    [|
-      SchemaConstructor
-        (MkSchemaInfo Nothing Nothing (Just name))
-        (MkConstructorSchema ctorIndex $(pure (TH.ListE fields)))
-      |]
+    [|SchemaConstructor info (MkConstructorSchema ctorIndex $(pure (TH.ListE fields)))|]