diff --git a/cem-script.cabal b/cem-script.cabal index 27864f6..aea46f5 100644 --- a/cem-script.cabal +++ b/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: diff --git a/src/Cardano/CEM.hs b/src/Cardano/CEM.hs index adcc858..7bcc618 100644 --- a/src/Cardano/CEM.hs +++ b/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,6 +92,8 @@ 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 @@ -110,6 +101,19 @@ class -- | 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 :: diff --git a/src/Cardano/CEM/Examples/Auction.hs b/src/Cardano/CEM/Examples/Auction.hs index 53eb001..3e69e04 100644 --- a/src/Cardano/CEM/Examples/Auction.hs +++ b/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)) diff --git a/src/Cardano/CEM/Examples/Compilation.hs b/src/Cardano/CEM/Examples/Compilation.hs index 8fe02c2..7c0f471 100644 --- a/src/Cardano/CEM/Examples/Compilation.hs +++ b/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 + } diff --git a/src/Cardano/CEM/Examples/Voting.hs b/src/Cardano/CEM/Examples/Voting.hs index 9fd5cf6..058cb81 100644 --- a/src/Cardano/CEM/Examples/Voting.hs +++ b/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,22 +9,24 @@ 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 @@ -32,9 +34,9 @@ instance Eq VoteValue where 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)) diff --git a/src/Cardano/CEM/Monads/L1.hs b/src/Cardano/CEM/Monads/L1.hs index f24aa6b..a42076a 100644 --- a/src/Cardano/CEM/Monads/L1.hs +++ b/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 diff --git a/src/Cardano/CEM/TH.hs b/src/Cardano/CEM/TH.hs new file mode 100644 index 0000000..efe23f1 --- /dev/null +++ b/src/Cardano/CEM/TH.hs @@ -0,0 +1,98 @@ +module Cardano.CEM.TH ( + deriveCEMAssociatedTypes, + compileCEM, + unstableMakeIsDataSchema, + deriveStageAssociatedTypes, + defaultIndex, + unstableMakeHasSchemaInstance, +) where + +import Prelude + +import Data.Data (Proxy (..)) +import GHC.Num.Natural (Natural) +import Language.Haskell.TH +import Language.Haskell.TH.Syntax (sequenceQ) + +import PlutusTx qualified +import PlutusTx.Blueprint.TH + +import Language.Haskell.TH.Datatype ( + ConstructorInfo (..), + DatatypeInfo (..), + reifyDatatype, + ) + +import Cardano.CEM (CEMScriptTypes (..)) +import Cardano.CEM.OnChain (CEMScriptCompiled (..), genericCEMScript) +import Cardano.CEM.Stages (Stages (..)) +import Data.Spine (deriveSpine) +import PlutusTx.Show (deriveShow) + +defaultIndex :: Name -> Q [(Name, Natural)] +defaultIndex name = do + info <- reifyDatatype name + pure $ zip (constructorName <$> datatypeCons info) [0 ..] + +unstableMakeIsDataSchema :: Name -> Q [InstanceDec] +unstableMakeIsDataSchema name = do + index <- defaultIndex name + PlutusTx.makeIsDataSchemaIndexed name index + +unstableMakeHasSchemaInstance :: Name -> Q [InstanceDec] +unstableMakeHasSchemaInstance name = do + index <- defaultIndex name + dec <- makeHasSchemaInstance name index + return [dec] + +-- | Get `TypeFamily Datatype` result as TH Name +resolveFamily :: Name -> Name -> Q Name +resolveFamily familyName argName = do + argType <- conT argName + [TySynInstD (TySynEqn _ _ (ConT name))] <- + reifyInstances familyName [argType] + return name + +deriveStageAssociatedTypes :: Name -> Q [Dec] +deriveStageAssociatedTypes stageName = do + stageParamsName <- resolveFamily ''StageParams stageName + declss <- + sequenceQ + [ PlutusTx.unstableMakeIsData stageName + , PlutusTx.unstableMakeIsData stageParamsName + ] + return $ concat declss + +deriveCEMAssociatedTypes :: Bool -> Name -> Q [Dec] +deriveCEMAssociatedTypes deriveBlueprint scriptName = do + declss <- + sequenceQ + [ -- Data + deriveFamily isDataDeriver ''Params + , deriveFamily isDataDeriver ''State + , deriveFamily isDataDeriver ''Transition + , -- Spines + deriveFamily deriveSpine ''State + , deriveFamily deriveSpine ''Transition + , -- Other + deriveShow scriptName + ] + return $ concat declss + where + isDataDeriver = + if deriveBlueprint + then unstableMakeIsDataSchema + else PlutusTx.unstableMakeIsData + deriveFamily deriver family = do + name <- resolveFamily family scriptName + deriver name + +compileCEM :: Name -> Q [Dec] +compileCEM name = do + stageName <- resolveFamily ''Stage name + let compiled = PlutusTx.compileUntyped $ genericCEMScript name stageName + [d| + instance CEMScriptCompiled $(conT name) where + {-# INLINEABLE cemScriptCompiled #-} + cemScriptCompiled Proxy = serialiseCompiledCode $(compiled) + |] diff --git a/test/Voting.hs b/test/Voting.hs index 2c3b84b..37c227b 100644 --- a/test/Voting.hs +++ b/test/Voting.hs @@ -4,10 +4,12 @@ import Prelude hiding (readFile) import Control.Monad.IO.Class (MonadIO (..)) +import PlutusTx.Blueprint + import Test.Hspec (describe, it, shouldBe) import Cardano.CEM -import Cardano.CEM.Examples.Compilation () +import Cardano.CEM.Examples.Compilation (votingBlueprint) import Cardano.CEM.Examples.Voting import Cardano.CEM.Monads (MonadTest (..)) import Cardano.CEM.OffChain @@ -19,6 +21,8 @@ import Utils votingSpec = describe "Voting" $ do let ignoreTest (_name :: String) = const (return ()) + it "Compile blueprint" $ + writeBlueprint "/tmp/blueprint.json" votingBlueprint -- FIXME: fix Voting budget ignoreTest "Successfull flow" $ execClb $ do