Blueprint example extended with the AsData type.

IntersectMBO · Mar 18, 2024 · 31262d3 · 31262d3
1 parent d5d3853
commit 31262d3
Show file tree

Hide file tree

Showing 4 changed files with 124 additions and 29 deletions.
diff --git a/plutus-tx-plugin/test/Blueprint/Acme.golden.json b/plutus-tx-plugin/test/Blueprint/Acme.golden.json
@@ -58,7 +58,7 @@
       "datum": {
         "purpose": "mint",
         "schema": {
-          "$ref": "#/definitions/Integer"
+          "$ref": "#/definitions/Data"
         }
       },
       "parameters": [

diff --git a/plutus-tx-plugin/test/Blueprint/Tests.hs b/plutus-tx-plugin/test/Blueprint/Tests.hs
@@ -2,22 +2,27 @@
 {-# 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 (Bytes, Datum, Datum2, DatumPayload, Param2a, Param2b, Params, Redeemer,
+                            Redeemer2, goldenJson, serialisedScript, validatorScript1,
+                            validatorScript2)
 import Data.Set qualified as Set
+import Data.Typeable ((:~:) (Refl))
+import Data.Void (Void)
 import PlutusTx.Blueprint.Contract (ContractBlueprint (..))
-import PlutusTx.Blueprint.Definition (definitionRef, deriveDefinitions)
+import PlutusTx.Blueprint.Definition (UnrollAll, definitionRef, deriveDefinitions)
 import PlutusTx.Blueprint.PlutusVersion (PlutusVersion (PlutusV3))
 import PlutusTx.Blueprint.Preamble (Preamble (..))
 import PlutusTx.Blueprint.Purpose qualified as Purpose
 import PlutusTx.Blueprint.TH (deriveArgumentBlueprint, deriveParameterBlueprint)
 import PlutusTx.Blueprint.Validator (ValidatorBlueprint (..))
 import PlutusTx.Blueprint.Write (writeBlueprint)
+import PlutusTx.Builtins
 import Test.Tasty.Extras (TestNested, testNested)
 
 goldenTests :: TestNested
@@ -69,5 +74,44 @@ contractBlueprint =
               }
           ]
     , contractDefinitions =
-        deriveDefinitions @[Params, Redeemer, Datum, Param2a, Param2b, Redeemer2, Datum2]
+        deriveDefinitions
+          @[ Params
+           , Param2a
+           , Param2b
+           , Redeemer
+           , Redeemer2
+           , Datum
+           , Datum2
+           , -- 'Bool' and 'Integer' have to be mentioned explicitly
+             -- because `Datum2` as an "AsData-type" unrolls to the 'BuiltinData' only.
+             Bool
+           , Integer
+           ]
     }
+
+unrollAll ::
+  UnrollAll [Params, Param2a, Param2b, Datum, Datum2, Redeemer, Redeemer2]
+    :~: [ Params
+        , BuiltinByteString
+        , BuiltinData
+        , Integer
+        , ()
+        , Bool
+        , Param2a
+        , Bool
+        , Param2b
+        , Bool
+        , Datum
+        , DatumPayload
+        , Bytes Void
+        , BuiltinByteString
+        , Integer
+        , Datum2
+        , BuiltinData
+        , BuiltinString
+        , Integer
+        ]
+unrollAll = Refl
+
+unrollAll' :: UnrollAll '[Datum2] :~: '[Datum2, BuiltinData]
+unrollAll' = Refl
diff --git a/plutus-tx-plugin/test/Blueprint/Tests/Lib.hs b/plutus-tx-plugin/test/Blueprint/Tests/Lib.hs
@@ -6,6 +6,7 @@
 {-# LANGUAGE FlexibleInstances     #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE PatternSynonyms       #-}
 {-# LANGUAGE PolyKinds             #-}
 {-# LANGUAGE RankNTypes            #-}
 {-# LANGUAGE TemplateHaskell       #-}
@@ -24,9 +25,10 @@ import Data.Kind (Type)
 import Data.Void (Void)
 import Flat qualified
 import GHC.Generics (Generic)
+import PlutusTx.AsData qualified as PlutusTx
 import PlutusTx.Blueprint.Class (HasSchema (..))
-import PlutusTx.Blueprint.Definition (AsDefinitionId, definitionRef)
-import PlutusTx.Blueprint.Schema (Schema (..), emptyBytesSchema)
+import PlutusTx.Blueprint.Definition (AsDefinitionId, HasSchemaDefinition, definitionRef)
+import PlutusTx.Blueprint.Schema (ConstructorSchema (..), Schema (..), emptyBytesSchema)
 import PlutusTx.Blueprint.Schema.Annotation (SchemaComment (..), SchemaDescription (..),
                                              SchemaInfo (..), SchemaTitle (..), emptySchemaInfo)
 import PlutusTx.Blueprint.TH (makeIsDataSchemaIndexed)
@@ -135,7 +137,36 @@ newtype Param2b = MkParam2b Bool
 $(PlutusTx.makeLift ''Param2b)
 $(makeIsDataSchemaIndexed ''Param2b [('MkParam2b, 0)])
 
-type Datum2 = Integer
+$( PlutusTx.asData
+    [d|
+      data Datum2 = MkDatum2
+        { datum2integer :: Integer
+        , datum2bool :: Bool
+        }
+        deriving stock (Generic)
+        deriving newtype (AsDefinitionId)
+      |]
+ )
+
+-- The TH splice above generates a 'Datum2' newtype wrapper around the 'BuiltinData'.
+-- Generically derived 'HasSchema Datum2' instance isn't useful as it describes such type
+-- as an opaque 'BuiltinData', so we provide a custom instance to show its structure.
+instance
+  ( HasSchemaDefinition Integer ts
+  , HasSchemaDefinition Bool ts
+  ) =>
+  HasSchema Datum2 ts
+  where
+  schema =
+    SchemaConstructor
+      emptySchemaInfo{comment = Just "Implemented using AsData"}
+      MkConstructorSchema
+        { index = 0
+        , fieldSchemas =
+            [ definitionRef @Integer @ts
+            , definitionRef @Bool @ts
+            ]
+        }
 
 type Redeemer2 = Integer
 

diff --git a/plutus-tx/test/Blueprint/Spec.hs b/plutus-tx/test/Blueprint/Spec.hs
@@ -3,41 +3,26 @@
 {-# LANGUAGE DerivingStrategies    #-}
 {-# LANGUAGE FlexibleInstances     #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PatternSynonyms       #-}
+{-# LANGUAGE TemplateHaskell       #-}
 {-# LANGUAGE TypeApplications      #-}
 {-# LANGUAGE TypeOperators         #-}
+{-# LANGUAGE ViewPatterns          #-}
 
 module Blueprint.Spec where
 
 import Prelude
 
 import Data.Typeable ((:~:) (Refl))
 import GHC.Generics (Generic)
+import PlutusTx.AsData qualified as PlutusTx
 import PlutusTx.Blueprint.Class (HasSchema (..))
 import PlutusTx.Blueprint.Definition (AsDefinitionId, Definitions, Unroll, UnrollAll,
                                       Unrollable (..))
 import PlutusTx.Blueprint.Schema (Schema (..))
 import PlutusTx.Blueprint.Schema.Annotation (emptySchemaInfo)
-
-testUnrollNop :: Unroll Nop :~: '[Nop]
-testUnrollNop = Refl
-
-testUnrollBaz :: Unroll Baz :~: [Baz, Integer]
-testUnrollBaz = Refl
-
-testUnrollZap :: Unroll Zap :~: [Zap, Nop, Integer, Bool]
-testUnrollZap = Refl
-
-testUnrollBar :: Unroll Bar :~: [Bar, Zap, Nop, Integer, Bool, Baz]
-testUnrollBar = Refl
-
-testUnrollFoo :: Unroll Foo :~: [Foo, Bar, Zap, Nop, Integer, Bool, Baz]
-testUnrollFoo = Refl
-
-testUnrollAll :: UnrollAll [Nop, Baz] :~: [Nop, Baz, Integer]
-testUnrollAll = Refl
-
-definitions :: Definitions [Foo, Bar, Zap, Nop, Integer, Bool, Baz]
-definitions = unroll @(UnrollAll '[Foo])
+import PlutusTx.Builtins (BuiltinData)
+import PlutusTx.IsData ()
 
 ----------------------------------------------------------------------------------------------------
 -- Test fixture ------------------------------------------------------------------------------------
@@ -71,3 +56,38 @@ deriving stock instance (Generic Nop)
 deriving anyclass instance (AsDefinitionId Nop)
 instance HasSchema Nop ts where
   schema = SchemaBuiltInUnit emptySchemaInfo
+
+$( PlutusTx.asData
+    [d|
+      data Dat = MkDat {datInteger :: Integer, datBool :: Bool}
+        deriving stock (Generic)
+        deriving newtype (AsDefinitionId)
+      |]
+ )
+
+----------------------------------------------------------------------------------------------------
+-- Tests -------------------------------------------------------------------------------------------
+
+testUnrollNop :: Unroll Nop :~: '[Nop]
+testUnrollNop = Refl
+
+testUnrollBaz :: Unroll Baz :~: [Baz, Integer]
+testUnrollBaz = Refl
+
+testUnrollZap :: Unroll Zap :~: [Zap, Nop, Integer, Bool]
+testUnrollZap = Refl
+
+testUnrollBar :: Unroll Bar :~: [Bar, Zap, Nop, Integer, Bool, Baz]
+testUnrollBar = Refl
+
+testUnrollFoo :: Unroll Foo :~: [Foo, Bar, Zap, Nop, Integer, Bool, Baz]
+testUnrollFoo = Refl
+
+testUnrollAll :: UnrollAll [Nop, Baz] :~: [Nop, Baz, Integer]
+testUnrollAll = Refl
+
+definitions :: Definitions [Foo, Bar, Zap, Nop, Integer, Bool, Baz]
+definitions = unroll @(UnrollAll '[Foo])
+
+testUnrollDat :: Unroll Dat :~: '[Dat, BuiltinData]
+testUnrollDat = Refl