Add deriving utils and separate CEMScriptTypes

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.
@@ -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 ''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