Support for Plutus Blueprint

cem-script.cabal

@@ -171,6 +171,7 @@ library
     Cardano.CEM.OnChain
     Cardano.CEM.Stages
     Cardano.CEM.Testing.StateMachine
+    Cardano.CEM.TH
 
   other-modules:   Cardano.CEM.Monads.L1Commons
   build-depends:

src/Cardano/CEM.hs

@@ -13,10 +13,7 @@ import Data.Map qualified as Map
 -- Plutus imports
 import PlutusLedgerApi.V1.Address (Address, pubKeyHashAddress)
 import PlutusLedgerApi.V1.Crypto (PubKeyHash)
-import PlutusLedgerApi.V2 (
-  ToData (..),
-  Value,
- )
+import PlutusLedgerApi.V2 (ToData (..), Value)
 import PlutusTx.Show.TH (deriveShow)
 
 -- Project imports
@@ -81,20 +78,12 @@ type DefaultConstraints datatype =
   , Prelude.Show datatype
   )
 
-class
-  ( HasSpine (Transition script)
-  , HasSpine (State script)
-  , Stages (Stage script)
-  , DefaultConstraints (Stage script)
-  , DefaultConstraints (Transition script)
-  , DefaultConstraints (State script)
-  , DefaultConstraints (Params script)
-  , DefaultConstraints (StageParams (Stage script))
-  ) =>
-  CEMScript script
-  where
-  -- | `Params` is immutable part of script Datum,
-  -- | it should be used to encode all
+{- | All associated types for `CEMScript`
+They are separated to simplify TH deriving
+-}
+class CEMScriptTypes script where
+  -- \| `Params` is immutable part of script Datum,
+  -- \| it should be used to encode all
   type Params script = params | params -> script
 
   -- | `Stage` is datatype encoding all `Interval`s specified by script.
@@ -103,13 +92,28 @@ class
   -- | which is stored immutable in script Datum as well.
   type Stage script
 
+  type Stage script = SingleStage
+
   -- | `State` is changing part of script Datum.
   -- | It is in
   type State script = params | params -> script
 
   -- | Transitions for deterministic CEM-machine
   type Transition script = transition | transition -> script
 
+class
+  ( HasSpine (Transition script)
+  , HasSpine (State script)
+  , Stages (Stage script)
+  , DefaultConstraints (Stage script)
+  , DefaultConstraints (Transition script)
+  , DefaultConstraints (State script)
+  , DefaultConstraints (Params script)
+  , DefaultConstraints (StageParams (Stage script))
+  , CEMScriptTypes script
+  ) =>
+  CEMScript script
+  where
   -- | Each kind of Transition has statically associated Stage
   -- from/to `State`s spines
   transitionStage ::

src/Cardano/CEM/Examples/Auction.hs

@@ -14,11 +14,10 @@ import PlutusLedgerApi.V1.Time (POSIXTime)
 import PlutusLedgerApi.V1.Value (CurrencySymbol (..), TokenName (..), singleton)
 import PlutusLedgerApi.V2 (Value)
 import PlutusTx qualified
-import PlutusTx.Show.TH (deriveShow)
 
 import Cardano.CEM
-import Cardano.CEM.Stages
-import Data.Spine
+import Cardano.CEM.Stages (Stages (..))
+import Cardano.CEM.TH (deriveCEMAssociatedTypes, deriveStageAssociatedTypes)
 
 -- Simple no-deposit auction
 
@@ -66,24 +65,17 @@ data SimpleAuctionTransition
   deriving stock (Prelude.Eq, Prelude.Show)
 
 PlutusTx.unstableMakeIsData ''Bid
-PlutusTx.unstableMakeIsData 'MkAuctionParams
-PlutusTx.unstableMakeIsData 'NotStarted
-PlutusTx.unstableMakeIsData 'MakeBid
-PlutusTx.unstableMakeIsData ''SimpleAuctionStage
-PlutusTx.unstableMakeIsData ''SimpleAuctionStageParams
-deriveShow ''SimpleAuction
 
-deriveSpine ''SimpleAuctionTransition
-deriveSpine ''SimpleAuctionState
-
-instance CEMScript SimpleAuction where
+instance CEMScriptTypes SimpleAuction where
   type Stage SimpleAuction = SimpleAuctionStage
   type Params SimpleAuction = SimpleAuctionParams
-
   type State SimpleAuction = SimpleAuctionState
-
   type Transition SimpleAuction = SimpleAuctionTransition
 
+$(deriveStageAssociatedTypes ''SimpleAuctionStage)
+$(deriveCEMAssociatedTypes False ''SimpleAuction)
+
+instance CEMScript SimpleAuction where
   transitionStage Proxy =
     Map.fromList
       [ (CreateSpine, (Open, Nothing, Just NotStartedSpine))

src/Cardano/CEM/Examples/Compilation.hs

@@ -6,25 +6,63 @@
 
 module Cardano.CEM.Examples.Compilation where
 
-import PlutusTx qualified
+import Prelude
 
-import Data.Proxy (Proxy (..))
+import Data.Set qualified as Set
 
-import PlutusLedgerApi.V2 (serialiseCompiledCode)
+import PlutusLedgerApi.V2 (BuiltinByteString, CurrencySymbol (CurrencySymbol), PubKeyHash, serialiseCompiledCode)
 
 import Cardano.CEM.Examples.Auction
 import Cardano.CEM.Examples.Voting
-import Cardano.CEM.OnChain (CEMScriptCompiled (..), genericCEMScript)
-import Cardano.CEM.Stages (SingleStage)
-
-instance CEMScriptCompiled SimpleAuction where
-  {-# INLINEABLE cemScriptCompiled #-}
-  cemScriptCompiled Proxy =
-    serialiseCompiledCode
-      $(PlutusTx.compileUntyped (genericCEMScript ''SimpleAuction ''SimpleAuctionStage))
-
-instance CEMScriptCompiled SimpleVoting where
-  {-# INLINEABLE cemScriptCompiled #-}
-  cemScriptCompiled Proxy =
-    serialiseCompiledCode
-      $(PlutusTx.compileUntyped (genericCEMScript ''SimpleVoting ''SingleStage))
+import Cardano.CEM.TH
+import PlutusTx.Blueprint
+
+$(compileCEM ''SimpleAuction)
+$(compileCEM ''SimpleVoting)
+
+-- definitions :: Definitions (Unroll Value)
+-- definitions = error "TODO"
+-- deriveDefinitions @'[[CurrencySymbol]]
+
+type RefTypes = '[BuiltinByteString, PubKeyHash]
+
+votingBlueprint :: ContractBlueprint
+votingBlueprint =
+  MkContractBlueprint
+    { contractId = Just "voting"
+    , contractPreamble = votingPreamble
+    , contractValidators = Set.fromList [votingValidator]
+    , -- cemScriptCompiled $ Proxy @SimpleVoting
+      contractDefinitions = deriveDefinitions @'[SimpleVotingTransition]
+    }
+  where
+    votingPreamble =
+      MkPreamble
+        { preambleTitle = "Voting DApp"
+        , preambleDescription = Nothing
+        , preambleVersion = "0.1"
+        , preamblePlutusVersion = PlutusV2
+        , preambleLicense = Nothing
+        }
+    votingValidator =
+      MkValidatorBlueprint
+        { validatorTitle = "My Validator"
+        , validatorDescription = Nothing
+        , validatorParameters = []
+        , validatorRedeemer =
+            MkArgumentBlueprint
+              { argumentTitle = Nothing
+              , argumentDescription = Nothing
+              , argumentPurpose = Set.singleton Spend
+              , argumentSchema = definitionRef @SimpleVotingTransition
+              }
+        , validatorDatum =
+            Just
+              MkArgumentBlueprint
+                { argumentTitle = Nothing
+                , argumentDescription = Nothing
+                , argumentPurpose = Set.singleton Spend
+                , argumentSchema = definitionRef @SimpleVotingState
+                }
+        , validatorCompiledCode = Nothing
+        }

src/Cardano/CEM/Examples/Voting.hs

@@ -1,6 +1,6 @@
-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
-
 {-# HLINT ignore "Use when" #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 
 module Cardano.CEM.Examples.Voting where
 
@@ -9,32 +9,34 @@ import Prelude qualified
 
 import Data.Map qualified as Map
 
-import PlutusLedgerApi.V1.Crypto (PubKeyHash)
+import PlutusLedgerApi.V1.Crypto (PubKeyHash (..))
 import PlutusLedgerApi.V2 (Value)
-import PlutusTx qualified
 import PlutusTx.AssocMap qualified as PMap
-import PlutusTx.Show.TH (deriveShow)
 
 import Cardano.CEM
 import Cardano.CEM.Stages
-import Data.Spine (deriveSpine)
+import Cardano.CEM.TH
+import Data.Typeable (Typeable)
+import GHC.Generics (Generic)
+import PlutusLedgerApi.V1.Value (CurrencySymbol, TokenName)
+import PlutusTx.Blueprint
 
 -- Voting
 
 data SimpleVoting
 
 data VoteValue = Yes | No | Abstain
-  deriving stock (Prelude.Show, Prelude.Eq)
+  deriving stock (Prelude.Show, Prelude.Eq, Generic)
 
 instance Eq VoteValue where
   Yes == Yes = True
   No == No = True
   Abstain == Abstain = True
   _ == _ = False
 
--- | Policy determinig who can vote
+-- | Policy determining who can vote
 data JuryPolicy = Anyone | FixedJuryList [PubKeyHash] | WithToken Value
-  deriving stock (Prelude.Show, Prelude.Eq)
+  deriving stock (Prelude.Show, Prelude.Eq, Generic)
 
 -- Votes storage
 
@@ -71,38 +73,97 @@ data SimpleVotingParams = MkVotingParams
   , abstainAllowed :: Bool
   , drawDecision :: VoteValue
   }
-  deriving stock (Prelude.Show, Prelude.Eq)
+  deriving stock (Prelude.Show, Prelude.Eq, Generic)
 
 data SimpleVotingState
   = NotStarted
   | InProgress VoteStorage
   | Finalized VoteValue
-  deriving stock (Prelude.Show, Prelude.Eq)
+  deriving stock (Prelude.Show, Prelude.Eq, Generic)
 
 data SimpleVotingTransition
   = Create
   | Start
   | Vote PubKeyHash VoteValue
   | Finalize
-  deriving stock (Prelude.Show, Prelude.Eq)
+  deriving stock (Prelude.Show, Prelude.Eq, Generic)
 
-PlutusTx.unstableMakeIsData ''VoteValue
-PlutusTx.unstableMakeIsData ''JuryPolicy
-PlutusTx.unstableMakeIsData ''SimpleVotingState
-PlutusTx.unstableMakeIsData ''SimpleVotingParams
-PlutusTx.unstableMakeIsData ''SimpleVotingTransition
+-- Orphans
 
-deriveShow ''SimpleVoting
+unstableMakeHasSchemaInstance ''PubKeyHash
 
-deriveSpine ''SimpleVotingTransition
-deriveSpine ''SimpleVotingState
+deriving anyclass instance (AsDefinitionId PubKeyHash)
+deriving anyclass instance (AsDefinitionId [PubKeyHash])
 
-instance CEMScript SimpleVoting where
-  type Stage SimpleVoting = SingleStage
+unstableMakeHasSchemaInstance ''CurrencySymbol
+unstableMakeHasSchemaInstance ''TokenName
+deriving anyclass instance (AsDefinitionId CurrencySymbol)
+deriving anyclass instance (AsDefinitionId TokenName)
+
+-- deriving anyclass instance (AsDefinitionId [CurrencySymbol])
+
+deriving anyclass instance (Typeable k, Typeable v) => AsDefinitionId [(k, v)]
+deriving anyclass instance (Typeable k, Typeable v) => AsDefinitionId (PMap.Map k v)
+
+instance
+  ( Typeable k
+  , Typeable v
+  , HasSchemaDefinition [(k, v)] referencedTypes
+  ) =>
+  HasSchema (PMap.Map k v) referencedTypes
+  where
+  {-# INLINEABLE schema #-}
+  schema =
+    SchemaConstructor
+      (MkSchemaInfo Nothing Nothing Nothing)
+      ( MkConstructorSchema
+          0
+          [definitionRef @[(k, v)] @referencedTypes]
+      )
+
+{-
+instance
+  ( Typeable k
+  , Typeable v
+  , AsDefinitionId k
+  , AsDefinitionId v
+  , HasSchemaDefinition k referencedTypes
+  , HasSchemaDefinition v referencedTypes
+  ) =>
+  HasSchema (PMap.Map k v) referencedTypes
+  where
+  {-# INLINEABLE schema #-}
+  schema =
+    SchemaConstructor
+      (MkSchemaInfo Nothing Nothing Nothing)
+      ( MkConstructorSchema
+          0
+          [definitionRef @k @referencedTypes,
+          definitionRef @v @referencedTypes]
+      )
+-}
+
+unstableMakeHasSchemaInstance ''Value
+deriving anyclass instance (AsDefinitionId Value)
+
+--
+
+unstableMakeIsDataSchema ''VoteValue
+deriving anyclass instance (AsDefinitionId VoteValue)
+
+unstableMakeIsDataSchema ''JuryPolicy
+deriving anyclass instance (AsDefinitionId JuryPolicy)
+deriving anyclass instance (AsDefinitionId SimpleVotingParams)
+deriving anyclass instance (AsDefinitionId SimpleVotingState)
+
+instance CEMScriptTypes SimpleVoting where
   type Params SimpleVoting = SimpleVotingParams
   type State SimpleVoting = SimpleVotingState
   type Transition SimpleVoting = SimpleVotingTransition
 
+$(deriveCEMAssociatedTypes True ''SimpleVoting)
+
+instance CEMScript SimpleVoting where
   transitionStage _ =
     Map.fromList
       [ (CreateSpine, (Always, Nothing, Just NotStartedSpine))

src/Cardano/CEM/Monads/L1.hs

@@ -5,7 +5,6 @@ module Cardano.CEM.Monads.L1 where
 import Prelude
 
 import Control.Monad.Reader (MonadReader (..), ReaderT (..))
-import Control.Monad.Trans (MonadIO (..))
 import Data.ByteString qualified as BS
 import Data.Set qualified as Set