Add deriving utils and separate CEMScriptTypes

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:

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 ::

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,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)

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))

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
 

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)
+    |]