Move some datatypes from .Offchain up to .Monads

mlabs-haskell · Jun 30, 2024 · beadd21 · beadd21
1 parent a1b7d61
commit beadd21
Show file tree

Hide file tree

Showing 2 changed files with 46 additions and 41 deletions.
diff --git a/src/Cardano/CEM/Monads.hs b/src/Cardano/CEM/Monads.hs
@@ -3,6 +3,7 @@ module Cardano.CEM.Monads where
 import Prelude
 
 import Data.Set (Set)
+import GHC.Natural (Natural)
 
 import PlutusLedgerApi.V1.Address (Address)
 import PlutusLedgerApi.V2 (
@@ -14,10 +15,39 @@ import PlutusLedgerApi.V2 (
 import Cardano.Api hiding (Address, In, Out, queryUtxo, txIns)
 import Cardano.Api.Shelley (PoolId)
 import Cardano.Ledger.Core (PParams)
-import Cardano.Ledger.Shelley.API (ApplyTxError (..))
+import Cardano.Ledger.Shelley.API (ApplyTxError (..), Coin)
 
+import Cardano.CEM
+import Cardano.CEM.OnChain
 import Cardano.Extras
 
+-- CEMAction and TxSpec
+
+data CEMAction script
+  = MkCEMAction (CEMParams script) (Transition script)
+
+deriving stock instance
+  (CEMScript script) => Show (CEMAction script)
+
+-- FIXME: use generic Some
+data SomeCEMAction where
+  MkSomeCEMAction ::
+    forall script.
+    (CEMScriptCompiled script) =>
+    CEMAction script ->
+    SomeCEMAction
+
+instance Show SomeCEMAction where
+  -- FIXME: show script name
+  show :: SomeCEMAction -> String
+  show (MkSomeCEMAction action) = show action
+
+data TxSpec = MkTxSpec
+  { actions :: [SomeCEMAction]
+  , specSigner :: SigningKey PaymentKey
+  }
+  deriving stock (Show)
+
 -- MonadBlockchainParams
 
 -- | Params of blockchain required for transaction-building
@@ -73,6 +103,20 @@ data TxSubmittingError
   | UnhandledNodeSubmissionError (ApplyTxError LedgerEra)
   deriving stock (Show)
 
+-- | Error occurred while trying to execute CEMScript transition
+data TransitionError
+  = StateMachineError
+      { errorMessage :: String
+      }
+  | MissingTransitionInput
+  deriving stock (Show, Eq)
+
+data TxResolutionError
+  = TxSpecIsIncorrect
+  | MkTransitionError SomeCEMAction TransitionError
+  | UnhandledSubmittingError TxSubmittingError
+  deriving stock (Show)
+
 -- | Ability to send transaction to chain
 class (MonadQueryUtxo m) => MonadSubmitTx m where
   submitResolvedTx :: ResolvedTx -> m (Either TxSubmittingError TxId)

diff --git a/src/Cardano/CEM/OffChain.hs b/src/Cardano/CEM/OffChain.hs
@@ -59,45 +59,6 @@ awaitTx txId = do
         then return ()
         else go $ n - 1
 
-data CEMAction script
-  = MkCEMAction (CEMParams script) (Transition script)
-
-deriving stock instance
-  (CEMScript script) => Show (CEMAction script)
-
--- FIXME: use generic Some
-data SomeCEMAction where
-  MkSomeCEMAction ::
-    forall script.
-    (CEMScriptCompiled script) =>
-    CEMAction script ->
-    SomeCEMAction
-
-instance Show SomeCEMAction where
-  -- FIXME: show script name
-  show :: SomeCEMAction -> String
-  show (MkSomeCEMAction action) = show action
-
-data TxSpec = MkTxSpec
-  { actions :: [SomeCEMAction]
-  , specSigner :: SigningKey PaymentKey
-  }
-  deriving stock (Show)
-
--- | Error occurred while trying to execute CEMScript transition
-data TransitionError
-  = StateMachineError
-      { errorMessage :: String
-      }
-  | MissingTransitionInput
-  deriving stock (Show, Eq)
-
-data TxResolutionError
-  = TxSpecIsIncorrect
-  | MkTransitionError SomeCEMAction TransitionError
-  | UnhandledSubmittingError TxSubmittingError
-  deriving stock (Show)
-
 failLeft :: (MonadFail m, Show s) => Either s a -> m a
 failLeft (Left errorMsg) = fail $ show errorMsg
 failLeft (Right value) = return value
@@ -252,7 +213,7 @@ resolveTx spec = runExceptT $ do
   -- Merge specs
   let
     mergedSpec' = head actionsSpecs
-    mergedSpec = mergedSpec' {signer = specSigner spec}
+    mergedSpec = (mergedSpec' :: ResolvedTx) {signer = specSigner spec}
 
   return mergedSpec