{-# LANGUAGE DataKinds              #-}
{-# LANGUAGE DeriveAnyClass         #-}
{-# LANGUAGE DeriveGeneric          #-}
{-# LANGUAGE DerivingStrategies     #-}
{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE LambdaCase             #-}
{-# LANGUAGE MonoLocalBinds         #-}
{-# LANGUAGE NamedFieldPuns         #-}
{-# LANGUAGE OverloadedStrings      #-}
{-# LANGUAGE TemplateHaskell        #-}
{-# LANGUAGE TypeApplications       #-}
module Plutus.Contract.StateMachine(
    -- $statemachine
    StateMachineClient(..)
    , TxConstraints
    , SMContractError(..)
    , AsSMContractError(..)
    , SM.StateMachine(..)
    , SM.StateMachineInstance(..)
    , SM.State(..)
    , OnChainState(..)
    , WaitingResult(..)
    , InvalidTransition(..)
    , TransitionResult(..)
    , ThreadToken(..)
    -- * Constructing the machine instance
    , SM.mkValidator
    , SM.mkStateMachine
    -- * Constructing the state machine client
    , mkStateMachineClient
    , defaultChooser
    , getStates
    -- * Running the state machine
    , runGuardedStep
    , runStep
    , runInitialise
    , runGuardedStepWith
    , runStepWith
    , runInitialiseWith
    , getThreadToken
    , getOnChainState
    , getStateData
    , waitForUpdate
    , waitForUpdateUntilSlot
    , waitForUpdateUntilTime
    , waitForUpdateTimeout
    -- * Lower-level API
    , StateMachineTransition(..)
    , mkStep
    -- * Re-exports
    , Void
    ) where

import Control.Lens (_2, makeClassyPrisms, review, (^?))
import Control.Monad (unless)
import Control.Monad.Error.Lens
import Data.Aeson (FromJSON, ToJSON)
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Maybe (listToMaybe, mapMaybe)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Void (Void, absurd)
import GHC.Generics (Generic)
import Ledger (POSIXTime, Slot, TxOutRef)
import Ledger qualified
import Ledger.Tx qualified as Tx
import Ledger.Tx.Constraints (ScriptLookups, TxConstraints (txOwnInputs, txOwnOutputs), UnbalancedTx,
                              mustMintValueWithRedeemer, mustPayToTheScriptWithInlineDatum,
                              mustSpendOutputFromTheScript, mustSpendPubKeyOutput, plutusV2MintingPolicy)
import Ledger.Tx.Constraints.OffChain qualified as Constraints
import Ledger.Typed.Scripts qualified as Scripts
import Plutus.ChainIndex (ChainIndexTx (_citxInputs, _citxRedeemers))
import Plutus.Contract (AsContractError (_ContractError), Contract, ContractError, Promise, adjustUnbalancedTx,
                        awaitPromise, isSlot, isTime, logWarn, mapError, never, ownFirstPaymentPubKeyHash, ownUtxos,
                        promiseBind, select, submitTxConfirmed, utxoIsProduced, utxoIsSpent, utxosAt,
                        utxosTxOutTxFromTx)
import Plutus.Contract.Request (getUnspentOutput, mkTxConstraints)
import Plutus.Contract.StateMachine.MintingPolarity (MintingPolarity (Burn, Mint))
import Plutus.Contract.StateMachine.OnChain (State (State, stateData, stateValue),
                                             StateMachine (StateMachine, smFinal, smThreadToken, smTransition),
                                             StateMachineInstance (StateMachineInstance, stateMachine, typedValidator))
import Plutus.Contract.StateMachine.OnChain qualified as SM
import Plutus.Contract.StateMachine.ThreadToken (ThreadToken (ThreadToken), curPolicy, ttOutRef)
import Plutus.Script.Utils.V2.Scripts (scriptCurrencySymbol)
import Plutus.Script.Utils.V2.Typed.Scripts qualified as Typed
import Plutus.Script.Utils.Value (Value)
import Plutus.Script.Utils.Value qualified as Value
import Plutus.V2.Ledger.Tx qualified as V2
import PlutusTx qualified
import PlutusTx.Monoid (inv)

-- $statemachine
-- To write your contract as a state machine you need
-- * Two types @state@ and @input@ for the state and inputs of the machine
-- * A 'SM.StateMachineInstance state input' describing the transitions and
--   checks of the state machine (this is the on-chain code)
-- * A 'StateMachineClient state input' with the state machine instance and
--   an allocation function
--
-- In many cases it is enough to define the transition function
-- @t :: (state, Value) -> input -> Maybe (TxConstraints state)@ and use
-- 'mkStateMachine' and 'mkStateMachineClient' to get the client.
-- You can then use 'runInitialise' and 'runStep' to initialise and transition
-- the state machine. 'runStep' gets the current state from the utxo set and
-- makes the transition to the next state using the given input and taking care
-- of all payments.

-- | Typed representation of the on-chain state of a state machine instance
newtype OnChainState s i =
    OnChainState
        { OnChainState s i -> TypedScriptTxOutRef (StateMachine s i)
ocsTxOutRef :: Typed.TypedScriptTxOutRef (SM.StateMachine s i) -- ^ Typed UTXO
        }

getStateData :: OnChainState s i -> s
getStateData :: OnChainState s i -> s
getStateData = TypedScriptTxOut (StateMachine s i) -> s
forall a. TypedScriptTxOut a -> DatumType a
Typed.tyTxOutData (TypedScriptTxOut (StateMachine s i) -> s)
-> (OnChainState s i -> TypedScriptTxOut (StateMachine s i))
-> OnChainState s i
-> s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypedScriptTxOutRef (StateMachine s i)
-> TypedScriptTxOut (StateMachine s i)
forall a. TypedScriptTxOutRef a -> TypedScriptTxOut a
Typed.tyTxOutRefOut (TypedScriptTxOutRef (StateMachine s i)
 -> TypedScriptTxOut (StateMachine s i))
-> (OnChainState s i -> TypedScriptTxOutRef (StateMachine s i))
-> OnChainState s i
-> TypedScriptTxOut (StateMachine s i)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnChainState s i -> TypedScriptTxOutRef (StateMachine s i)
forall s i.
OnChainState s i -> TypedScriptTxOutRef (StateMachine s i)
ocsTxOutRef

getInput ::
    forall i.
    (PlutusTx.FromData i)
    => TxOutRef
    -> ChainIndexTx
    -> Maybe i
getInput :: TxOutRef -> ChainIndexTx -> Maybe i
getInput TxOutRef
outRef ChainIndexTx
tx = do
    -- We retrieve the correspondent redeemer according to the index of txIn in the list
    let findRedeemer :: (Integer, TxOutRef) -> Maybe Redeemer
findRedeemer (Integer
ix, TxOutRef
_) = RedeemerPtr -> Map RedeemerPtr Redeemer -> Maybe Redeemer
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ScriptTag -> Integer -> RedeemerPtr
Tx.RedeemerPtr ScriptTag
Tx.Spend Integer
ix) (ChainIndexTx -> Map RedeemerPtr Redeemer
_citxRedeemers ChainIndexTx
tx)
    Ledger.Redeemer BuiltinData
r <- [Redeemer] -> Maybe Redeemer
forall a. [a] -> Maybe a
listToMaybe
                       ([Redeemer] -> Maybe Redeemer) -> [Redeemer] -> Maybe Redeemer
forall a b. (a -> b) -> a -> b
$ ((Integer, TxOutRef) -> Maybe Redeemer)
-> [(Integer, TxOutRef)] -> [Redeemer]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Integer, TxOutRef) -> Maybe Redeemer
findRedeemer
                       ([(Integer, TxOutRef)] -> [Redeemer])
-> [(Integer, TxOutRef)] -> [Redeemer]
forall a b. (a -> b) -> a -> b
$ ((Integer, TxOutRef) -> Bool)
-> [(Integer, TxOutRef)] -> [(Integer, TxOutRef)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Integer
_, TxOutRef
ref) -> TxOutRef
outRef TxOutRef -> TxOutRef -> Bool
forall a. Eq a => a -> a -> Bool
== TxOutRef
ref)
                       ([(Integer, TxOutRef)] -> [(Integer, TxOutRef)])
-> [(Integer, TxOutRef)] -> [(Integer, TxOutRef)]
forall a b. (a -> b) -> a -> b
$ [Integer] -> [TxOutRef] -> [(Integer, TxOutRef)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
0..] ([TxOutRef] -> [(Integer, TxOutRef)])
-> [TxOutRef] -> [(Integer, TxOutRef)]
forall a b. (a -> b) -> a -> b
$ ChainIndexTx -> [TxOutRef]
_citxInputs ChainIndexTx
tx
    BuiltinData -> Maybe i
forall a. FromData a => BuiltinData -> Maybe a
PlutusTx.fromBuiltinData BuiltinData
r

getStates
    :: forall s i
    . (PlutusTx.FromData s, PlutusTx.ToData s)
    => SM.StateMachineInstance s i
    -> Map Tx.TxOutRef Tx.DecoratedTxOut
    -> [OnChainState s i]
getStates :: StateMachineInstance s i
-> Map TxOutRef DecoratedTxOut -> [OnChainState s i]
getStates (SM.StateMachineInstance StateMachine s i
_ TypedValidator (StateMachine s i)
si) Map TxOutRef DecoratedTxOut
refMap =
    (((TxOutRef, DecoratedTxOut) -> Maybe (OnChainState s i))
 -> [(TxOutRef, DecoratedTxOut)] -> [OnChainState s i])
-> [(TxOutRef, DecoratedTxOut)]
-> ((TxOutRef, DecoratedTxOut) -> Maybe (OnChainState s i))
-> [OnChainState s i]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((TxOutRef, DecoratedTxOut) -> Maybe (OnChainState s i))
-> [(TxOutRef, DecoratedTxOut)] -> [OnChainState s i]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Map TxOutRef DecoratedTxOut -> [(TxOutRef, DecoratedTxOut)]
forall k a. Map k a -> [(k, a)]
Map.toList Map TxOutRef DecoratedTxOut
refMap) (((TxOutRef, DecoratedTxOut) -> Maybe (OnChainState s i))
 -> [OnChainState s i])
-> ((TxOutRef, DecoratedTxOut) -> Maybe (OnChainState s i))
-> [OnChainState s i]
forall a b. (a -> b) -> a -> b
$ \(TxOutRef
txOutRef, DecoratedTxOut
ciTxOut) -> do
      let txOut :: TxOut
txOut = DecoratedTxOut -> TxOut
Tx.toTxInfoTxOut DecoratedTxOut
ciTxOut
      Datum
datum <- DecoratedTxOut
ciTxOut DecoratedTxOut
-> Getting (First Datum) DecoratedTxOut Datum -> Maybe Datum
forall s a. s -> Getting (First a) s a -> Maybe a
^? ((DatumHash, DatumFromQuery)
 -> Const (First Datum) (DatumHash, DatumFromQuery))
-> DecoratedTxOut -> Const (First Datum) DecoratedTxOut
Traversal' DecoratedTxOut (DatumHash, DatumFromQuery)
Tx.decoratedTxOutScriptDatum (((DatumHash, DatumFromQuery)
  -> Const (First Datum) (DatumHash, DatumFromQuery))
 -> DecoratedTxOut -> Const (First Datum) DecoratedTxOut)
-> ((Datum -> Const (First Datum) Datum)
    -> (DatumHash, DatumFromQuery)
    -> Const (First Datum) (DatumHash, DatumFromQuery))
-> Getting (First Datum) DecoratedTxOut Datum
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DatumFromQuery -> Const (First Datum) DatumFromQuery)
-> (DatumHash, DatumFromQuery)
-> Const (First Datum) (DatumHash, DatumFromQuery)
forall s t a b. Field2 s t a b => Lens s t a b
_2 ((DatumFromQuery -> Const (First Datum) DatumFromQuery)
 -> (DatumHash, DatumFromQuery)
 -> Const (First Datum) (DatumHash, DatumFromQuery))
-> ((Datum -> Const (First Datum) Datum)
    -> DatumFromQuery -> Const (First Datum) DatumFromQuery)
-> (Datum -> Const (First Datum) Datum)
-> (DatumHash, DatumFromQuery)
-> Const (First Datum) (DatumHash, DatumFromQuery)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Datum -> Const (First Datum) Datum)
-> DatumFromQuery -> Const (First Datum) DatumFromQuery
Traversal' DatumFromQuery Datum
Tx.datumInDatumFromQuery
      TypedScriptTxOutRef (StateMachine s i)
ocsTxOutRef <- (ConnectionError -> Maybe (TypedScriptTxOutRef (StateMachine s i)))
-> (TypedScriptTxOutRef (StateMachine s i)
    -> Maybe (TypedScriptTxOutRef (StateMachine s i)))
-> Either ConnectionError (TypedScriptTxOutRef (StateMachine s i))
-> Maybe (TypedScriptTxOutRef (StateMachine s i))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe (TypedScriptTxOutRef (StateMachine s i))
-> ConnectionError
-> Maybe (TypedScriptTxOutRef (StateMachine s i))
forall a b. a -> b -> a
const Maybe (TypedScriptTxOutRef (StateMachine s i))
forall a. Maybe a
Nothing) TypedScriptTxOutRef (StateMachine s i)
-> Maybe (TypedScriptTxOutRef (StateMachine s i))
forall a. a -> Maybe a
Just (Either ConnectionError (TypedScriptTxOutRef (StateMachine s i))
 -> Maybe (TypedScriptTxOutRef (StateMachine s i)))
-> Either ConnectionError (TypedScriptTxOutRef (StateMachine s i))
-> Maybe (TypedScriptTxOutRef (StateMachine s i))
forall a b. (a -> b) -> a -> b
$ TypedValidator (StateMachine s i)
-> TxOutRef
-> TxOut
-> Datum
-> Either ConnectionError (TypedScriptTxOutRef (StateMachine s i))
forall out (m :: * -> *).
(FromData (DatumType out), ToData (DatumType out),
 MonadError ConnectionError m) =>
TypedValidator out
-> TxOutRef -> TxOut -> Datum -> m (TypedScriptTxOutRef out)
Typed.typeScriptTxOutRef TypedValidator (StateMachine s i)
si TxOutRef
txOutRef TxOut
txOut Datum
datum
      OnChainState s i -> Maybe (OnChainState s i)
forall (f :: * -> *) a. Applicative f => a -> f a
pure OnChainState :: forall s i.
TypedScriptTxOutRef (StateMachine s i) -> OnChainState s i
OnChainState{TypedScriptTxOutRef (StateMachine s i)
ocsTxOutRef :: TypedScriptTxOutRef (StateMachine s i)
ocsTxOutRef :: TypedScriptTxOutRef (StateMachine s i)
ocsTxOutRef}

-- | An invalid transition
data InvalidTransition s i =
    InvalidTransition
        { InvalidTransition s i -> Maybe (State s)
tfState :: Maybe (State s) -- ^ Current state. 'Nothing' indicates that there is no current state.
        , InvalidTransition s i -> i
tfInput :: i -- ^ Transition that was attempted but failed
        }
        deriving stock (InvalidTransition s i -> InvalidTransition s i -> Bool
(InvalidTransition s i -> InvalidTransition s i -> Bool)
-> (InvalidTransition s i -> InvalidTransition s i -> Bool)
-> Eq (InvalidTransition s i)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall s i.
(Eq s, Eq i) =>
InvalidTransition s i -> InvalidTransition s i -> Bool
/= :: InvalidTransition s i -> InvalidTransition s i -> Bool
$c/= :: forall s i.
(Eq s, Eq i) =>
InvalidTransition s i -> InvalidTransition s i -> Bool
== :: InvalidTransition s i -> InvalidTransition s i -> Bool
$c== :: forall s i.
(Eq s, Eq i) =>
InvalidTransition s i -> InvalidTransition s i -> Bool
Eq, Int -> InvalidTransition s i -> ShowS
[InvalidTransition s i] -> ShowS
InvalidTransition s i -> String
(Int -> InvalidTransition s i -> ShowS)
-> (InvalidTransition s i -> String)
-> ([InvalidTransition s i] -> ShowS)
-> Show (InvalidTransition s i)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall s i.
(Show s, Show i) =>
Int -> InvalidTransition s i -> ShowS
forall s i. (Show s, Show i) => [InvalidTransition s i] -> ShowS
forall s i. (Show s, Show i) => InvalidTransition s i -> String
showList :: [InvalidTransition s i] -> ShowS
$cshowList :: forall s i. (Show s, Show i) => [InvalidTransition s i] -> ShowS
show :: InvalidTransition s i -> String
$cshow :: forall s i. (Show s, Show i) => InvalidTransition s i -> String
showsPrec :: Int -> InvalidTransition s i -> ShowS
$cshowsPrec :: forall s i.
(Show s, Show i) =>
Int -> InvalidTransition s i -> ShowS
Show, (forall x. InvalidTransition s i -> Rep (InvalidTransition s i) x)
-> (forall x.
    Rep (InvalidTransition s i) x -> InvalidTransition s i)
-> Generic (InvalidTransition s i)
forall x. Rep (InvalidTransition s i) x -> InvalidTransition s i
forall x. InvalidTransition s i -> Rep (InvalidTransition s i) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall s i x.
Rep (InvalidTransition s i) x -> InvalidTransition s i
forall s i x.
InvalidTransition s i -> Rep (InvalidTransition s i) x
$cto :: forall s i x.
Rep (InvalidTransition s i) x -> InvalidTransition s i
$cfrom :: forall s i x.
InvalidTransition s i -> Rep (InvalidTransition s i) x
Generic)
        deriving anyclass ([InvalidTransition s i] -> Encoding
[InvalidTransition s i] -> Value
InvalidTransition s i -> Encoding
InvalidTransition s i -> Value
(InvalidTransition s i -> Value)
-> (InvalidTransition s i -> Encoding)
-> ([InvalidTransition s i] -> Value)
-> ([InvalidTransition s i] -> Encoding)
-> ToJSON (InvalidTransition s i)
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
forall s i.
(ToJSON i, ToJSON s) =>
[InvalidTransition s i] -> Encoding
forall s i.
(ToJSON i, ToJSON s) =>
[InvalidTransition s i] -> Value
forall s i.
(ToJSON i, ToJSON s) =>
InvalidTransition s i -> Encoding
forall s i. (ToJSON i, ToJSON s) => InvalidTransition s i -> Value
toEncodingList :: [InvalidTransition s i] -> Encoding
$ctoEncodingList :: forall s i.
(ToJSON i, ToJSON s) =>
[InvalidTransition s i] -> Encoding
toJSONList :: [InvalidTransition s i] -> Value
$ctoJSONList :: forall s i.
(ToJSON i, ToJSON s) =>
[InvalidTransition s i] -> Value
toEncoding :: InvalidTransition s i -> Encoding
$ctoEncoding :: forall s i.
(ToJSON i, ToJSON s) =>
InvalidTransition s i -> Encoding
toJSON :: InvalidTransition s i -> Value
$ctoJSON :: forall s i. (ToJSON i, ToJSON s) => InvalidTransition s i -> Value
ToJSON, Value -> Parser [InvalidTransition s i]
Value -> Parser (InvalidTransition s i)
(Value -> Parser (InvalidTransition s i))
-> (Value -> Parser [InvalidTransition s i])
-> FromJSON (InvalidTransition s i)
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
forall s i.
(FromJSON s, FromJSON i) =>
Value -> Parser [InvalidTransition s i]
forall s i.
(FromJSON s, FromJSON i) =>
Value -> Parser (InvalidTransition s i)
parseJSONList :: Value -> Parser [InvalidTransition s i]
$cparseJSONList :: forall s i.
(FromJSON s, FromJSON i) =>
Value -> Parser [InvalidTransition s i]
parseJSON :: Value -> Parser (InvalidTransition s i)
$cparseJSON :: forall s i.
(FromJSON s, FromJSON i) =>
Value -> Parser (InvalidTransition s i)
FromJSON)

-- | Result of an attempted transition
data TransitionResult s i =
    TransitionFailure (InvalidTransition s i) -- ^ The transition is not allowed
    | TransitionSuccess s -- ^ The transition is allowed and results in a new state

data SMContractError =
    ChooserError Text
    | UnableToExtractTransition
    | SMCContractError ContractError
    deriving stock (Int -> SMContractError -> ShowS
[SMContractError] -> ShowS
SMContractError -> String
(Int -> SMContractError -> ShowS)
-> (SMContractError -> String)
-> ([SMContractError] -> ShowS)
-> Show SMContractError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SMContractError] -> ShowS
$cshowList :: [SMContractError] -> ShowS
show :: SMContractError -> String
$cshow :: SMContractError -> String
showsPrec :: Int -> SMContractError -> ShowS
$cshowsPrec :: Int -> SMContractError -> ShowS
Show, SMContractError -> SMContractError -> Bool
(SMContractError -> SMContractError -> Bool)
-> (SMContractError -> SMContractError -> Bool)
-> Eq SMContractError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SMContractError -> SMContractError -> Bool
$c/= :: SMContractError -> SMContractError -> Bool
== :: SMContractError -> SMContractError -> Bool
$c== :: SMContractError -> SMContractError -> Bool
Eq, (forall x. SMContractError -> Rep SMContractError x)
-> (forall x. Rep SMContractError x -> SMContractError)
-> Generic SMContractError
forall x. Rep SMContractError x -> SMContractError
forall x. SMContractError -> Rep SMContractError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SMContractError x -> SMContractError
$cfrom :: forall x. SMContractError -> Rep SMContractError x
Generic)
    deriving anyclass ([SMContractError] -> Encoding
[SMContractError] -> Value
SMContractError -> Encoding
SMContractError -> Value
(SMContractError -> Value)
-> (SMContractError -> Encoding)
-> ([SMContractError] -> Value)
-> ([SMContractError] -> Encoding)
-> ToJSON SMContractError
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [SMContractError] -> Encoding
$ctoEncodingList :: [SMContractError] -> Encoding
toJSONList :: [SMContractError] -> Value
$ctoJSONList :: [SMContractError] -> Value
toEncoding :: SMContractError -> Encoding
$ctoEncoding :: SMContractError -> Encoding
toJSON :: SMContractError -> Value
$ctoJSON :: SMContractError -> Value
ToJSON, Value -> Parser [SMContractError]
Value -> Parser SMContractError
(Value -> Parser SMContractError)
-> (Value -> Parser [SMContractError]) -> FromJSON SMContractError
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [SMContractError]
$cparseJSONList :: Value -> Parser [SMContractError]
parseJSON :: Value -> Parser SMContractError
$cparseJSON :: Value -> Parser SMContractError
FromJSON)

makeClassyPrisms ''SMContractError

instance AsContractError SMContractError where
    _ContractError :: p ContractError (f ContractError)
-> p SMContractError (f SMContractError)
_ContractError = p ContractError (f ContractError)
-> p SMContractError (f SMContractError)
forall r. AsSMContractError r => Prism' r ContractError
_SMCContractError

-- | Client-side definition of a state machine.
data StateMachineClient s i = StateMachineClient
    { StateMachineClient s i -> StateMachineInstance s i
scInstance :: SM.StateMachineInstance s i
    -- ^ The instance of the state machine, defining the machine's transitions,
    --   its final states and its check function.
    , StateMachineClient s i
-> [OnChainState s i] -> Either SMContractError (OnChainState s i)
scChooser  :: [OnChainState s i] -> Either SMContractError (OnChainState s i)
    -- ^ A function that chooses the relevant on-chain state, given a list of
    --   all potential on-chain states found at the contract address.
    }

-- | A state chooser function that fails if confronted with anything other
--   than exactly one output
defaultChooser ::
    forall state input
    . [OnChainState state input]
    -> Either SMContractError (OnChainState state input)
defaultChooser :: [OnChainState state input]
-> Either SMContractError (OnChainState state input)
defaultChooser [OnChainState state input
x] = OnChainState state input
-> Either SMContractError (OnChainState state input)
forall a b. b -> Either a b
Right OnChainState state input
x
defaultChooser [OnChainState state input]
xs  =
    let msg :: String
msg = String
"Found " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([OnChainState state input] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [OnChainState state input]
xs) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" outputs, expected 1"
    in SMContractError
-> Either SMContractError (OnChainState state input)
forall a b. a -> Either a b
Left (Text -> SMContractError
ChooserError (String -> Text
Text.pack String
msg))

-- | A state chooser function that searches for an output with the thread token
threadTokenChooser ::
    forall state input
    . Value
    -> [OnChainState state input]
    -> Either SMContractError (OnChainState state input)
threadTokenChooser :: Value
-> [OnChainState state input]
-> Either SMContractError (OnChainState state input)
threadTokenChooser Value
val [OnChainState state input]
states =
    let hasToken :: OnChainState state input -> Bool
hasToken OnChainState{TypedScriptTxOutRef (StateMachine state input)
ocsTxOutRef :: TypedScriptTxOutRef (StateMachine state input)
ocsTxOutRef :: forall s i.
OnChainState s i -> TypedScriptTxOutRef (StateMachine s i)
ocsTxOutRef} =
          Value
val Value -> Value -> Bool
`Value.leq` (TxOut -> Value
V2.txOutValue (TxOut -> Value) -> TxOut -> Value
forall a b. (a -> b) -> a -> b
$ TypedScriptTxOut (StateMachine state input) -> TxOut
forall a. TypedScriptTxOut a -> TxOut
Typed.tyTxOutTxOut (TypedScriptTxOut (StateMachine state input) -> TxOut)
-> TypedScriptTxOut (StateMachine state input) -> TxOut
forall a b. (a -> b) -> a -> b
$ TypedScriptTxOutRef (StateMachine state input)
-> TypedScriptTxOut (StateMachine state input)
forall a. TypedScriptTxOutRef a -> TypedScriptTxOut a
Typed.tyTxOutRefOut TypedScriptTxOutRef (StateMachine state input)
ocsTxOutRef)
    in case (OnChainState state input -> Bool)
-> [OnChainState state input] -> [OnChainState state input]
forall a. (a -> Bool) -> [a] -> [a]
filter OnChainState state input -> Bool
hasToken [OnChainState state input]
states of
        [OnChainState state input
x] -> OnChainState state input
-> Either SMContractError (OnChainState state input)
forall a b. b -> Either a b
Right OnChainState state input
x
        [OnChainState state input]
xs ->
            let msg :: String
msg = [String] -> String
unwords [String
"Found", Int -> String
forall a. Show a => a -> String
show ([OnChainState state input] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [OnChainState state input]
xs), String
"outputs with thread token", Value -> String
forall a. Show a => a -> String
show Value
val, String
"expected 1"]
            in SMContractError
-> Either SMContractError (OnChainState state input)
forall a b. a -> Either a b
Left (Text -> SMContractError
ChooserError (String -> Text
Text.pack String
msg))

-- | A state machine client with the 'defaultChooser' function
mkStateMachineClient ::
    forall state input
    . SM.StateMachineInstance state input
    -> StateMachineClient state input
mkStateMachineClient :: StateMachineInstance state input -> StateMachineClient state input
mkStateMachineClient StateMachineInstance state input
inst =
    let threadTokenVal :: Value
threadTokenVal = StateMachineInstance state input -> Value
forall s i. StateMachineInstance s i -> Value
SM.threadTokenValueOrZero StateMachineInstance state input
inst
        scChooser :: [OnChainState state input]
-> Either SMContractError (OnChainState state input)
scChooser = if Value -> Bool
Value.isZero Value
threadTokenVal then [OnChainState state input]
-> Either SMContractError (OnChainState state input)
forall state input.
[OnChainState state input]
-> Either SMContractError (OnChainState state input)
defaultChooser else Value
-> [OnChainState state input]
-> Either SMContractError (OnChainState state input)
forall state input.
Value
-> [OnChainState state input]
-> Either SMContractError (OnChainState state input)
threadTokenChooser Value
threadTokenVal
    in StateMachineClient :: forall s i.
StateMachineInstance s i
-> ([OnChainState s i]
    -> Either SMContractError (OnChainState s i))
-> StateMachineClient s i
StateMachineClient
        { scInstance :: StateMachineInstance state input
scInstance = StateMachineInstance state input
inst
        , [OnChainState state input]
-> Either SMContractError (OnChainState state input)
scChooser :: [OnChainState state input]
-> Either SMContractError (OnChainState state input)
scChooser :: [OnChainState state input]
-> Either SMContractError (OnChainState state input)
scChooser
        }

{-| Get the current on-chain state of the state machine instance.
    Return Nothing if there is no state on chain.
    Throws an @SMContractError@ if the number of outputs at the machine address is greater than one.
-}
getOnChainState ::
    ( AsSMContractError e
    , PlutusTx.FromData state
    , PlutusTx.ToData state
    )
    => StateMachineClient state i
    -> Contract w schema e (Maybe (OnChainState state i, Map TxOutRef Tx.DecoratedTxOut))
getOnChainState :: StateMachineClient state i
-> Contract
     w
     schema
     e
     (Maybe (OnChainState state i, Map TxOutRef DecoratedTxOut))
getOnChainState StateMachineClient{StateMachineInstance state i
scInstance :: StateMachineInstance state i
scInstance :: forall s i. StateMachineClient s i -> StateMachineInstance s i
scInstance, [OnChainState state i]
-> Either SMContractError (OnChainState state i)
scChooser :: [OnChainState state i]
-> Either SMContractError (OnChainState state i)
scChooser :: forall s i.
StateMachineClient s i
-> [OnChainState s i] -> Either SMContractError (OnChainState s i)
scChooser} = (SMContractError -> e)
-> Contract
     w
     schema
     SMContractError
     (Maybe (OnChainState state i, Map TxOutRef DecoratedTxOut))
-> Contract
     w
     schema
     e
     (Maybe (OnChainState state i, Map TxOutRef DecoratedTxOut))
forall w (s :: Row *) e e' a.
(e -> e') -> Contract w s e a -> Contract w s e' a
mapError (AReview e SMContractError -> SMContractError -> e
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review AReview e SMContractError
forall r. AsSMContractError r => Prism' r SMContractError
_SMContractError) (Contract
   w
   schema
   SMContractError
   (Maybe (OnChainState state i, Map TxOutRef DecoratedTxOut))
 -> Contract
      w
      schema
      e
      (Maybe (OnChainState state i, Map TxOutRef DecoratedTxOut)))
-> Contract
     w
     schema
     SMContractError
     (Maybe (OnChainState state i, Map TxOutRef DecoratedTxOut))
-> Contract
     w
     schema
     e
     (Maybe (OnChainState state i, Map TxOutRef DecoratedTxOut))
forall a b. (a -> b) -> a -> b
$ do
    Map TxOutRef DecoratedTxOut
utxoTx <- CardanoAddress
-> Contract w schema SMContractError (Map TxOutRef DecoratedTxOut)
forall w (s :: Row *) e.
AsContractError e =>
CardanoAddress -> Contract w s e (Map TxOutRef DecoratedTxOut)
utxosAt (StateMachineInstance state i -> CardanoAddress
forall s i. StateMachineInstance s i -> CardanoAddress
SM.machineAddress StateMachineInstance state i
scInstance)
    let states :: [OnChainState state i]
states = StateMachineInstance state i
-> Map TxOutRef DecoratedTxOut -> [OnChainState state i]
forall s i.
(FromData s, ToData s) =>
StateMachineInstance s i
-> Map TxOutRef DecoratedTxOut -> [OnChainState s i]
getStates StateMachineInstance state i
scInstance Map TxOutRef DecoratedTxOut
utxoTx
    case [OnChainState state i]
states of
        [] -> Maybe (OnChainState state i, Map TxOutRef DecoratedTxOut)
-> Contract
     w
     schema
     SMContractError
     (Maybe (OnChainState state i, Map TxOutRef DecoratedTxOut))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (OnChainState state i, Map TxOutRef DecoratedTxOut)
forall a. Maybe a
Nothing
        [OnChainState state i]
_  -> case [OnChainState state i]
-> Either SMContractError (OnChainState state i)
scChooser [OnChainState state i]
states of
                Left SMContractError
err    -> AReview SMContractError SMContractError
-> SMContractError
-> Contract
     w
     schema
     SMContractError
     (Maybe (OnChainState state i, Map TxOutRef DecoratedTxOut))
forall e (m :: * -> *) t x.
MonadError e m =>
AReview e t -> t -> m x
throwing AReview SMContractError SMContractError
forall r. AsSMContractError r => Prism' r SMContractError
_SMContractError SMContractError
err
                Right OnChainState state i
state -> Maybe (OnChainState state i, Map TxOutRef DecoratedTxOut)
-> Contract
     w
     schema
     SMContractError
     (Maybe (OnChainState state i, Map TxOutRef DecoratedTxOut))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (OnChainState state i, Map TxOutRef DecoratedTxOut)
 -> Contract
      w
      schema
      SMContractError
      (Maybe (OnChainState state i, Map TxOutRef DecoratedTxOut)))
-> Maybe (OnChainState state i, Map TxOutRef DecoratedTxOut)
-> Contract
     w
     schema
     SMContractError
     (Maybe (OnChainState state i, Map TxOutRef DecoratedTxOut))
forall a b. (a -> b) -> a -> b
$ (OnChainState state i, Map TxOutRef DecoratedTxOut)
-> Maybe (OnChainState state i, Map TxOutRef DecoratedTxOut)
forall a. a -> Maybe a
Just (OnChainState state i
state, Map TxOutRef DecoratedTxOut
utxoTx)

-- | The outcome of 'waitForUpdateTimeout'
data WaitingResult t i s
    = Timeout t -- ^ The timeout happened before any change of the on-chain state was detected
    | ContractEnded i -- ^ The state machine instance ended
    | Transition i s -- ^ The state machine instance transitioned to a new state
    | InitialState s -- ^ The state machine instance was initialised
  deriving stock (Int -> WaitingResult t i s -> ShowS
[WaitingResult t i s] -> ShowS
WaitingResult t i s -> String
(Int -> WaitingResult t i s -> ShowS)
-> (WaitingResult t i s -> String)
-> ([WaitingResult t i s] -> ShowS)
-> Show (WaitingResult t i s)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall t i s.
(Show t, Show i, Show s) =>
Int -> WaitingResult t i s -> ShowS
forall t i s.
(Show t, Show i, Show s) =>
[WaitingResult t i s] -> ShowS
forall t i s.
(Show t, Show i, Show s) =>
WaitingResult t i s -> String
showList :: [WaitingResult t i s] -> ShowS
$cshowList :: forall t i s.
(Show t, Show i, Show s) =>
[WaitingResult t i s] -> ShowS
show :: WaitingResult t i s -> String
$cshow :: forall t i s.
(Show t, Show i, Show s) =>
WaitingResult t i s -> String
showsPrec :: Int -> WaitingResult t i s -> ShowS
$cshowsPrec :: forall t i s.
(Show t, Show i, Show s) =>
Int -> WaitingResult t i s -> ShowS
Show,(forall x. WaitingResult t i s -> Rep (WaitingResult t i s) x)
-> (forall x. Rep (WaitingResult t i s) x -> WaitingResult t i s)
-> Generic (WaitingResult t i s)
forall x. Rep (WaitingResult t i s) x -> WaitingResult t i s
forall x. WaitingResult t i s -> Rep (WaitingResult t i s) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall t i s x. Rep (WaitingResult t i s) x -> WaitingResult t i s
forall t i s x. WaitingResult t i s -> Rep (WaitingResult t i s) x
$cto :: forall t i s x. Rep (WaitingResult t i s) x -> WaitingResult t i s
$cfrom :: forall t i s x. WaitingResult t i s -> Rep (WaitingResult t i s) x
Generic,a -> WaitingResult t i b -> WaitingResult t i a
(a -> b) -> WaitingResult t i a -> WaitingResult t i b
(forall a b.
 (a -> b) -> WaitingResult t i a -> WaitingResult t i b)
-> (forall a b. a -> WaitingResult t i b -> WaitingResult t i a)
-> Functor (WaitingResult t i)
forall a b. a -> WaitingResult t i b -> WaitingResult t i a
forall a b. (a -> b) -> WaitingResult t i a -> WaitingResult t i b
forall t i a b. a -> WaitingResult t i b -> WaitingResult t i a
forall t i a b.
(a -> b) -> WaitingResult t i a -> WaitingResult t i b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> WaitingResult t i b -> WaitingResult t i a
$c<$ :: forall t i a b. a -> WaitingResult t i b -> WaitingResult t i a
fmap :: (a -> b) -> WaitingResult t i a -> WaitingResult t i b
$cfmap :: forall t i a b.
(a -> b) -> WaitingResult t i a -> WaitingResult t i b
Functor)
  deriving anyclass ([WaitingResult t i s] -> Encoding
[WaitingResult t i s] -> Value
WaitingResult t i s -> Encoding
WaitingResult t i s -> Value
(WaitingResult t i s -> Value)
-> (WaitingResult t i s -> Encoding)
-> ([WaitingResult t i s] -> Value)
-> ([WaitingResult t i s] -> Encoding)
-> ToJSON (WaitingResult t i s)
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
forall t i s.
(ToJSON s, ToJSON i, ToJSON t) =>
[WaitingResult t i s] -> Encoding
forall t i s.
(ToJSON s, ToJSON i, ToJSON t) =>
[WaitingResult t i s] -> Value
forall t i s.
(ToJSON s, ToJSON i, ToJSON t) =>
WaitingResult t i s -> Encoding
forall t i s.
(ToJSON s, ToJSON i, ToJSON t) =>
WaitingResult t i s -> Value
toEncodingList :: [WaitingResult t i s] -> Encoding
$ctoEncodingList :: forall t i s.
(ToJSON s, ToJSON i, ToJSON t) =>
[WaitingResult t i s] -> Encoding
toJSONList :: [WaitingResult t i s] -> Value
$ctoJSONList :: forall t i s.
(ToJSON s, ToJSON i, ToJSON t) =>
[WaitingResult t i s] -> Value
toEncoding :: WaitingResult t i s -> Encoding
$ctoEncoding :: forall t i s.
(ToJSON s, ToJSON i, ToJSON t) =>
WaitingResult t i s -> Encoding
toJSON :: WaitingResult t i s -> Value
$ctoJSON :: forall t i s.
(ToJSON s, ToJSON i, ToJSON t) =>
WaitingResult t i s -> Value
ToJSON, Value -> Parser [WaitingResult t i s]
Value -> Parser (WaitingResult t i s)
(Value -> Parser (WaitingResult t i s))
-> (Value -> Parser [WaitingResult t i s])
-> FromJSON (WaitingResult t i s)
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
forall t i s.
(FromJSON s, FromJSON t, FromJSON i) =>
Value -> Parser [WaitingResult t i s]
forall t i s.
(FromJSON s, FromJSON t, FromJSON i) =>
Value -> Parser (WaitingResult t i s)
parseJSONList :: Value -> Parser [WaitingResult t i s]
$cparseJSONList :: forall t i s.
(FromJSON s, FromJSON t, FromJSON i) =>
Value -> Parser [WaitingResult t i s]
parseJSON :: Value -> Parser (WaitingResult t i s)
$cparseJSON :: forall t i s.
(FromJSON s, FromJSON t, FromJSON i) =>
Value -> Parser (WaitingResult t i s)
FromJSON)

-- | Wait for the on-chain state of the state machine instance to change until timeoutSlot,
--   and return the new state, or return 'ContractEnded' if the instance has been
--   terminated. If 'waitForUpdate' is called before the instance has even
--   started then it returns the first state of the instance as soon as it
--   has started.
waitForUpdateUntilSlot ::
    ( AsSMContractError e
    , AsContractError e
    , PlutusTx.FromData state
    , PlutusTx.ToData state
    , PlutusTx.FromData i
    )
    => StateMachineClient state i
    -> Slot
    -> Contract w schema e (WaitingResult Slot i state)
waitForUpdateUntilSlot :: StateMachineClient state i
-> Slot -> Contract w schema e (WaitingResult Slot i state)
waitForUpdateUntilSlot StateMachineClient state i
client Slot
timeoutSlot = do
  WaitingResult Slot i (OnChainState state i)
result <- StateMachineClient state i
-> Promise w schema e Slot
-> Contract
     w
     schema
     e
     (Promise w schema e (WaitingResult Slot i (OnChainState state i)))
forall state i t w (schema :: Row *) e.
(AsSMContractError e, AsContractError e, FromData state,
 ToData state, FromData i) =>
StateMachineClient state i
-> Promise w schema e t
-> Contract
     w
     schema
     e
     (Promise w schema e (WaitingResult t i (OnChainState state i)))
waitForUpdateTimeout StateMachineClient state i
client (Slot -> Promise w schema e Slot
forall w (s :: Row *) e.
AsContractError e =>
Slot -> Promise w s e Slot
isSlot Slot
timeoutSlot) Contract
  w
  schema
  e
  (Promise w schema e (WaitingResult Slot i (OnChainState state i)))
-> (Promise
      w schema e (WaitingResult Slot i (OnChainState state i))
    -> Contract
         w schema e (WaitingResult Slot i (OnChainState state i)))
-> Contract
     w schema e (WaitingResult Slot i (OnChainState state i))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Promise w schema e (WaitingResult Slot i (OnChainState state i))
-> Contract
     w schema e (WaitingResult Slot i (OnChainState state i))
forall w (s :: Row *) e a. Promise w s e a -> Contract w s e a
awaitPromise
  WaitingResult Slot i state
-> Contract w schema e (WaitingResult Slot i state)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WaitingResult Slot i state
 -> Contract w schema e (WaitingResult Slot i state))
-> WaitingResult Slot i state
-> Contract w schema e (WaitingResult Slot i state)
forall a b. (a -> b) -> a -> b
$ (OnChainState state i -> state)
-> WaitingResult Slot i (OnChainState state i)
-> WaitingResult Slot i state
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap OnChainState state i -> state
forall s i. OnChainState s i -> s
getStateData WaitingResult Slot i (OnChainState state i)
result

-- | Same as 'waitForUpdateUntilSlot', but works with 'POSIXTime' instead.
waitForUpdateUntilTime ::
    ( AsSMContractError e
    , AsContractError e
    , PlutusTx.FromData state
    , PlutusTx.ToData state
    , PlutusTx.FromData i
    )
    => StateMachineClient state i
    -> POSIXTime
    -> Contract w schema e (WaitingResult POSIXTime i state)
waitForUpdateUntilTime :: StateMachineClient state i
-> POSIXTime
-> Contract w schema e (WaitingResult POSIXTime i state)
waitForUpdateUntilTime StateMachineClient state i
client POSIXTime
timeoutTime = do
  WaitingResult POSIXTime i (OnChainState state i)
result <- StateMachineClient state i
-> Promise w schema e POSIXTime
-> Contract
     w
     schema
     e
     (Promise
        w schema e (WaitingResult POSIXTime i (OnChainState state i)))
forall state i t w (schema :: Row *) e.
(AsSMContractError e, AsContractError e, FromData state,
 ToData state, FromData i) =>
StateMachineClient state i
-> Promise w schema e t
-> Contract
     w
     schema
     e
     (Promise w schema e (WaitingResult t i (OnChainState state i)))
waitForUpdateTimeout StateMachineClient state i
client (POSIXTime -> Promise w schema e POSIXTime
forall w (s :: Row *) e.
AsContractError e =>
POSIXTime -> Promise w s e POSIXTime
isTime POSIXTime
timeoutTime) Contract
  w
  schema
  e
  (Promise
     w schema e (WaitingResult POSIXTime i (OnChainState state i)))
-> (Promise
      w schema e (WaitingResult POSIXTime i (OnChainState state i))
    -> Contract
         w schema e (WaitingResult POSIXTime i (OnChainState state i)))
-> Contract
     w schema e (WaitingResult POSIXTime i (OnChainState state i))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Promise
  w schema e (WaitingResult POSIXTime i (OnChainState state i))
-> Contract
     w schema e (WaitingResult POSIXTime i (OnChainState state i))
forall w (s :: Row *) e a. Promise w s e a -> Contract w s e a
awaitPromise
  WaitingResult POSIXTime i state
-> Contract w schema e (WaitingResult POSIXTime i state)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WaitingResult POSIXTime i state
 -> Contract w schema e (WaitingResult POSIXTime i state))
-> WaitingResult POSIXTime i state
-> Contract w schema e (WaitingResult POSIXTime i state)
forall a b. (a -> b) -> a -> b
$ (OnChainState state i -> state)
-> WaitingResult POSIXTime i (OnChainState state i)
-> WaitingResult POSIXTime i state
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap OnChainState state i -> state
forall s i. OnChainState s i -> s
getStateData WaitingResult POSIXTime i (OnChainState state i)
result

-- | Wait until the on-chain state of the state machine instance has changed,
--   and return the new state, or return 'Nothing' if the instance has been
--   terminated. If 'waitForUpdate' is called before the instance has even
--   started then it returns the first state of the instance as soon as it
--   has started.
waitForUpdate ::
    forall state i w schema e.
    ( AsSMContractError e
    , AsContractError e
    , PlutusTx.FromData state
    , PlutusTx.ToData state
    , PlutusTx.FromData i
    )
    => StateMachineClient state i
    -> Contract w schema e (Maybe (OnChainState state i))
waitForUpdate :: StateMachineClient state i
-> Contract w schema e (Maybe (OnChainState state i))
waitForUpdate StateMachineClient state i
client = do
  WaitingResult Void i (OnChainState state i)
result <- StateMachineClient state i
-> Promise w schema e Void
-> Contract
     w
     schema
     e
     (Promise w schema e (WaitingResult Void i (OnChainState state i)))
forall state i t w (schema :: Row *) e.
(AsSMContractError e, AsContractError e, FromData state,
 ToData state, FromData i) =>
StateMachineClient state i
-> Promise w schema e t
-> Contract
     w
     schema
     e
     (Promise w schema e (WaitingResult t i (OnChainState state i)))
waitForUpdateTimeout StateMachineClient state i
client Promise w schema e Void
forall w (s :: Row *) e a. Promise w s e a
never Contract
  w
  schema
  e
  (Promise w schema e (WaitingResult Void i (OnChainState state i)))
-> (Promise
      w schema e (WaitingResult Void i (OnChainState state i))
    -> Contract
         w schema e (WaitingResult Void i (OnChainState state i)))
-> Contract
     w schema e (WaitingResult Void i (OnChainState state i))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Promise w schema e (WaitingResult Void i (OnChainState state i))
-> Contract
     w schema e (WaitingResult Void i (OnChainState state i))
forall w (s :: Row *) e a. Promise w s e a -> Contract w s e a
awaitPromise
  case WaitingResult Void i (OnChainState state i)
result of
    Timeout Void
t       -> Void -> Contract w schema e (Maybe (OnChainState state i))
forall a. Void -> a
absurd Void
t
    ContractEnded{} -> Maybe (OnChainState state i)
-> Contract w schema e (Maybe (OnChainState state i))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (OnChainState state i)
forall a. Maybe a
Nothing
    InitialState OnChainState state i
r  -> Maybe (OnChainState state i)
-> Contract w schema e (Maybe (OnChainState state i))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OnChainState state i -> Maybe (OnChainState state i)
forall a. a -> Maybe a
Just OnChainState state i
r)
    Transition i
_ OnChainState state i
r  -> Maybe (OnChainState state i)
-> Contract w schema e (Maybe (OnChainState state i))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OnChainState state i -> Maybe (OnChainState state i)
forall a. a -> Maybe a
Just OnChainState state i
r)

-- | Construct a 'Promise' that waits for an update to the state machine's
--   on-chain state, or a user-defined timeout (whichever happens first).
waitForUpdateTimeout ::
    forall state i t w schema e.
    ( AsSMContractError e
    , AsContractError e
    , PlutusTx.FromData state
    , PlutusTx.ToData state
    , PlutusTx.FromData i
    )
    => StateMachineClient state i -- ^ The state machine client
    -> Promise w schema e t -- ^ The timeout
    -> Contract w schema e (Promise w schema e (WaitingResult t i (OnChainState state i)))
waitForUpdateTimeout :: StateMachineClient state i
-> Promise w schema e t
-> Contract
     w
     schema
     e
     (Promise w schema e (WaitingResult t i (OnChainState state i)))
waitForUpdateTimeout client :: StateMachineClient state i
client@StateMachineClient{StateMachineInstance state i
scInstance :: StateMachineInstance state i
scInstance :: forall s i. StateMachineClient s i -> StateMachineInstance s i
scInstance, [OnChainState state i]
-> Either SMContractError (OnChainState state i)
scChooser :: [OnChainState state i]
-> Either SMContractError (OnChainState state i)
scChooser :: forall s i.
StateMachineClient s i
-> [OnChainState s i] -> Either SMContractError (OnChainState s i)
scChooser} Promise w schema e t
timeout = do
    Maybe (OnChainState state i, Map TxOutRef DecoratedTxOut)
currentState <- StateMachineClient state i
-> Contract
     w
     schema
     e
     (Maybe (OnChainState state i, Map TxOutRef DecoratedTxOut))
forall e state i w (schema :: Row *).
(AsSMContractError e, FromData state, ToData state) =>
StateMachineClient state i
-> Contract
     w
     schema
     e
     (Maybe (OnChainState state i, Map TxOutRef DecoratedTxOut))
getOnChainState StateMachineClient state i
client
    let projectFst :: (a, (b, b)) -> (a, b)
projectFst = (\(a
a, (b
b, b
_)) -> (a
a, b
b))
    let success :: Promise w schema e (WaitingResult t i (OnChainState state i))
success = case Maybe (OnChainState state i, Map TxOutRef DecoratedTxOut)
currentState of
                    Maybe (OnChainState state i, Map TxOutRef DecoratedTxOut)
Nothing ->
                        -- There is no on-chain state, so we wait for an output to appear
                        -- at the address. Any output that appears needs to be checked
                        -- with scChooser'
                        let addr :: CardanoAddress
addr = StateMachineInstance state i -> CardanoAddress
forall s i. StateMachineInstance s i -> CardanoAddress
SM.machineAddress StateMachineInstance state i
scInstance in
                        Promise w schema e (NonEmpty ChainIndexTx)
-> (NonEmpty ChainIndexTx
    -> Contract w schema e (WaitingResult t i (OnChainState state i)))
-> Promise w schema e (WaitingResult t i (OnChainState state i))
forall w (s :: Row *) e a b.
Promise w s e a -> (a -> Contract w s e b) -> Promise w s e b
promiseBind (CardanoAddress -> Promise w schema e (NonEmpty ChainIndexTx)
forall w (s :: Row *) e.
AsContractError e =>
CardanoAddress -> Promise w s e (NonEmpty ChainIndexTx)
utxoIsProduced CardanoAddress
addr) ((NonEmpty ChainIndexTx
  -> Contract w schema e (WaitingResult t i (OnChainState state i)))
 -> Promise w schema e (WaitingResult t i (OnChainState state i)))
-> (NonEmpty ChainIndexTx
    -> Contract w schema e (WaitingResult t i (OnChainState state i)))
-> Promise w schema e (WaitingResult t i (OnChainState state i))
forall a b. (a -> b) -> a -> b
$ \NonEmpty ChainIndexTx
txns -> do
                            NonEmpty [(TxOutRef, (DecoratedTxOut, ChainIndexTx))]
outRefMaps <- (ChainIndexTx
 -> Contract
      w schema e [(TxOutRef, (DecoratedTxOut, ChainIndexTx))])
-> NonEmpty ChainIndexTx
-> Contract
     w schema e (NonEmpty [(TxOutRef, (DecoratedTxOut, ChainIndexTx))])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ChainIndexTx
-> Contract w schema e [(TxOutRef, (DecoratedTxOut, ChainIndexTx))]
forall e w (s :: Row *).
AsContractError e =>
ChainIndexTx
-> Contract w s e [(TxOutRef, (DecoratedTxOut, ChainIndexTx))]
utxosTxOutTxFromTx NonEmpty ChainIndexTx
txns
                            let produced :: [OnChainState state i]
produced = StateMachineInstance state i
-> Map TxOutRef DecoratedTxOut -> [OnChainState state i]
forall s i.
(FromData s, ToData s) =>
StateMachineInstance s i
-> Map TxOutRef DecoratedTxOut -> [OnChainState s i]
getStates @state @i StateMachineInstance state i
scInstance
                                         (Map TxOutRef DecoratedTxOut -> [OnChainState state i])
-> Map TxOutRef DecoratedTxOut -> [OnChainState state i]
forall a b. (a -> b) -> a -> b
$ [(TxOutRef, DecoratedTxOut)] -> Map TxOutRef DecoratedTxOut
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(TxOutRef, DecoratedTxOut)] -> Map TxOutRef DecoratedTxOut)
-> [(TxOutRef, DecoratedTxOut)] -> Map TxOutRef DecoratedTxOut
forall a b. (a -> b) -> a -> b
$ ((TxOutRef, (DecoratedTxOut, ChainIndexTx))
 -> (TxOutRef, DecoratedTxOut))
-> [(TxOutRef, (DecoratedTxOut, ChainIndexTx))]
-> [(TxOutRef, DecoratedTxOut)]
forall a b. (a -> b) -> [a] -> [b]
map (TxOutRef, (DecoratedTxOut, ChainIndexTx))
-> (TxOutRef, DecoratedTxOut)
forall a b b. (a, (b, b)) -> (a, b)
projectFst ([(TxOutRef, (DecoratedTxOut, ChainIndexTx))]
 -> [(TxOutRef, DecoratedTxOut)])
-> [(TxOutRef, (DecoratedTxOut, ChainIndexTx))]
-> [(TxOutRef, DecoratedTxOut)]
forall a b. (a -> b) -> a -> b
$ NonEmpty [(TxOutRef, (DecoratedTxOut, ChainIndexTx))]
-> [(TxOutRef, (DecoratedTxOut, ChainIndexTx))]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat NonEmpty [(TxOutRef, (DecoratedTxOut, ChainIndexTx))]
outRefMaps
                            case [OnChainState state i]
-> Either SMContractError (OnChainState state i)
scChooser [OnChainState state i]
produced of
                                Left SMContractError
e             -> AReview e SMContractError
-> SMContractError
-> Contract w schema e (WaitingResult t i (OnChainState state i))
forall e (m :: * -> *) t x.
MonadError e m =>
AReview e t -> t -> m x
throwing AReview e SMContractError
forall r. AsSMContractError r => Prism' r SMContractError
_SMContractError SMContractError
e
                                Right OnChainState state i
onChainState -> WaitingResult t i (OnChainState state i)
-> Contract w schema e (WaitingResult t i (OnChainState state i))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WaitingResult t i (OnChainState state i)
 -> Contract w schema e (WaitingResult t i (OnChainState state i)))
-> WaitingResult t i (OnChainState state i)
-> Contract w schema e (WaitingResult t i (OnChainState state i))
forall a b. (a -> b) -> a -> b
$ OnChainState state i -> WaitingResult t i (OnChainState state i)
forall t i s. s -> WaitingResult t i s
InitialState OnChainState state i
onChainState
                    Just (OnChainState{TypedScriptTxOutRef (StateMachine state i)
ocsTxOutRef :: TypedScriptTxOutRef (StateMachine state i)
ocsTxOutRef :: forall s i.
OnChainState s i -> TypedScriptTxOutRef (StateMachine s i)
ocsTxOutRef}, Map TxOutRef DecoratedTxOut
_) ->
                        Promise w schema e ChainIndexTx
-> (ChainIndexTx
    -> Contract w schema e (WaitingResult t i (OnChainState state i)))
-> Promise w schema e (WaitingResult t i (OnChainState state i))
forall w (s :: Row *) e a b.
Promise w s e a -> (a -> Contract w s e b) -> Promise w s e b
promiseBind (TxOutRef -> Promise w schema e ChainIndexTx
forall w (s :: Row *) e.
AsContractError e =>
TxOutRef -> Promise w s e ChainIndexTx
utxoIsSpent (TypedScriptTxOutRef (StateMachine state i) -> TxOutRef
forall a. TypedScriptTxOutRef a -> TxOutRef
Typed.tyTxOutRefRef TypedScriptTxOutRef (StateMachine state i)
ocsTxOutRef)) ((ChainIndexTx
  -> Contract w schema e (WaitingResult t i (OnChainState state i)))
 -> Promise w schema e (WaitingResult t i (OnChainState state i)))
-> (ChainIndexTx
    -> Contract w schema e (WaitingResult t i (OnChainState state i)))
-> Promise w schema e (WaitingResult t i (OnChainState state i))
forall a b. (a -> b) -> a -> b
$ \ChainIndexTx
txn -> do
                            Map TxOutRef DecoratedTxOut
outRefMap <- [(TxOutRef, DecoratedTxOut)] -> Map TxOutRef DecoratedTxOut
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(TxOutRef, DecoratedTxOut)] -> Map TxOutRef DecoratedTxOut)
-> ([(TxOutRef, (DecoratedTxOut, ChainIndexTx))]
    -> [(TxOutRef, DecoratedTxOut)])
-> [(TxOutRef, (DecoratedTxOut, ChainIndexTx))]
-> Map TxOutRef DecoratedTxOut
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TxOutRef, (DecoratedTxOut, ChainIndexTx))
 -> (TxOutRef, DecoratedTxOut))
-> [(TxOutRef, (DecoratedTxOut, ChainIndexTx))]
-> [(TxOutRef, DecoratedTxOut)]
forall a b. (a -> b) -> [a] -> [b]
map (TxOutRef, (DecoratedTxOut, ChainIndexTx))
-> (TxOutRef, DecoratedTxOut)
forall a b b. (a, (b, b)) -> (a, b)
projectFst ([(TxOutRef, (DecoratedTxOut, ChainIndexTx))]
 -> Map TxOutRef DecoratedTxOut)
-> Contract w schema e [(TxOutRef, (DecoratedTxOut, ChainIndexTx))]
-> Contract w schema e (Map TxOutRef DecoratedTxOut)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainIndexTx
-> Contract w schema e [(TxOutRef, (DecoratedTxOut, ChainIndexTx))]
forall e w (s :: Row *).
AsContractError e =>
ChainIndexTx
-> Contract w s e [(TxOutRef, (DecoratedTxOut, ChainIndexTx))]
utxosTxOutTxFromTx ChainIndexTx
txn
                            let newStates :: [OnChainState state i]
newStates = StateMachineInstance state i
-> Map TxOutRef DecoratedTxOut -> [OnChainState state i]
forall s i.
(FromData s, ToData s) =>
StateMachineInstance s i
-> Map TxOutRef DecoratedTxOut -> [OnChainState s i]
getStates @state @i StateMachineInstance state i
scInstance Map TxOutRef DecoratedTxOut
outRefMap
                                inp :: Maybe i
inp       = TxOutRef -> ChainIndexTx -> Maybe i
forall i. FromData i => TxOutRef -> ChainIndexTx -> Maybe i
getInput (TypedScriptTxOutRef (StateMachine state i) -> TxOutRef
forall a. TypedScriptTxOutRef a -> TxOutRef
Typed.tyTxOutRefRef TypedScriptTxOutRef (StateMachine state i)
ocsTxOutRef) ChainIndexTx
txn
                            case ([OnChainState state i]
newStates, Maybe i
inp) of
                                ([], Just i
i) -> WaitingResult t i (OnChainState state i)
-> Contract w schema e (WaitingResult t i (OnChainState state i))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (i -> WaitingResult t i (OnChainState state i)
forall t i s. i -> WaitingResult t i s
ContractEnded i
i)
                                ([OnChainState state i]
xs, Just i
i) -> case [OnChainState state i]
-> Either SMContractError (OnChainState state i)
scChooser [OnChainState state i]
xs of
                                    Left SMContractError
e         -> AReview e SMContractError
-> SMContractError
-> Contract w schema e (WaitingResult t i (OnChainState state i))
forall e (m :: * -> *) t x.
MonadError e m =>
AReview e t -> t -> m x
throwing AReview e SMContractError
forall r. AsSMContractError r => Prism' r SMContractError
_SMContractError SMContractError
e
                                    Right OnChainState state i
newState -> WaitingResult t i (OnChainState state i)
-> Contract w schema e (WaitingResult t i (OnChainState state i))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (i
-> OnChainState state i -> WaitingResult t i (OnChainState state i)
forall t i s. i -> s -> WaitingResult t i s
Transition i
i OnChainState state i
newState)
                                ([OnChainState state i], Maybe i)
_ -> AReview e ()
-> Contract w schema e (WaitingResult t i (OnChainState state i))
forall e (m :: * -> *) x. MonadError e m => AReview e () -> m x
throwing_ AReview e ()
forall r. AsSMContractError r => Prism' r ()
_UnableToExtractTransition
    Promise w schema e (WaitingResult t i (OnChainState state i))
-> Contract
     w
     schema
     e
     (Promise w schema e (WaitingResult t i (OnChainState state i)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Promise w schema e (WaitingResult t i (OnChainState state i))
 -> Contract
      w
      schema
      e
      (Promise w schema e (WaitingResult t i (OnChainState state i))))
-> Promise w schema e (WaitingResult t i (OnChainState state i))
-> Contract
     w
     schema
     e
     (Promise w schema e (WaitingResult t i (OnChainState state i)))
forall a b. (a -> b) -> a -> b
$ Promise w schema e (WaitingResult t i (OnChainState state i))
-> Promise w schema e (WaitingResult t i (OnChainState state i))
-> Promise w schema e (WaitingResult t i (OnChainState state i))
forall w (s :: Row *) e a.
Promise w s e a -> Promise w s e a -> Promise w s e a
select Promise w schema e (WaitingResult t i (OnChainState state i))
success (t -> WaitingResult t i (OnChainState state i)
forall t i s. t -> WaitingResult t i s
Timeout (t -> WaitingResult t i (OnChainState state i))
-> Promise w schema e t
-> Promise w schema e (WaitingResult t i (OnChainState state i))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Promise w schema e t
timeout)

-- | Tries to run one step of a state machine: If the /guard/ (the last argument) returns @'Nothing'@ when given the
-- unbalanced transaction to be submitted, the old state and the new step, the step is run and @'Right'@ the new state is returned.
-- If the guard returns @'Just' a@, @'Left' a@ is returned instead.
runGuardedStep ::
    forall w a e state schema input.
    ( AsSMContractError e
    , PlutusTx.FromData state
    , PlutusTx.ToData state
    , PlutusTx.ToData input
    )
    => StateMachineClient state input              -- ^ The state machine
    -> input                                       -- ^ The input to apply to the state machine
    -> (UnbalancedTx -> state -> state -> Maybe a) -- ^ The guard to check before running the step
    -> Contract w schema e (Either a (TransitionResult state input))
runGuardedStep :: StateMachineClient state input
-> input
-> (UnbalancedTx -> state -> state -> Maybe a)
-> Contract w schema e (Either a (TransitionResult state input))
runGuardedStep = ScriptLookups (StateMachine state input)
-> TxConstraints input state
-> StateMachineClient state input
-> input
-> (UnbalancedTx -> state -> state -> Maybe a)
-> Contract w schema e (Either a (TransitionResult state input))
forall w a e state (schema :: Row *) input.
(AsSMContractError e, FromData state, ToData state,
 ToData input) =>
ScriptLookups (StateMachine state input)
-> TxConstraints input state
-> StateMachineClient state input
-> input
-> (UnbalancedTx -> state -> state -> Maybe a)
-> Contract w schema e (Either a (TransitionResult state input))
runGuardedStepWith ScriptLookups (StateMachine state input)
forall a. Monoid a => a
mempty TxConstraints input state
forall a. Monoid a => a
mempty

-- | Run one step of a state machine, returning the new state.
runStep ::
    forall w e state schema input.
    ( AsSMContractError e
    , PlutusTx.FromData state
    , PlutusTx.ToData state
    , PlutusTx.ToData input
    )
    => StateMachineClient state input
    -- ^ The state machine
    -> input
    -- ^ The input to apply to the state machine
    -> Contract w schema e (TransitionResult state input)
runStep :: StateMachineClient state input
-> input -> Contract w schema e (TransitionResult state input)
runStep = ScriptLookups (StateMachine state input)
-> TxConstraints input state
-> StateMachineClient state input
-> input
-> Contract w schema e (TransitionResult state input)
forall w e state (schema :: Row *) input.
(AsSMContractError e, FromData state, ToData state,
 ToData input) =>
ScriptLookups (StateMachine state input)
-> TxConstraints input state
-> StateMachineClient state input
-> input
-> Contract w schema e (TransitionResult state input)
runStepWith ScriptLookups (StateMachine state input)
forall a. Monoid a => a
mempty TxConstraints input state
forall a. Monoid a => a
mempty

-- | Create a thread token. The thread token contains a reference to an unspent output of the wallet,
-- so it needs to used with 'mkStateMachine' immediately, and the machine must be initialised,
-- to prevent the output from getting spent in the mean time.
getThreadToken :: AsSMContractError e => Contract w schema e ThreadToken
getThreadToken :: Contract w schema e ThreadToken
getThreadToken = (SMContractError -> e)
-> Contract w schema SMContractError ThreadToken
-> Contract w schema e ThreadToken
forall w (s :: Row *) e e' a.
(e -> e') -> Contract w s e a -> Contract w s e' a
mapError (AReview e SMContractError -> SMContractError -> e
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review AReview e SMContractError
forall r. AsSMContractError r => Prism' r SMContractError
_SMContractError) (Contract w schema SMContractError ThreadToken
 -> Contract w schema e ThreadToken)
-> Contract w schema SMContractError ThreadToken
-> Contract w schema e ThreadToken
forall a b. (a -> b) -> a -> b
$ do
    TxOutRef
txOutRef <- Contract w schema SMContractError TxOutRef
forall e w (s :: Row *).
AsContractError e =>
Contract w s e TxOutRef
getUnspentOutput
    ThreadToken -> Contract w schema SMContractError ThreadToken
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ThreadToken -> Contract w schema SMContractError ThreadToken)
-> ThreadToken -> Contract w schema SMContractError ThreadToken
forall a b. (a -> b) -> a -> b
$ TxOutRef -> CurrencySymbol -> ThreadToken
ThreadToken TxOutRef
txOutRef (MintingPolicy -> CurrencySymbol
scriptCurrencySymbol (TxOutRef -> MintingPolicy
curPolicy TxOutRef
txOutRef))

-- | Initialise a state machine
runInitialise ::
    forall w e state schema input.
    ( PlutusTx.FromData state
    , PlutusTx.ToData state
    , PlutusTx.ToData input
    , AsSMContractError e
    )
    => StateMachineClient state input
    -- ^ The state machine
    -> state
    -- ^ The initial state
    -> Value
    -- ^ The value locked by the contract at the beginning
    -> Contract w schema e state
runInitialise :: StateMachineClient state input
-> state -> Value -> Contract w schema e state
runInitialise = ScriptLookups (StateMachine state input)
-> TxConstraints input state
-> StateMachineClient state input
-> state
-> Value
-> Contract w schema e state
forall w e state (schema :: Row *) input.
(FromData state, ToData state, ToData input,
 AsSMContractError e) =>
ScriptLookups (StateMachine state input)
-> TxConstraints input state
-> StateMachineClient state input
-> state
-> Value
-> Contract w schema e state
runInitialiseWith ScriptLookups (StateMachine state input)
forall a. Monoid a => a
mempty TxConstraints input state
forall a. Monoid a => a
mempty

-- | Constraints & lookups needed to transition a state machine instance
data StateMachineTransition state input =
    StateMachineTransition
        { StateMachineTransition state input -> TxConstraints input state
smtConstraints :: TxConstraints input state
        , StateMachineTransition state input -> State state
smtOldState    :: State state
        , StateMachineTransition state input -> State state
smtNewState    :: State state
        , StateMachineTransition state input
-> ScriptLookups (StateMachine state input)
smtLookups     :: ScriptLookups (StateMachine state input)
        }

-- | Initialise a state machine and supply additional constraints and lookups for transaction.
runInitialiseWith ::
    forall w e state schema input.
    ( PlutusTx.FromData state
    , PlutusTx.ToData state
    , PlutusTx.ToData input
    , AsSMContractError e
    )
    => ScriptLookups (StateMachine state input)
    -- ^ Additional lookups
    -> TxConstraints input state
    -- ^ Additional constraints
    -> StateMachineClient state input
    -- ^ The state machine
    -> state
    -- ^ The initial state
    -> Value
    -- ^ The value locked by the contract at the beginning
    -> Contract w schema e state
runInitialiseWith :: ScriptLookups (StateMachine state input)
-> TxConstraints input state
-> StateMachineClient state input
-> state
-> Value
-> Contract w schema e state
runInitialiseWith ScriptLookups (StateMachine state input)
customLookups TxConstraints input state
customConstraints StateMachineClient{StateMachineInstance state input
scInstance :: StateMachineInstance state input
scInstance :: forall s i. StateMachineClient s i -> StateMachineInstance s i
scInstance} state
initialState Value
initialValue =
    (SMContractError -> e)
-> Contract w schema SMContractError state
-> Contract w schema e state
forall w (s :: Row *) e e' a.
(e -> e') -> Contract w s e a -> Contract w s e' a
mapError (AReview e SMContractError -> SMContractError -> e
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review AReview e SMContractError
forall r. AsSMContractError r => Prism' r SMContractError
_SMContractError) (Contract w schema SMContractError state
 -> Contract w schema e state)
-> Contract w schema SMContractError state
-> Contract w schema e state
forall a b. (a -> b) -> a -> b
$ do
      Map TxOutRef DecoratedTxOut
utxo <- Contract w schema SMContractError (Map TxOutRef DecoratedTxOut)
forall w (s :: Row *) e.
AsContractError e =>
Contract w s e (Map TxOutRef DecoratedTxOut)
ownUtxos
      let StateMachineInstance{StateMachine state input
stateMachine :: StateMachine state input
stateMachine :: forall s i. StateMachineInstance s i -> StateMachine s i
stateMachine, TypedValidator (StateMachine state input)
typedValidator :: TypedValidator (StateMachine state input)
typedValidator :: forall s i.
StateMachineInstance s i -> TypedValidator (StateMachine s i)
typedValidator} = StateMachineInstance state input
scInstance
          constraints :: TxConstraints input state
constraints =
              state -> Value -> TxConstraints input state
forall o i. o -> Value -> TxConstraints i o
mustPayToTheScriptWithInlineDatum
                state
initialState
                (Value
initialValue Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> StateMachineInstance state input -> Value
forall s i. StateMachineInstance s i -> Value
SM.threadTokenValueOrZero StateMachineInstance state input
scInstance)
              TxConstraints input state
-> TxConstraints input state -> TxConstraints input state
forall a. Semigroup a => a -> a -> a
<> (ThreadToken -> TxConstraints input state)
-> Maybe ThreadToken -> TxConstraints input state
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ThreadToken -> TxConstraints input state
ttConstraints (StateMachine state input -> Maybe ThreadToken
forall s i. StateMachine s i -> Maybe ThreadToken
smThreadToken StateMachine state input
stateMachine)
              TxConstraints input state
-> TxConstraints input state -> TxConstraints input state
forall a. Semigroup a => a -> a -> a
<> TxConstraints input state
customConstraints
          red :: Redeemer
red = BuiltinData -> Redeemer
Ledger.Redeemer ((ValidatorHash, MintingPolarity) -> BuiltinData
forall a. ToData a => a -> BuiltinData
PlutusTx.toBuiltinData (TypedValidator (StateMachine state input) -> ValidatorHash
forall a. TypedValidator a -> ValidatorHash
Scripts.validatorHash TypedValidator (StateMachine state input)
typedValidator, MintingPolarity
Mint))
          ttConstraints :: ThreadToken -> TxConstraints input state
ttConstraints ThreadToken{TxOutRef
ttOutRef :: TxOutRef
ttOutRef :: ThreadToken -> TxOutRef
ttOutRef} =
              Redeemer -> Value -> TxConstraints input state
forall i o. Redeemer -> Value -> TxConstraints i o
mustMintValueWithRedeemer Redeemer
red (StateMachineInstance state input -> Value
forall s i. StateMachineInstance s i -> Value
SM.threadTokenValueOrZero StateMachineInstance state input
scInstance)
              TxConstraints input state
-> TxConstraints input state -> TxConstraints input state
forall a. Semigroup a => a -> a -> a
<> TxOutRef -> TxConstraints input state
forall i o. TxOutRef -> TxConstraints i o
mustSpendPubKeyOutput TxOutRef
ttOutRef
          lookups :: ScriptLookups (StateMachine state input)
lookups = TypedValidator (StateMachine state input)
-> ScriptLookups (StateMachine state input)
forall a. TypedValidator a -> ScriptLookups a
Constraints.typedValidatorLookups TypedValidator (StateMachine state input)
typedValidator
              ScriptLookups (StateMachine state input)
-> ScriptLookups (StateMachine state input)
-> ScriptLookups (StateMachine state input)
forall a. Semigroup a => a -> a -> a
<> (ThreadToken -> ScriptLookups (StateMachine state input))
-> Maybe ThreadToken -> ScriptLookups (StateMachine state input)
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (MintingPolicy -> ScriptLookups (StateMachine state input)
forall a. MintingPolicy -> ScriptLookups a
plutusV2MintingPolicy (MintingPolicy -> ScriptLookups (StateMachine state input))
-> (ThreadToken -> MintingPolicy)
-> ThreadToken
-> ScriptLookups (StateMachine state input)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOutRef -> MintingPolicy
curPolicy (TxOutRef -> MintingPolicy)
-> (ThreadToken -> TxOutRef) -> ThreadToken -> MintingPolicy
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThreadToken -> TxOutRef
ttOutRef) (StateMachine state input -> Maybe ThreadToken
forall s i. StateMachine s i -> Maybe ThreadToken
smThreadToken StateMachine state input
stateMachine)
              ScriptLookups (StateMachine state input)
-> ScriptLookups (StateMachine state input)
-> ScriptLookups (StateMachine state input)
forall a. Semigroup a => a -> a -> a
<> Map TxOutRef DecoratedTxOut
-> ScriptLookups (StateMachine state input)
forall a. Map TxOutRef DecoratedTxOut -> ScriptLookups a
Constraints.unspentOutputs Map TxOutRef DecoratedTxOut
utxo
              ScriptLookups (StateMachine state input)
-> ScriptLookups (StateMachine state input)
-> ScriptLookups (StateMachine state input)
forall a. Semigroup a => a -> a -> a
<> ScriptLookups (StateMachine state input)
customLookups
      UnbalancedTx
utx <- ScriptLookups (StateMachine state input)
-> TxConstraints
     (RedeemerType (StateMachine state input))
     (DatumType (StateMachine state input))
-> Contract w schema SMContractError UnbalancedTx
forall a w (s :: Row *) e.
(ToData (RedeemerType a), FromData (DatumType a),
 ToData (DatumType a), AsContractError e) =>
ScriptLookups a
-> TxConstraints (RedeemerType a) (DatumType a)
-> Contract w s e UnbalancedTx
mkTxConstraints ScriptLookups (StateMachine state input)
lookups TxConstraints input state
TxConstraints
  (RedeemerType (StateMachine state input))
  (DatumType (StateMachine state input))
constraints
      UnbalancedTx
adjustedUtx <- UnbalancedTx -> Contract w schema SMContractError UnbalancedTx
forall w (s :: Row *) e.
AsContractError e =>
UnbalancedTx -> Contract w s e UnbalancedTx
adjustUnbalancedTx UnbalancedTx
utx
      Bool
-> Contract w schema SMContractError ()
-> Contract w schema SMContractError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (UnbalancedTx
utx UnbalancedTx -> UnbalancedTx -> Bool
forall a. Eq a => a -> a -> Bool
== UnbalancedTx
adjustedUtx) (Contract w schema SMContractError ()
 -> Contract w schema SMContractError ())
-> Contract w schema SMContractError ()
-> Contract w schema SMContractError ()
forall a b. (a -> b) -> a -> b
$
        forall a w (s :: Row *) e. ToJSON a => a -> Contract w s e ()
forall w (s :: Row *) e. ToJSON Text => Text -> Contract w s e ()
logWarn @Text (Text -> Contract w schema SMContractError ())
-> Text -> Contract w schema SMContractError ()
forall a b. (a -> b) -> a -> b
$ Text
"Plutus.Contract.StateMachine.runInitialise: "
                      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"Found a transaction output value with less than the minimum amount of Ada. Adjusting ..."
      UnbalancedTx -> Contract w schema SMContractError ()
forall w (s :: Row *) e.
AsContractError e =>
UnbalancedTx -> Contract w s e ()
submitTxConfirmed UnbalancedTx
adjustedUtx
      state -> Contract w schema SMContractError state
forall (f :: * -> *) a. Applicative f => a -> f a
pure state
initialState

-- | Run one step of a state machine, returning the new state. We can supply additional constraints and lookups for transaction.
runStepWith ::
    forall w e state schema input.
    ( AsSMContractError e
    , PlutusTx.FromData state
    , PlutusTx.ToData state
    , PlutusTx.ToData input
    )
    => ScriptLookups (StateMachine state input)
    -- ^ Additional lookups
    -> TxConstraints input state
    -- ^ Additional constraints
    -> StateMachineClient state input
    -- ^ The state machine
    -> input
    -- ^ The input to apply to the state machine
    -> Contract w schema e (TransitionResult state input)
runStepWith :: ScriptLookups (StateMachine state input)
-> TxConstraints input state
-> StateMachineClient state input
-> input
-> Contract w schema e (TransitionResult state input)
runStepWith ScriptLookups (StateMachine state input)
lookups TxConstraints input state
constraints StateMachineClient state input
smc input
input =
    ScriptLookups (StateMachine state input)
-> TxConstraints input state
-> StateMachineClient state input
-> input
-> (UnbalancedTx -> state -> state -> Maybe Void)
-> Contract w schema e (Either Void (TransitionResult state input))
forall w a e state (schema :: Row *) input.
(AsSMContractError e, FromData state, ToData state,
 ToData input) =>
ScriptLookups (StateMachine state input)
-> TxConstraints input state
-> StateMachineClient state input
-> input
-> (UnbalancedTx -> state -> state -> Maybe a)
-> Contract w schema e (Either a (TransitionResult state input))
runGuardedStepWith ScriptLookups (StateMachine state input)
lookups TxConstraints input state
constraints StateMachineClient state input
smc input
input (\UnbalancedTx
_ state
_ state
_ -> Maybe Void
forall a. Maybe a
Nothing) Contract w schema e (Either Void (TransitionResult state input))
-> (Either Void (TransitionResult state input)
    -> Contract w schema e (TransitionResult state input))
-> Contract w schema e (TransitionResult state input)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TransitionResult state input
-> Contract w schema e (TransitionResult state input)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TransitionResult state input
 -> Contract w schema e (TransitionResult state input))
-> (Either Void (TransitionResult state input)
    -> TransitionResult state input)
-> Either Void (TransitionResult state input)
-> Contract w schema e (TransitionResult state input)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
        Left Void
a  -> Void -> TransitionResult state input
forall a. Void -> a
absurd Void
a
        Right TransitionResult state input
a -> TransitionResult state input
a

-- | The same as 'runGuardedStep' but we can supply additional constraints and lookups for transaction.
runGuardedStepWith ::
    forall w a e state schema input.
    ( AsSMContractError e
    , PlutusTx.FromData state
    , PlutusTx.ToData state
    , PlutusTx.ToData input
    )
    => ScriptLookups (StateMachine state input)    -- ^ Additional lookups
    -> TxConstraints input state                   -- ^ Additional constraints
    -> StateMachineClient state input              -- ^ The state machine
    -> input                                       -- ^ The input to apply to the state machine
    -> (UnbalancedTx -> state -> state -> Maybe a) -- ^ The guard to check before running the step
    -> Contract w schema e (Either a (TransitionResult state input))
runGuardedStepWith :: ScriptLookups (StateMachine state input)
-> TxConstraints input state
-> StateMachineClient state input
-> input
-> (UnbalancedTx -> state -> state -> Maybe a)
-> Contract w schema e (Either a (TransitionResult state input))
runGuardedStepWith ScriptLookups (StateMachine state input)
userLookups TxConstraints input state
userConstraints StateMachineClient state input
smc input
input UnbalancedTx -> state -> state -> Maybe a
guard =
  (SMContractError -> e)
-> Contract
     w schema SMContractError (Either a (TransitionResult state input))
-> Contract w schema e (Either a (TransitionResult state input))
forall w (s :: Row *) e e' a.
(e -> e') -> Contract w s e a -> Contract w s e' a
mapError (AReview e SMContractError -> SMContractError -> e
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review AReview e SMContractError
forall r. AsSMContractError r => Prism' r SMContractError
_SMContractError) (Contract
   w schema SMContractError (Either a (TransitionResult state input))
 -> Contract w schema e (Either a (TransitionResult state input)))
-> Contract
     w schema SMContractError (Either a (TransitionResult state input))
-> Contract w schema e (Either a (TransitionResult state input))
forall a b. (a -> b) -> a -> b
$ StateMachineClient state input
-> input
-> Contract
     w
     schema
     SMContractError
     (Either
        (InvalidTransition state input)
        (StateMachineTransition state input))
forall w e state (schema :: Row *) input.
(AsSMContractError e, FromData state, ToData state) =>
StateMachineClient state input
-> input
-> Contract
     w
     schema
     e
     (Either
        (InvalidTransition state input)
        (StateMachineTransition state input))
mkStep StateMachineClient state input
smc input
input Contract
  w
  schema
  SMContractError
  (Either
     (InvalidTransition state input)
     (StateMachineTransition state input))
-> (Either
      (InvalidTransition state input)
      (StateMachineTransition state input)
    -> Contract
         w schema SMContractError (Either a (TransitionResult state input)))
-> Contract
     w schema SMContractError (Either a (TransitionResult state input))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Right StateMachineTransition{TxConstraints input state
smtConstraints :: TxConstraints input state
smtConstraints :: forall state input.
StateMachineTransition state input -> TxConstraints input state
smtConstraints,smtOldState :: forall state input.
StateMachineTransition state input -> State state
smtOldState=State{stateData :: forall s. State s -> s
stateData=state
os}, smtNewState :: forall state input.
StateMachineTransition state input -> State state
smtNewState=State{stateData :: forall s. State s -> s
stateData=state
ns}, ScriptLookups (StateMachine state input)
smtLookups :: ScriptLookups (StateMachine state input)
smtLookups :: forall state input.
StateMachineTransition state input
-> ScriptLookups (StateMachine state input)
smtLookups} -> do
        PaymentPubKeyHash
pk <- Contract w schema SMContractError PaymentPubKeyHash
forall w (s :: Row *) e.
AsContractError e =>
Contract w s e PaymentPubKeyHash
ownFirstPaymentPubKeyHash
        let lookups :: ScriptLookups (StateMachine state input)
lookups = ScriptLookups (StateMachine state input)
smtLookups { slOwnPaymentPubKeyHash :: Maybe PaymentPubKeyHash
Constraints.slOwnPaymentPubKeyHash = PaymentPubKeyHash -> Maybe PaymentPubKeyHash
forall a. a -> Maybe a
Just PaymentPubKeyHash
pk }
        UnbalancedTx
utx <- ScriptLookups (StateMachine state input)
-> TxConstraints
     (RedeemerType (StateMachine state input))
     (DatumType (StateMachine state input))
-> Contract w schema SMContractError UnbalancedTx
forall a w (s :: Row *) e.
(ToData (RedeemerType a), FromData (DatumType a),
 ToData (DatumType a), AsContractError e) =>
ScriptLookups a
-> TxConstraints (RedeemerType a) (DatumType a)
-> Contract w s e UnbalancedTx
mkTxConstraints (ScriptLookups (StateMachine state input)
lookups ScriptLookups (StateMachine state input)
-> ScriptLookups (StateMachine state input)
-> ScriptLookups (StateMachine state input)
forall a. Semigroup a => a -> a -> a
<> ScriptLookups (StateMachine state input)
userLookups) (TxConstraints input state
smtConstraints TxConstraints input state
-> TxConstraints input state -> TxConstraints input state
forall a. Semigroup a => a -> a -> a
<> TxConstraints input state
userConstraints)
        UnbalancedTx
adjustedUtx <- UnbalancedTx -> Contract w schema SMContractError UnbalancedTx
forall w (s :: Row *) e.
AsContractError e =>
UnbalancedTx -> Contract w s e UnbalancedTx
adjustUnbalancedTx UnbalancedTx
utx
        Bool
-> Contract w schema SMContractError ()
-> Contract w schema SMContractError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (UnbalancedTx
utx UnbalancedTx -> UnbalancedTx -> Bool
forall a. Eq a => a -> a -> Bool
== UnbalancedTx
adjustedUtx) (Contract w schema SMContractError ()
 -> Contract w schema SMContractError ())
-> Contract w schema SMContractError ()
-> Contract w schema SMContractError ()
forall a b. (a -> b) -> a -> b
$
          forall a w (s :: Row *) e. ToJSON a => a -> Contract w s e ()
forall w (s :: Row *) e. ToJSON Text => Text -> Contract w s e ()
logWarn @Text (Text -> Contract w schema SMContractError ())
-> Text -> Contract w schema SMContractError ()
forall a b. (a -> b) -> a -> b
$ Text
"Plutus.Contract.StateMachine.runStep: "
                       Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"Found a transaction output value with less than the minimum amount of Ada. Adjusting ..."
        case UnbalancedTx -> state -> state -> Maybe a
guard UnbalancedTx
adjustedUtx state
os state
ns of
            Maybe a
Nothing -> do
                UnbalancedTx -> Contract w schema SMContractError ()
forall w (s :: Row *) e.
AsContractError e =>
UnbalancedTx -> Contract w s e ()
submitTxConfirmed UnbalancedTx
adjustedUtx
                Either a (TransitionResult state input)
-> Contract
     w schema SMContractError (Either a (TransitionResult state input))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either a (TransitionResult state input)
 -> Contract
      w schema SMContractError (Either a (TransitionResult state input)))
-> Either a (TransitionResult state input)
-> Contract
     w schema SMContractError (Either a (TransitionResult state input))
forall a b. (a -> b) -> a -> b
$ TransitionResult state input
-> Either a (TransitionResult state input)
forall a b. b -> Either a b
Right (TransitionResult state input
 -> Either a (TransitionResult state input))
-> TransitionResult state input
-> Either a (TransitionResult state input)
forall a b. (a -> b) -> a -> b
$ state -> TransitionResult state input
forall s i. s -> TransitionResult s i
TransitionSuccess state
ns
            Just a
a  -> Either a (TransitionResult state input)
-> Contract
     w schema SMContractError (Either a (TransitionResult state input))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either a (TransitionResult state input)
 -> Contract
      w schema SMContractError (Either a (TransitionResult state input)))
-> Either a (TransitionResult state input)
-> Contract
     w schema SMContractError (Either a (TransitionResult state input))
forall a b. (a -> b) -> a -> b
$ a -> Either a (TransitionResult state input)
forall a b. a -> Either a b
Left a
a
    Left InvalidTransition state input
e -> Either a (TransitionResult state input)
-> Contract
     w schema SMContractError (Either a (TransitionResult state input))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either a (TransitionResult state input)
 -> Contract
      w schema SMContractError (Either a (TransitionResult state input)))
-> Either a (TransitionResult state input)
-> Contract
     w schema SMContractError (Either a (TransitionResult state input))
forall a b. (a -> b) -> a -> b
$ TransitionResult state input
-> Either a (TransitionResult state input)
forall a b. b -> Either a b
Right (TransitionResult state input
 -> Either a (TransitionResult state input))
-> TransitionResult state input
-> Either a (TransitionResult state input)
forall a b. (a -> b) -> a -> b
$ InvalidTransition state input -> TransitionResult state input
forall s i. InvalidTransition s i -> TransitionResult s i
TransitionFailure InvalidTransition state input
e

-- | Given a state machine client and an input to apply to
--   the client's state machine instance, compute the 'StateMachineTransition'
--   that can produce an actual transaction performing the transition
mkStep ::
    forall w e state schema input.
    ( AsSMContractError e
    , PlutusTx.FromData state
    , PlutusTx.ToData state
    )
    => StateMachineClient state input
    -> input
    -> Contract w schema e (Either (InvalidTransition state input) (StateMachineTransition state input))
mkStep :: StateMachineClient state input
-> input
-> Contract
     w
     schema
     e
     (Either
        (InvalidTransition state input)
        (StateMachineTransition state input))
mkStep client :: StateMachineClient state input
client@StateMachineClient{StateMachineInstance state input
scInstance :: StateMachineInstance state input
scInstance :: forall s i. StateMachineClient s i -> StateMachineInstance s i
scInstance} input
input = do
    let StateMachineInstance{StateMachine state input
stateMachine :: StateMachine state input
stateMachine :: forall s i. StateMachineInstance s i -> StateMachine s i
stateMachine, TypedValidator (StateMachine state input)
typedValidator :: TypedValidator (StateMachine state input)
typedValidator :: forall s i.
StateMachineInstance s i -> TypedValidator (StateMachine s i)
typedValidator} = StateMachineInstance state input
scInstance
        StateMachine{State state
-> input -> Maybe (TxConstraints Void Void, State state)
smTransition :: State state
-> input -> Maybe (TxConstraints Void Void, State state)
smTransition :: forall s i.
StateMachine s i
-> State s -> i -> Maybe (TxConstraints Void Void, State s)
smTransition} = StateMachine state input
stateMachine
    Maybe (OnChainState state input, Map TxOutRef DecoratedTxOut)
maybeState <- StateMachineClient state input
-> Contract
     w
     schema
     e
     (Maybe (OnChainState state input, Map TxOutRef DecoratedTxOut))
forall e state i w (schema :: Row *).
(AsSMContractError e, FromData state, ToData state) =>
StateMachineClient state i
-> Contract
     w
     schema
     e
     (Maybe (OnChainState state i, Map TxOutRef DecoratedTxOut))
getOnChainState StateMachineClient state input
client
    case Maybe (OnChainState state input, Map TxOutRef DecoratedTxOut)
maybeState of
        Maybe (OnChainState state input, Map TxOutRef DecoratedTxOut)
Nothing -> Either
  (InvalidTransition state input)
  (StateMachineTransition state input)
-> Contract
     w
     schema
     e
     (Either
        (InvalidTransition state input)
        (StateMachineTransition state input))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
   (InvalidTransition state input)
   (StateMachineTransition state input)
 -> Contract
      w
      schema
      e
      (Either
         (InvalidTransition state input)
         (StateMachineTransition state input)))
-> Either
     (InvalidTransition state input)
     (StateMachineTransition state input)
-> Contract
     w
     schema
     e
     (Either
        (InvalidTransition state input)
        (StateMachineTransition state input))
forall a b. (a -> b) -> a -> b
$ InvalidTransition state input
-> Either
     (InvalidTransition state input)
     (StateMachineTransition state input)
forall a b. a -> Either a b
Left (InvalidTransition state input
 -> Either
      (InvalidTransition state input)
      (StateMachineTransition state input))
-> InvalidTransition state input
-> Either
     (InvalidTransition state input)
     (StateMachineTransition state input)
forall a b. (a -> b) -> a -> b
$ Maybe (State state) -> input -> InvalidTransition state input
forall s i. Maybe (State s) -> i -> InvalidTransition s i
InvalidTransition Maybe (State state)
forall a. Maybe a
Nothing input
input
        Just (OnChainState state input
onChainState, Map TxOutRef DecoratedTxOut
utxo) -> do
            let OnChainState{TypedScriptTxOutRef (StateMachine state input)
ocsTxOutRef :: TypedScriptTxOutRef (StateMachine state input)
ocsTxOutRef :: forall s i.
OnChainState s i -> TypedScriptTxOutRef (StateMachine s i)
ocsTxOutRef} = OnChainState state input
onChainState
                oldState :: State state
oldState = State :: forall s. s -> Value -> State s
State
                    { stateData :: state
stateData = OnChainState state input -> state
forall s i. OnChainState s i -> s
getStateData OnChainState state input
onChainState
                      -- Hide the thread token value from the client code
                    , stateValue :: Value
stateValue = TxOut -> Value
V2.txOutValue (TypedScriptTxOut (StateMachine state input) -> TxOut
forall a. TypedScriptTxOut a -> TxOut
Typed.tyTxOutTxOut (TypedScriptTxOut (StateMachine state input) -> TxOut)
-> TypedScriptTxOut (StateMachine state input) -> TxOut
forall a b. (a -> b) -> a -> b
$ TypedScriptTxOutRef (StateMachine state input)
-> TypedScriptTxOut (StateMachine state input)
forall a. TypedScriptTxOutRef a -> TypedScriptTxOut a
Typed.tyTxOutRefOut TypedScriptTxOutRef (StateMachine state input)
ocsTxOutRef) Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value -> Value
forall a. Group a => a -> a
inv (StateMachineInstance state input -> Value
forall s i. StateMachineInstance s i -> Value
SM.threadTokenValueOrZero StateMachineInstance state input
scInstance)
                    }
                inputConstraints :: TxConstraints input Any
inputConstraints = TxOutRef -> input -> TxConstraints input Any
forall i o. TxOutRef -> i -> TxConstraints i o
mustSpendOutputFromTheScript (TypedScriptTxOutRef (StateMachine state input) -> TxOutRef
forall a. TypedScriptTxOutRef a -> TxOutRef
Typed.tyTxOutRefRef TypedScriptTxOutRef (StateMachine state input)
ocsTxOutRef) input
input

            case State state
-> input -> Maybe (TxConstraints Void Void, State state)
smTransition State state
oldState input
input of
                Just (TxConstraints Void Void
newConstraints, State state
newState)  ->
                    let isFinal :: Bool
isFinal = StateMachine state input -> state -> Bool
forall s i. StateMachine s i -> s -> Bool
smFinal StateMachine state input
stateMachine (State state -> state
forall s. State s -> s
stateData State state
newState)
                        lookups :: ScriptLookups (StateMachine state input)
lookups =
                            TypedValidator (StateMachine state input)
-> ScriptLookups (StateMachine state input)
forall a. TypedValidator a -> ScriptLookups a
Constraints.typedValidatorLookups TypedValidator (StateMachine state input)
typedValidator
                            ScriptLookups (StateMachine state input)
-> ScriptLookups (StateMachine state input)
-> ScriptLookups (StateMachine state input)
forall a. Semigroup a => a -> a -> a
<> Map TxOutRef DecoratedTxOut
-> ScriptLookups (StateMachine state input)
forall a. Map TxOutRef DecoratedTxOut -> ScriptLookups a
Constraints.unspentOutputs Map TxOutRef DecoratedTxOut
utxo
                            ScriptLookups (StateMachine state input)
-> ScriptLookups (StateMachine state input)
-> ScriptLookups (StateMachine state input)
forall a. Semigroup a => a -> a -> a
<> if Bool
isFinal then (ThreadToken -> ScriptLookups (StateMachine state input))
-> Maybe ThreadToken -> ScriptLookups (StateMachine state input)
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (MintingPolicy -> ScriptLookups (StateMachine state input)
forall a. MintingPolicy -> ScriptLookups a
plutusV2MintingPolicy (MintingPolicy -> ScriptLookups (StateMachine state input))
-> (ThreadToken -> MintingPolicy)
-> ThreadToken
-> ScriptLookups (StateMachine state input)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOutRef -> MintingPolicy
curPolicy (TxOutRef -> MintingPolicy)
-> (ThreadToken -> TxOutRef) -> ThreadToken -> MintingPolicy
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThreadToken -> TxOutRef
ttOutRef) (StateMachine state input -> Maybe ThreadToken
forall s i. StateMachine s i -> Maybe ThreadToken
smThreadToken StateMachine state input
stateMachine) else ScriptLookups (StateMachine state input)
forall a. Monoid a => a
mempty
                        red :: Redeemer
red = BuiltinData -> Redeemer
Ledger.Redeemer ((ValidatorHash, MintingPolarity) -> BuiltinData
forall a. ToData a => a -> BuiltinData
PlutusTx.toBuiltinData (TypedValidator (StateMachine state input) -> ValidatorHash
forall a. TypedValidator a -> ValidatorHash
Scripts.validatorHash TypedValidator (StateMachine state input)
typedValidator, MintingPolarity
Burn))
                        unmint :: TxConstraints Void Void
unmint = if Bool
isFinal then Redeemer -> Value -> TxConstraints Void Void
forall i o. Redeemer -> Value -> TxConstraints i o
mustMintValueWithRedeemer Redeemer
red (Value -> Value
forall a. Group a => a -> a
inv (Value -> Value) -> Value -> Value
forall a b. (a -> b) -> a -> b
$ StateMachineInstance state input -> Value
forall s i. StateMachineInstance s i -> Value
SM.threadTokenValueOrZero StateMachineInstance state input
scInstance) else TxConstraints Void Void
forall a. Monoid a => a
mempty
                        -- Add the thread token value back to the output
                        valueWithToken :: Value
valueWithToken = State state -> Value
forall s. State s -> Value
stateValue State state
newState Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> StateMachineInstance state input -> Value
forall s i. StateMachineInstance s i -> Value
SM.threadTokenValueOrZero StateMachineInstance state input
scInstance
                        outputConstraints :: TxConstraints Any state
outputConstraints = if Bool
isFinal then TxConstraints Any state
forall a. Monoid a => a
mempty else state -> Value -> TxConstraints Any state
forall o i. o -> Value -> TxConstraints i o
mustPayToTheScriptWithInlineDatum (State state -> state
forall s. State s -> s
stateData State state
newState) Value
valueWithToken
                    in Either
  (InvalidTransition state input)
  (StateMachineTransition state input)
-> Contract
     w
     schema
     e
     (Either
        (InvalidTransition state input)
        (StateMachineTransition state input))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                        (Either
   (InvalidTransition state input)
   (StateMachineTransition state input)
 -> Contract
      w
      schema
      e
      (Either
         (InvalidTransition state input)
         (StateMachineTransition state input)))
-> Either
     (InvalidTransition state input)
     (StateMachineTransition state input)
-> Contract
     w
     schema
     e
     (Either
        (InvalidTransition state input)
        (StateMachineTransition state input))
forall a b. (a -> b) -> a -> b
$ StateMachineTransition state input
-> Either
     (InvalidTransition state input)
     (StateMachineTransition state input)
forall a b. b -> Either a b
Right
                        (StateMachineTransition state input
 -> Either
      (InvalidTransition state input)
      (StateMachineTransition state input))
-> StateMachineTransition state input
-> Either
     (InvalidTransition state input)
     (StateMachineTransition state input)
forall a b. (a -> b) -> a -> b
$ StateMachineTransition :: forall state input.
TxConstraints input state
-> State state
-> State state
-> ScriptLookups (StateMachine state input)
-> StateMachineTransition state input
StateMachineTransition
                            { smtConstraints :: TxConstraints input state
smtConstraints =
                                (TxConstraints Void Void
newConstraints TxConstraints Void Void
-> TxConstraints Void Void -> TxConstraints Void Void
forall a. Semigroup a => a -> a -> a
<> TxConstraints Void Void
unmint)
                                    { txOwnInputs :: [ScriptInputConstraint input]
txOwnInputs = TxConstraints input Any -> [ScriptInputConstraint input]
forall i o. TxConstraints i o -> [ScriptInputConstraint i]
txOwnInputs TxConstraints input Any
inputConstraints
                                    , txOwnOutputs :: [ScriptOutputConstraint state]
txOwnOutputs = TxConstraints Any state -> [ScriptOutputConstraint state]
forall i o. TxConstraints i o -> [ScriptOutputConstraint o]
txOwnOutputs TxConstraints Any state
outputConstraints
                                    }
                            , smtOldState :: State state
smtOldState = State state
oldState
                            , smtNewState :: State state
smtNewState = State state
newState
                            , smtLookups :: ScriptLookups (StateMachine state input)
smtLookups = ScriptLookups (StateMachine state input)
lookups
                            }
                Maybe (TxConstraints Void Void, State state)
Nothing -> Either
  (InvalidTransition state input)
  (StateMachineTransition state input)
-> Contract
     w
     schema
     e
     (Either
        (InvalidTransition state input)
        (StateMachineTransition state input))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
   (InvalidTransition state input)
   (StateMachineTransition state input)
 -> Contract
      w
      schema
      e
      (Either
         (InvalidTransition state input)
         (StateMachineTransition state input)))
-> Either
     (InvalidTransition state input)
     (StateMachineTransition state input)
-> Contract
     w
     schema
     e
     (Either
        (InvalidTransition state input)
        (StateMachineTransition state input))
forall a b. (a -> b) -> a -> b
$ InvalidTransition state input
-> Either
     (InvalidTransition state input)
     (StateMachineTransition state input)
forall a b. a -> Either a b
Left (InvalidTransition state input
 -> Either
      (InvalidTransition state input)
      (StateMachineTransition state input))
-> InvalidTransition state input
-> Either
     (InvalidTransition state input)
     (StateMachineTransition state input)
forall a b. (a -> b) -> a -> b
$ Maybe (State state) -> input -> InvalidTransition state input
forall s i. Maybe (State s) -> i -> InvalidTransition s i
InvalidTransition (State state -> Maybe (State state)
forall a. a -> Maybe a
Just State state
oldState) input
input