From c5460cad8ef937ed25baf809ef9586304c86c59f Mon Sep 17 00:00:00 2001 From: Gregory Gerasev Date: Fri, 31 May 2024 18:04:15 +0700 Subject: [PATCH 1/3] Add deriving utils and separate `CEMScriptTypes` --- cem-script.cabal | 1 + src/Cardano/CEM.hs | 38 +++++----- src/Cardano/CEM/Examples/Auction.hs | 22 ++---- src/Cardano/CEM/Examples/Compilation.hs | 20 +---- src/Cardano/CEM/Examples/Voting.hs | 16 ++-- src/Cardano/CEM/Monads/L1.hs | 1 - src/Cardano/CEM/TH.hs | 98 +++++++++++++++++++++++++ 7 files changed, 134 insertions(+), 62 deletions(-) create mode 100644 src/Cardano/CEM/TH.hs diff --git a/cem-script.cabal b/cem-script.cabal index db3b340..480d712 100644 --- a/cem-script.cabal +++ b/cem-script.cabal @@ -148,6 +148,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..b294a6b 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. @@ -110,6 +99,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..ffcac47 100644 --- a/src/Cardano/CEM/Examples/Compilation.hs +++ b/src/Cardano/CEM/Examples/Compilation.hs @@ -6,25 +6,11 @@ module Cardano.CEM.Examples.Compilation where -import PlutusTx qualified - -import Data.Proxy (Proxy (..)) - import PlutusLedgerApi.V2 (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)) +import Cardano.CEM.TH -instance CEMScriptCompiled SimpleVoting where - {-# INLINEABLE cemScriptCompiled #-} - cemScriptCompiled Proxy = - serialiseCompiledCode - $(PlutusTx.compileUntyped (genericCEMScript ''SimpleVoting ''SingleStage)) +$(compileCEM ''SimpleAuction) +$(compileCEM ''SimpleVoting) diff --git a/src/Cardano/CEM/Examples/Voting.hs b/src/Cardano/CEM/Examples/Voting.hs index 9fd5cf6..72e6ab0 100644 --- a/src/Cardano/CEM/Examples/Voting.hs +++ b/src/Cardano/CEM/Examples/Voting.hs @@ -13,11 +13,10 @@ 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 (deriveCEMAssociatedTypes) -- Voting @@ -88,21 +87,16 @@ data SimpleVotingTransition PlutusTx.unstableMakeIsData ''VoteValue PlutusTx.unstableMakeIsData ''JuryPolicy -PlutusTx.unstableMakeIsData ''SimpleVotingState -PlutusTx.unstableMakeIsData ''SimpleVotingParams -PlutusTx.unstableMakeIsData ''SimpleVotingTransition -deriveShow ''SimpleVoting - -deriveSpine ''SimpleVotingTransition -deriveSpine ''SimpleVotingState - -instance CEMScript SimpleVoting where +instance CEMScriptTypes SimpleVoting where type Stage SimpleVoting = SingleStage type Params SimpleVoting = SimpleVotingParams type State SimpleVoting = SimpleVotingState type Transition SimpleVoting = SimpleVotingTransition +$(deriveCEMAssociatedTypes False ''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 aa76951..8b64db8 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) + |] From 07b090171877e07f4fb03af109fc5542b6d4313a Mon Sep 17 00:00:00 2001 From: Gregory Gerasev Date: Fri, 31 May 2024 19:50:44 +0700 Subject: [PATCH 2/3] Defaulting `Stage` to `SingleStage` --- src/Cardano/CEM.hs | 2 ++ src/Cardano/CEM/Examples/Voting.hs | 1 - 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Cardano/CEM.hs b/src/Cardano/CEM.hs index b294a6b..7bcc618 100644 --- a/src/Cardano/CEM.hs +++ b/src/Cardano/CEM.hs @@ -92,6 +92,8 @@ class CEMScriptTypes script where -- | 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 diff --git a/src/Cardano/CEM/Examples/Voting.hs b/src/Cardano/CEM/Examples/Voting.hs index 72e6ab0..a155e6b 100644 --- a/src/Cardano/CEM/Examples/Voting.hs +++ b/src/Cardano/CEM/Examples/Voting.hs @@ -89,7 +89,6 @@ PlutusTx.unstableMakeIsData ''VoteValue PlutusTx.unstableMakeIsData ''JuryPolicy instance CEMScriptTypes SimpleVoting where - type Stage SimpleVoting = SingleStage type Params SimpleVoting = SimpleVotingParams type State SimpleVoting = SimpleVotingState type Transition SimpleVoting = SimpleVotingTransition From 56d95d32535282d7f76cf2bb0e0337f646705fb7 Mon Sep 17 00:00:00 2001 From: Gregory Gerasev Date: Tue, 11 Jun 2024 22:42:50 +0700 Subject: [PATCH 3/3] Fix GHC warnings --- src/Cardano/CEM/Monads/L1Commons.hs | 1 - src/Cardano/CEM/OffChain.hs | 2 -- test/Utils.hs | 1 - 3 files changed, 4 deletions(-) diff --git a/src/Cardano/CEM/Monads/L1Commons.hs b/src/Cardano/CEM/Monads/L1Commons.hs index ea7830a..baa520d 100644 --- a/src/Cardano/CEM/Monads/L1Commons.hs +++ b/src/Cardano/CEM/Monads/L1Commons.hs @@ -5,7 +5,6 @@ module Cardano.CEM.Monads.L1Commons where import Prelude -import Control.Monad.Except (ExceptT (..), runExceptT) import Data.List (nub) import Data.Map qualified as Map diff --git a/src/Cardano/CEM/OffChain.hs b/src/Cardano/CEM/OffChain.hs index 1580362..1b627ae 100644 --- a/src/Cardano/CEM/OffChain.hs +++ b/src/Cardano/CEM/OffChain.hs @@ -7,8 +7,6 @@ import Prelude -- Haskell imports import Control.Concurrent (threadDelay) -import Control.Monad.Except (ExceptT (..), MonadError (..), runExceptT) -import Control.Monad.Trans (MonadIO (..), MonadTrans (..)) import Data.Bifunctor (Bifunctor (..)) import Data.Data (Proxy (..)) import Data.List (find) diff --git a/test/Utils.hs b/test/Utils.hs index 95bfce3..3491218 100644 --- a/test/Utils.hs +++ b/test/Utils.hs @@ -2,7 +2,6 @@ module Utils where import Prelude -import Control.Monad.Trans (MonadIO (..)) import Data.Map (keys) import PlutusLedgerApi.V1.Interval (always)