CIP-0057: Extend the Blueprint test case with the AsData example. (#…

…5837)

* refactor: s/schema/itemSchema/

* Blueprint example extended with the AsData type.

* refactor: extract Unroll functionality into a dedicated module

* chore: refactor asDataFor, remove long lines, etc.

plutus-tx-plugin/plutus-tx-plugin.cabal

@@ -130,6 +130,8 @@ test-suite plutus-tx-plugin-tests
     AsData.Budget.Types
     Blueprint.Tests
     Blueprint.Tests.Lib
+    Blueprint.Tests.Lib.AsData.Blueprint
+    Blueprint.Tests.Lib.AsData.Decls
     Budget.Spec
     Budget.WithGHCOptimisations
     Budget.WithoutGHCOptimisations

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

@@ -58,7 +58,7 @@
       "datum": {
         "purpose": "mint",
         "schema": {
-          "$ref": "#/definitions/Integer"
+          "$ref": "#/definitions/Datum2"
         }
       },
       "parameters": [
@@ -115,6 +115,18 @@
         }
       ]
     },
+    "Datum2": {
+      "dataType": "constructor",
+      "fields": [
+        {
+          "$ref": "#/definitions/Integer"
+        },
+        {
+          "$ref": "#/definitions/Bool"
+        }
+      ],
+      "index": 0
+    },
     "DatumPayload": {
       "$comment": "MkDatumPayload",
       "dataType": "constructor",

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

@@ -2,13 +2,15 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE TypeApplications  #-}
+{-# LANGUAGE TypeOperators     #-}
 
 module Blueprint.Tests where
 
 import Prelude
 
-import Blueprint.Tests.Lib (Datum, Datum2, Param2a, Param2b, Params, Redeemer, Redeemer2,
-                            goldenJson, serialisedScript, validatorScript1, validatorScript2)
+import Blueprint.Tests.Lib (Datum, Param2a, Param2b, Params, Redeemer, Redeemer2, goldenJson,
+                            serialisedScript, validatorScript1, validatorScript2)
+import Blueprint.Tests.Lib.AsData.Blueprint (Datum2)
 import Data.Set qualified as Set
 import PlutusTx.Blueprint.Contract (ContractBlueprint (..))
 import PlutusTx.Blueprint.Definition (definitionRef, deriveDefinitions)
@@ -69,5 +71,13 @@ contractBlueprint =
               }
           ]
     , contractDefinitions =
-        deriveDefinitions @[Params, Redeemer, Datum, Param2a, Param2b, Redeemer2, Datum2]
+        deriveDefinitions
+          @[ Params
+           , Param2a
+           , Param2b
+           , Redeemer
+           , Redeemer2
+           , Datum
+           , Datum2
+           ]
     }

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

@@ -6,15 +6,20 @@
 {-# LANGUAGE FlexibleInstances     #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE PatternSynonyms       #-}
 {-# LANGUAGE PolyKinds             #-}
 {-# LANGUAGE RankNTypes            #-}
 {-# LANGUAGE TemplateHaskell       #-}
 {-# LANGUAGE TypeApplications      #-}
 {-# LANGUAGE UndecidableInstances  #-}
 {-# LANGUAGE ViewPatterns          #-}
 
-module Blueprint.Tests.Lib where
+module Blueprint.Tests.Lib
+  ( module Blueprint.Tests.Lib
+  , module AsData
+  ) where
 
+import Blueprint.Tests.Lib.AsData.Decls as AsData (datum2)
 import Codec.Serialise (serialise)
 import Control.Lens (over, (&))
 import Control.Monad.Reader (asks)
@@ -24,6 +29,7 @@ import Data.Kind (Type)
 import Data.Void (Void)
 import Flat qualified
 import GHC.Generics (Generic)
+import PlutusTx.AsData (asData)
 import PlutusTx.Blueprint.Class (HasSchema (..))
 import PlutusTx.Blueprint.Definition (AsDefinitionId, definitionRef)
 import PlutusTx.Blueprint.Schema (Schema (..), emptyBytesSchema)
@@ -33,7 +39,7 @@ 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.Lift (liftCodeDef, makeLift)
 import PlutusTx.TH qualified as PlutusTx
 import Prelude
 import System.FilePath ((</>))
@@ -57,7 +63,7 @@ data Params = MkParams
   deriving stock (Generic)
   deriving anyclass (AsDefinitionId)
 
-$(PlutusTx.makeLift ''Params)
+$(makeLift ''Params)
 $(makeIsDataSchemaIndexed ''Params [('MkParams, 0)])
 
 newtype Bytes (phantom :: Type) = MkAcmeBytes BuiltinByteString
@@ -109,7 +115,7 @@ typedValidator1 _params _datum _redeemer _context = False
 validatorScript1 :: PlutusTx.CompiledCode (Datum -> Redeemer -> ScriptContext -> Bool)
 validatorScript1 =
   $$(PlutusTx.compile [||typedValidator1||])
-    `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef
+    `PlutusTx.unsafeApplyCode` liftCodeDef
       MkParams
         { myUnit = ()
         , myBool = True
@@ -125,17 +131,17 @@ newtype Param2a = MkParam2a Bool
   deriving stock (Generic)
   deriving anyclass (AsDefinitionId)
 
-$(PlutusTx.makeLift ''Param2a)
+$(makeLift ''Param2a)
 $(makeIsDataSchemaIndexed ''Param2a [('MkParam2a, 0)])
 
 newtype Param2b = MkParam2b Bool
   deriving stock (Generic)
   deriving anyclass (AsDefinitionId)
 
-$(PlutusTx.makeLift ''Param2b)
+$(makeLift ''Param2b)
 $(makeIsDataSchemaIndexed ''Param2b [('MkParam2b, 0)])
 
-type Datum2 = Integer
+$(asData datum2)
 
 type Redeemer2 = Integer
 
@@ -146,8 +152,8 @@ 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)
+    `PlutusTx.unsafeApplyCode` liftCodeDef (MkParam2a False)
+    `PlutusTx.unsafeApplyCode` liftCodeDef (MkParam2b True)
 
 ----------------------------------------------------------------------------------------------------
 -- Helper functions --------------------------------------------------------------------------------

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

@@ -0,0 +1,26 @@
+{-# LANGUAGE DeriveAnyClass        #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE TypeApplications      #-}
+{-# LANGUAGE UndecidableInstances  #-}
+
+{- | This module contains data type declarations to use in blueprints **only**
+
+The problem with using the 'AsData' types in blueprints is that such types are opaque and
+do not reveal their schema when deriving a 'HasSchema' instance for a blueprint.
+
+To work around this problem we generate a separate data type declaration for each 'AsData' type
+and use these in blueprints.
+
+Do not use these types in real validators, instead use the 'AsData' declarations.
+-}
+module Blueprint.Tests.Lib.AsData.Blueprint where
+
+import Blueprint.Tests.Lib.AsData.Decls (datum2)
+import PlutusTx.Blueprint.Definition (definitionRef)
+import PlutusTx.Blueprint.TH (makeHasSchemaInstance)
+
+$(datum2)
+
+$(pure <$> makeHasSchemaInstance ''Datum2 [('MkDatum2, 0)])

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

@@ -0,0 +1,23 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
+
+{- | This module contains TH data type declarations from which 'AsData' declarations are derived.
+
+These declarations are used for two purposes:
+1. To generate an 'AsData' type declaration to be used in real validators.
+2. To generate a regular data type declaration to be used in a blueprint.
+
+Because of the GHC stage restriction, we have to keep these TH declarations in a separate module.
+-}
+module Blueprint.Tests.Lib.AsData.Decls where
+
+import GHC.Generics (Generic)
+import Language.Haskell.TH qualified as TH
+import PlutusTx.Blueprint.Definition.Id (AsDefinitionId)
+
+datum2 :: TH.DecsQ
+datum2 =
+  [d|
+    data Datum2 = MkDatum2 {datum2integer :: Integer, datum2bool :: Bool}
+      deriving stock (Generic)
+      deriving anyclass (AsDefinitionId)
+    |]

plutus-tx/plutus-tx.cabal

@@ -57,6 +57,8 @@ library
     PlutusTx.Blueprint.Contract
     PlutusTx.Blueprint.Definition
     PlutusTx.Blueprint.Definition.Id
+    PlutusTx.Blueprint.Definition.Internal
+    PlutusTx.Blueprint.Definition.Unroll
     PlutusTx.Blueprint.Parameter
     PlutusTx.Blueprint.PlutusVersion
     PlutusTx.Blueprint.Preamble

plutus-tx/src/PlutusTx/AsData.hs

@@ -1,24 +1,23 @@
--- editorconfig-checker-disable-file
 {-# LANGUAGE BangPatterns       #-}
 {-# LANGUAGE CPP                #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE PatternSynonyms    #-}
 {-# LANGUAGE TemplateHaskell    #-}
 {-# LANGUAGE TypeApplications   #-}
 {-# LANGUAGE ViewPatterns       #-}
+
 module PlutusTx.AsData (asData, asDataFor) where
 
 import Control.Lens (ifor)
 import Control.Monad (unless)
-import Data.Foldable
-import Data.Traversable
+import Data.Traversable (for)
 
 import Language.Haskell.TH qualified as TH
 import Language.Haskell.TH.Datatype qualified as TH
 import Language.Haskell.TH.Datatype.TyVarBndr qualified as TH
 
-import PlutusTx.Builtins as Builtins
-import PlutusTx.IsData.Class
+import PlutusTx.Builtins qualified as Builtins
+import PlutusTx.IsData.Class (ToData, UnsafeFromData)
 import PlutusTx.IsData.TH (mkConstrCreateExpr, mkUnsafeConstrMatchPattern)
 
 import Prelude
@@ -41,26 +40,28 @@ declaration. Note that you may therefore need to do strange things like use
 
 Example:
 @
-    $(asData
-      [d|
-        data Example a = Ex1 Integer | Ex2 a a
-          deriving newtype (Eq)
-      |]
+  $(asData [d|
+      data Example a = Ex1 Integer | Ex2 a a
+        deriving newtype (Eq)
+    |])
 @
 becomes
 @
-    newtype Example a = Example BuiltinData
-      deriving newtype (Eq)
+  newtype Example a = Example BuiltinData
+    deriving newtype (Eq)
 
-    pattern Ex1 :: (ToData a, UnsafeFromData a) => Integer -> Example a
-    pattern Ex1 i <- Example (unsafeDataAsConstr -> ((==) 0 -> True, [unsafeFromBuiltinData -> i]))
-      where Ex1 i = Example (mkConstr 0 [toBuiltinData i])
+  pattern Ex1 :: (ToData a, UnsafeFromData a) => Integer -> Example a
+  pattern Ex1 i <- Example (unsafeDataAsConstr -> ((==) 0 -> True, [unsafeFromBuiltinData -> i]))
+    where Ex1 i = Example (mkConstr 0 [toBuiltinData i])
 
-    pattern Ex2 :: (ToData a, UnsafeFromData a) => a -> a -> Example a
-    pattern Ex2 a1 a2 <- Example (unsafeDataAsConstr -> ((==) 1 -> True, [unsafeFromBuiltinData -> a1, unsafeFromBuiltinData -> a2]))
-      where Ex2 a1 a2 = Example (mkConstr 1 [toBuiltinData a1, toBuiltinData a2])
+  pattern Ex2 :: (ToData a, UnsafeFromData a) => a -> a -> Example a
+  pattern Ex2 a1 a2 <- Example (unsafeDataAsConstr -> ((==) 1 -> True,
+    [ unsafeFromBuiltinData -> a1
+    , unsafeFromBuiltinData -> a2
+    ]))
+    where Ex2 a1 a2 = Example (mkConstr 1 [toBuiltinData a1, toBuiltinData a2])
 
-    {-# COMPLETE Ex1, Ex2 #-}
+  {-# COMPLETE Ex1, Ex2 #-}
 @
 -}
 asData :: TH.Q [TH.Dec] -> TH.Q [TH.Dec]
@@ -76,15 +77,27 @@ asDataFor dec = do
         TH.DataD _ _ _ _ _ deriv -> deriv
         _                        -> []
 
-  di@(TH.DatatypeInfo{TH.datatypeVariant=dVariant, TH.datatypeCons=cons, TH.datatypeName=name, TH.datatypeVars=tTypeVars}) <- TH.normalizeDec dec
+  di@(
+    TH.DatatypeInfo
+      { TH.datatypeVariant = dVariant
+      , TH.datatypeCons    = cons
+      , TH.datatypeName    = name
+      , TH.datatypeVars    = tTypeVars
+      }
+    ) <- TH.normalizeDec dec
 
   -- Other stuff is data families and so on
-  unless (dVariant == TH.Datatype) $ fail $ "asData: can't handle datatype variant " ++ show dVariant
+  unless (dVariant == TH.Datatype) $
+    fail $ "asData: can't handle datatype variant " ++ show dVariant
   -- a fresh name for the new datatype, but same lexically as the old one
   cname <- TH.newName (show name)
   -- The newtype declaration
   let ntD =
-        let con = TH.NormalC cname [(TH.Bang TH.NoSourceUnpackedness TH.NoSourceStrictness, TH.ConT ''BuiltinData)]
+        let con = TH.NormalC cname
+              [ ( TH.Bang TH.NoSourceUnpackedness TH.NoSourceStrictness
+                , TH.ConT ''Builtins.BuiltinData
+                )
+              ]
         in TH.NewtypeD [] name
 #if MIN_VERSION_template_haskell(2,21,0)
             (TH.changeTVFlags TH.BndrReq tTypeVars)
@@ -94,36 +107,35 @@ asDataFor dec = do
             Nothing con derivs
 
   -- The pattern synonyms, one for each constructor
-  pats <- ifor cons $ \conIx (TH.ConstructorInfo{TH.constructorName=conName, TH.constructorFields=fields, TH.constructorVariant=cVariant}) -> do
+  pats <- ifor cons $
+    \conIx TH.ConstructorInfo
+      { TH.constructorName = conName
+      , TH.constructorFields = fields
+      , TH.constructorVariant = cVariant
+      } -> do
     -- If we have a record constructor, we need to reuse the names for the
     -- matching part of the pattern synonym
     fieldNames <- case cVariant of
       TH.RecordConstructor names -> pure names
       -- otherwise whatever
       _                          -> ifor fields $ \fieldIx _ -> TH.newName $ "arg" ++ show fieldIx
-    let extractFieldNames = fieldNames
     createFieldNames <- for fieldNames (TH.newName . show)
     patSynArgs <- case cVariant of
-      TH.NormalConstructor   -> pure $ TH.prefixPatSyn extractFieldNames
-      TH.RecordConstructor _ -> pure $ TH.recordPatSyn extractFieldNames
-      TH.InfixConstructor    -> case extractFieldNames of
+      TH.NormalConstructor   -> pure $ TH.prefixPatSyn fieldNames
+      TH.RecordConstructor _ -> pure $ TH.recordPatSyn fieldNames
+      TH.InfixConstructor    -> case fieldNames of
         [f1,f2] -> pure $ TH.infixPatSyn f1 f2
         _       -> fail "asData: infix data constructor with other than two fields"
     let
+      pat = TH.conP cname [mkUnsafeConstrMatchPattern (fromIntegral conIx) fieldNames]
 
-      pat = TH.conP cname [mkUnsafeConstrMatchPattern (fromIntegral conIx) extractFieldNames]
-
-      createExpr = [| $(TH.conE cname) $(mkConstrCreateExpr (fromIntegral conIx) createFieldNames) |]
+      createExpr = [|$(TH.conE cname) $(mkConstrCreateExpr (fromIntegral conIx) createFieldNames) |]
       clause = TH.clause (fmap TH.varP createFieldNames) (TH.normalB createExpr) []
       patSynD = TH.patSynD conName patSynArgs (TH.explBidir [clause]) pat
-
-    let
       dataConstraints t = [TH.ConT ''ToData `TH.AppT` t, TH.ConT ''UnsafeFromData `TH.AppT` t]
-      ctxFor vars = concatMap (dataConstraints . TH.VarT . TH.tvName) vars
-      -- Try and be a little clever and only add constraints on the variables
-      -- used in the arguments
+      -- Try and be a little clever and only add constraints on the variables used in the arguments
       varsInArgs = TH.freeVariablesWellScoped fields
-      ctxForArgs = ctxFor varsInArgs
+      ctxForArgs = concatMap (dataConstraints . TH.VarT . TH.tvName) varsInArgs
       conTy = foldr (\ty acc -> TH.ArrowT `TH.AppT` ty `TH.AppT` acc) (TH.datatypeType di) fields
       allFreeVars = TH.freeVariablesWellScoped [conTy]
       fullTy = TH.ForallT (TH.changeTVFlags TH.SpecifiedSpec allFreeVars) ctxForArgs conTy