Switch to Promise design

doc/plutus/tutorials/BasicApps.hs

@@ -83,10 +83,10 @@ type SplitSchema =
 
 -- BLOCK5
 
-lock :: Contract () SplitSchema T.Text (Waited ())
+lock :: Promise () SplitSchema T.Text ()
 lock = endpoint @"lock" (lockFunds . mkSplitData)
 
-unlock :: Contract () SplitSchema T.Text (Waited ())
+unlock :: Promise () SplitSchema T.Text ()
 unlock = endpoint @"unlock" (unlockFunds . mkSplitData)
 
 -- BLOCK6

marlowe/follow/Main.hs

@@ -5,15 +5,13 @@ import           Data.Bifunctor          (first)
 import           Data.Proxy              (Proxy (..))
 import           Data.Text.Extras        (tshow)
 import           Language.Marlowe.Client (MarloweFollowSchema, marloweFollowContract)
-import           Plutus.Contract         (getWaited)
 import           Plutus.PAB.ContractCLI  (commandLineApp')
 
 main :: IO ()
 main =
     commandLineApp'
         (Proxy @MarloweFollowSchema) -- see note ['ToSchema' and Marlowe]
         $ first tshow
-        $ fmap getWaited
         $ marloweFollowContract
 
 {- Note ['ToSchema' and Marlowe]

marlowe/src/Language/Marlowe/Client.hs

@@ -155,16 +155,16 @@ instance Monoid LastResult where
 type MarloweContractState = LastResult
 
 
-marloweFollowContract :: Contract ContractHistory MarloweFollowSchema MarloweError (Waited ())
-marloweFollowContract = endpoint @"follow" $ \params -> do
+marloweFollowContract :: Contract ContractHistory MarloweFollowSchema MarloweError ()
+marloweFollowContract = awaitPromise $ endpoint @"follow" $ \params -> do
     slot <- currentSlot
     checkpointLoop follow (0, slot, params)
   where
     follow (ifrom, ito, params) = do
         let client@StateMachineClient{scInstance} = mkMarloweClient params
         let inst = SM.typedValidator scInstance
         let address = Scripts.validatorAddress inst
-        AddressChangeResponse{acrTxns} <- getWaited <$> addressChangeRequest
+        AddressChangeResponse{acrTxns} <- awaitPromise $ addressChangeRequest
                 AddressChangeRequest
                 { acreqSlotRangeFrom = ifrom
                 , acreqSlotRangeTo = ito
@@ -256,7 +256,7 @@ marlowePlutusContract = do
         _ <- applyInputs params slotInterval inputs
         tell OK
         marlowePlutusContract
-    redeem = mapError (review _MarloweError) $ endpoint @"redeem" $ \(MarloweParams{rolesCurrency}, role, pkh) -> do
+    redeem = promiseMap (mapError (review _MarloweError)) $ endpoint @"redeem" $ \(MarloweParams{rolesCurrency}, role, pkh) -> do
         let address = scriptHashAddress (mkRolePayoutValidatorHash rolesCurrency)
         utxos <- utxoAt address
         let spendPayoutConstraints tx ref TxOutTx{txOutTxOut} = let
@@ -296,7 +296,7 @@ marlowePlutusContract = do
         maybeState <- SM.getOnChainState theClient
         case maybeState of
             Nothing -> do
-                wr <- getWaited <$> SM.waitForUpdateUntilSlot theClient untilSlot
+                wr <- SM.waitForUpdateUntilSlot theClient untilSlot
                 case wr of
                     ContractEnded -> do
                         logInfo @String $ "Contract Ended for party " <> show party
@@ -341,7 +341,7 @@ marlowePlutusContract = do
                 continueWith marloweData
             WaitOtherActionUntil timeout -> do
                 logInfo @String $ "WaitOtherActionUntil " <> show timeout
-                wr <- getWaited <$> SM.waitForUpdateUntilSlot theClient timeout
+                wr <- SM.waitForUpdateUntilSlot theClient timeout
                 case wr of
                     ContractEnded -> do
                         logInfo @String $ "Contract Ended"
@@ -664,7 +664,7 @@ marloweCompanionContract = contracts
         forM_ txOuts notifyOnNewContractRoles
         checkpointLoop (fmap Right <$> cont) ownAddress
     cont ownAddress = do
-        txns <- getWaited <$> nextTransactionsAt ownAddress
+        txns <- nextTransactionsAt ownAddress
         let txOuts = txns >>= eitherTx (const []) txOutputs
         forM_ txOuts notifyOnNewContractRoles
         pure ownAddress

playground-common/src/PSGenerator/Common.hs

@@ -36,7 +36,7 @@ import           Ledger.Value                              (CurrencySymbol, Toke
 import           Playground.Types                          (ContractCall, FunctionSchema, KnownCurrency)
 import           Plutus.Contract.Checkpoint                (CheckpointError)
 import           Plutus.Contract.Effects                   (ActiveEndpoint, BalanceTxResponse, PABReq, PABResp,
-                                                            UtxoAtAddress, Waited, WriteBalancedTxResponse)
+                                                            UtxoAtAddress, WriteBalancedTxResponse)
 import           Plutus.Contract.Resumable                 (IterationID, Request, RequestID, Response)
 import           Plutus.Trace.Emulator.Types               (ContractInstanceLog, ContractInstanceMsg,
                                                             ContractInstanceTag, EmulatorRuntimeError, UserThreadMsg)
@@ -301,7 +301,6 @@ ledgerTypes =
     , (equal <*> (genericShow <*> mkSumType)) (Proxy @ScriptType)
     , (equal <*> (genericShow <*> mkSumType)) (Proxy @PABReq)
     , (equal <*> (genericShow <*> mkSumType)) (Proxy @PABResp)
-    , (equal <*> (genericShow <*> mkSumType)) (Proxy @(Waited A))
     , (equal <*> (genericShow <*> mkSumType)) (Proxy @AddressChangeRequest)
     , (equal <*> (genericShow <*> mkSumType)) (Proxy @AddressChangeResponse)
     , (equal <*> (genericShow <*> mkSumType)) (Proxy @(EndpointValue A))

plutus-contract/src/Plutus/Contract.hs

@@ -6,23 +6,28 @@ module Plutus.Contract(
       Contract(..)
     , ContractError(..)
     , AsContractError(..)
-    , Waited
-    , getWaited
-    , bindWaited
-    , both
-    , selectEither
-    , select
-    , selectList
+    , IsContract(..)
     , (>>)
     , throwError
     , handleError
     , mapError
     , runError
+    -- * Promises
+    , Promise
+    , awaitPromise
+    , promiseMap
+    , promiseBind
+    , both
+    , selectEither
+    , select
+    , selectList
     -- * Dealing with time
     , Request.awaitSlot
+    , Request.isSlot
     , Request.currentSlot
     , Request.waitNSlots
     , Request.awaitTime
+    , Request.isTime
     , Request.currentTime
     , Request.waitNMilliSeconds
     -- * Endpoints
@@ -66,6 +71,7 @@ module Plutus.Contract(
     , module Tx
     -- ** Tx confirmation
     , Request.awaitTxConfirmed
+    , Request.isTxConfirmed
     -- * Checkpoints
     , checkpoint
     , checkpointLoop
@@ -86,15 +92,14 @@ module Plutus.Contract(
 import           Data.Aeson                     (ToJSON (toJSON))
 import           Data.Row
 
-import           Plutus.Contract.Effects        (Waited (..), bindWaited)
 import           Plutus.Contract.Request        (ContractRow)
 import qualified Plutus.Contract.Request        as Request
 import qualified Plutus.Contract.Schema         as Schema
 import           Plutus.Contract.Typed.Tx       as Tx
 import           Plutus.Contract.Types          (AsCheckpointError (..), AsContractError (..), CheckpointError (..),
-                                                 Contract (..), ContractError (..), checkpoint, checkpointLoop,
-                                                 handleError, mapError, runError, select, selectEither, selectList,
-                                                 throwError)
+                                                 Contract (..), ContractError (..), IsContract (..), Promise (..),
+                                                 checkpoint, checkpointLoop, handleError, mapError, promiseBind,
+                                                 promiseMap, runError, select, selectEither, selectList, throwError)
 
 import qualified Control.Monad.Freer.Extras.Log as L
 import qualified Control.Monad.Freer.Writer     as W
@@ -105,10 +110,8 @@ import           Wallet.API                     (WalletAPIError)
 import qualified Wallet.Types
 
 -- | Execute both contracts in any order
-both :: Contract w s e (Waited a) -> Contract w s e (Waited b) -> Contract w s e (Waited (a, b))
-both a b =
-  let swap b_ a_ = (a_, b_) in
-  (liftF2 (,) <$> a <*> b) `select` (liftF2 swap <$> b <*> a)
+both :: Promise w s e a -> Promise w s e b -> Promise w s e (a, b)
+both a b = liftF2 (,) a b `select` liftF2 (flip (,)) b a
 
 -- | Log a message at the 'Debug' level
 logDebug :: ToJSON a => a -> Contract w s e ()

plutus-contract/src/Plutus/Contract/Effects.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE DeriveAnyClass    #-}
-{-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE DerivingVia       #-}
 {-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE NamedFieldPuns    #-}
@@ -32,8 +31,6 @@ module Plutus.Contract.Effects( -- TODO: Move to Requests.Internal
     _BalanceTxResp,
     _WriteBalancedTxResp,
     _ExposeEndpointResp,
-    Waited(..),
-    bindWaited,
     matches,
 
     -- * Etc.
@@ -49,8 +46,6 @@ module Plutus.Contract.Effects( -- TODO: Move to Requests.Internal
 import           Control.Lens                (Iso', iso, makePrisms)
 import           Data.Aeson                  (FromJSON, ToJSON)
 import qualified Data.Aeson                  as JSON
-import           Data.Functor.Apply          (Apply (..))
-import           Data.Functor.Extend         (Extend (..))
 import qualified Data.Map                    as Map
 import           Data.Text.Prettyprint.Doc   (Pretty (..), colon, indent, viaShow, vsep, (<+>))
 import           GHC.Generics                (Generic)
@@ -97,18 +92,18 @@ instance Pretty PABReq where
 
 -- | Responses that 'Contract's receive
 data PABResp =
-    AwaitSlotResp (Waited Slot)
-    | AwaitTimeResp (Waited POSIXTime)
+    AwaitSlotResp Slot
+    | AwaitTimeResp POSIXTime
     | CurrentSlotResp Slot
     | CurrentTimeResp POSIXTime
-    | AwaitTxConfirmedResp (Waited TxId)
+    | AwaitTxConfirmedResp TxId
     | OwnContractInstanceIdResp ContractInstanceId
     | OwnPublicKeyResp PubKey
     | UtxoAtResp UtxoAtAddress
     | AddressChangeResp AddressChangeResponse
     | BalanceTxResp BalanceTxResponse
     | WriteBalancedTxResp WriteBalancedTxResponse
-    | ExposeEndpointResp EndpointDescription (Waited (EndpointValue JSON.Value))
+    | ExposeEndpointResp EndpointDescription (EndpointValue JSON.Value)
     deriving stock (Eq, Show, Generic)
     deriving anyclass (ToJSON, FromJSON)
 
@@ -145,24 +140,6 @@ matches a b = case (a, b) of
     | aeDescription == desc -> True
   _                                                       -> False
 
--- | A wrapper indicating that calulating this value was not immediate. For use with @select@.
-newtype Waited a = Waited { getWaited :: a }
-    deriving stock (Eq, Show, Generic, Functor, Foldable, Traversable)
-    deriving anyclass (ToJSON, FromJSON)
-    deriving Pretty via a
-
-instance Apply Waited where
-    liftF2 f (Waited a) (Waited b) = Waited (f a b)
-
--- 'Waited' is actually a complete comonad, with 'getWaited' as 'extract'.
-instance Extend Waited where
-    extended f = Waited . f
-
-bindWaited :: Monad m => m (Waited a) -> (a -> m b) -> m (Waited b)
-bindWaited ma f = do
-  Waited a <- ma
-  Waited <$> f a
-
 data UtxoAtAddress =
     UtxoAtAddress
         { address :: Address