feat: backport transitionStage

Author: euonymos

.gitignore

@@ -27,4 +27,4 @@ haddocks
 # Functions changed by runing local testnet
 devnet/db
 devnet/genesis-*.json
-test.log
+test.log

Makefile

@@ -10,4 +10,4 @@ run-oura-daemon:
 	@oura daemon --config ./test/daemon.toml
 
 format:
-	fourmolu --mode inplace $$(git ls-files '*.hs')
+	fourmolu --mode inplace $$(git ls-files '*.hs')

src/Cardano/CEM.hs

@@ -512,6 +512,18 @@ class
 
   compilationConfig :: CompilationConfig
 
+  -- \| This is the map of all possible machine 'Transition's.
+  --          This statically associates every 'Transition' with
+  --          a 'Stage' through source/target 'State's.
+  transitionStage ::
+    Proxy script ->
+    Map.Map
+      (Spine (Transition script))
+      ( Maybe (Spine (State script)) -- source 'State'
+      , Maybe (Spine (State script)) -- target 'State'
+      )
+  transitionStage _ = Map.empty
+
 -- FIXME: No need to use type synonym anymore (was needed due to Plutus)
 type CEMScriptDatum script = (Params script, State script)
 

src/Cardano/CEM/Examples/Auction.hs

@@ -63,6 +63,15 @@ $(deriveCEMAssociatedTypes False ''SimpleAuction)
 instance CEMScript SimpleAuction where
   compilationConfig = MkCompilationConfig "AUC"
 
+  transitionStage _ =
+    Map.fromList
+      [ (CreateSpine, (Nothing, Just NotStartedSpine))
+      , (StartSpine, (Just NotStartedSpine, Just CurrentBidSpine))
+      , (MakeBidSpine, (Just CurrentBidSpine, Just CurrentBidSpine))
+      , (CloseSpine, (Just CurrentBidSpine, Just WinnerSpine))
+      , (BuyoutSpine, (Just WinnerSpine, Nothing))
+      ]
+
   perTransitionScriptSpec =
     Map.fromList
       [

src/Cardano/CEM/Indexing/Event.hs

@@ -6,7 +6,7 @@ module Cardano.CEM.Indexing.Event where
 import Cardano.Api qualified as C
 import Cardano.Api.ScriptData qualified as C
 import Cardano.Api.SerialiseRaw qualified as SerialiseRaw
-import Cardano.CEM (CEMScript, CEMScriptDatum, State, Transition)
+import Cardano.CEM (CEMScript (transitionStage), CEMScriptDatum, State, Transition)
 import Cardano.CEM.Address qualified as Address
 import Cardano.CEM.Indexing.Tx
 import Cardano.CEM.OnChain (CEMScriptCompiled)
@@ -93,11 +93,11 @@ extractEvent network tx = do
 
   -- Look up the transition
   let transitions =
-        first
-          (\(_, b, c) -> (b, c))
-          . swap
-          -- <$> Map.toList (transitionStage $ Proxy @script)
-          <$> Map.toList (undefined $ Proxy @script) -- TODO: backport transitionStage
+        -- first
+        -- (\(_, b, c) -> (b, c))
+        -- .
+        swap
+          <$> Map.toList (transitionStage $ Proxy @script)
   let transSpine = lookup (mSourceSpine, mTargetSpine) transitions
 
   -- Return

test/Auction.hs

@@ -2,8 +2,6 @@
 
 module Auction where
 
-import Prelude
-
 import Cardano.Api.NetworkId (toShelleyNetwork)
 import Cardano.CEM.Examples.Auction
 import Cardano.CEM.Examples.Compilation ()
@@ -16,20 +14,20 @@ import Cardano.Extras
 import Control.Monad.Trans (MonadIO (..))
 import Data.Proxy (Proxy (..))
 import GHC.IsList
-
 import Plutarch.Script
 import PlutusLedgerApi.V1.Value (assetClassValue)
-
 import Test.Hspec (describe, it, shouldBe)
 import TestNFT (testNftAssetClass)
-import Text.Show.Pretty (ppShow)
 import Utils (
   execClb,
   mintTestTokens,
   perTransitionStats,
   submitAndCheck,
   submitCheckReturn,
  )
+import Prelude
+
+-- import Text.Show.Pretty (ppShow)
 
 auctionSpec = describe "AuctionSpec" $ do
   it "Serialise" $ do
@@ -76,7 +74,8 @@ auctionSpec = describe "AuctionSpec" $ do
               ]
           , specSigner = bidder1
           }
-    Left (PerTransitionErrors _) <- return result
+
+    Left CEMScriptTxInResolutionError <- return result
 
     return ()
 
@@ -258,14 +257,6 @@ auctionSpec = describe "AuctionSpec" $ do
 
     mEvent <- liftIO $ extractEvent @SimpleAuction network $ resolvedTxToOura preBody utxo
     liftIO $ mEvent `shouldBe` Just (Following BuyoutSpine)
-    submitAndCheck $
-      MkTxSpec
-        { actions =
-            [ MkSomeCEMAction $
-                MkCEMAction auctionParams Buyout
-            ]
-        , specSigner = bidder1
-        }
 
-    stats <- perTransitionStats
-    liftIO $ putStrLn $ ppShow stats
+-- stats <- perTransitionStats
+-- liftIO $ putStrLn $ ppShow stats

test/Voting.hs

@@ -1,28 +1,21 @@
 module Voting (votingSpec) where
 
-import Prelude hiding (readFile)
-
-import Control.Monad.IO.Class (MonadIO (..))
-import Data.Proxy
-
-import GHC.IsList
-import Text.Show.Pretty (ppShow)
-
-import Plutarch.Script
-
-import Test.Hspec (describe, it, shouldBe)
-
 import Cardano.CEM.Examples.Compilation ()
 import Cardano.CEM.Examples.Voting
 import Cardano.CEM.Monads
 import Cardano.CEM.OffChain
 import Cardano.CEM.OnChain
 import Cardano.Extras (signingKeyToPKH)
 import Control.Monad.IO.Class (MonadIO (..))
-import Test.Hspec (describe, shouldBe)
+import Data.Proxy
+import GHC.IsList
+import Plutarch.Script
+import Test.Hspec (describe, it, shouldBe)
 import Utils
 import Prelude hiding (readFile)
 
+-- import Text.Show.Pretty (ppShow)
+
 votingSpec = describe "Voting" $ do
   it "Serialise" $ do
     let !script = cemScriptCompiled (Proxy :: Proxy SimpleVoting)
@@ -65,8 +58,8 @@ votingSpec = describe "Voting" $ do
           , specSigner = jury1
           }
 
-      stats <- perTransitionStats
-      liftIO $ putStrLn $ ppShow stats
+      -- stats <- perTransitionStats
+      -- liftIO $ putStrLn $ ppShow stats
 
       submitAndCheck $
         MkTxSpec
@@ -81,8 +74,8 @@ votingSpec = describe "Voting" $ do
           , specSigner = creator
           }
 
-      stats <- perTransitionStats
-      liftIO $ putStrLn $ ppShow stats
+      -- stats <- perTransitionStats
+      -- liftIO $ putStrLn $ ppShow stats
 
       Just state <- queryScriptState params
       liftIO $ state `shouldBe` Finalized Abstain