{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns        #-}
-- |
-- Module: Capnp.Rpc.Promise
-- Description: Promises
--
-- This module defines a 'Promise' type, represents a value which is not yet
-- available, and related utilities.
module Capnp.Rpc.Promise
    ( Promise
    , Fulfiller

    -- * Creating promises
    , newPromise
    , newReadyPromise
    , newPromiseWithCallback
    , newCallback

    -- * Fulfilling or breaking promises
    , fulfill
    , breakPromise
    , breakOrFulfill
    , ErrAlreadyResolved(..)

    -- * Getting the value of a promise
    , wait
    ) where

import Control.Concurrent.STM
import Control.Monad.STM.Class

import qualified Control.Exception.Safe as HsExn

import Capnp.Gen.Capnp.Rpc.Pure
-- For exception instance:
import Capnp.Rpc.Errors ()

-- | An exception thrown if 'breakPromise' or 'fulfill' is called on an
-- already-resolved fulfiller.
data ErrAlreadyResolved = ErrAlreadyResolved deriving(Int -> ErrAlreadyResolved -> ShowS
[ErrAlreadyResolved] -> ShowS
ErrAlreadyResolved -> String
(Int -> ErrAlreadyResolved -> ShowS)
-> (ErrAlreadyResolved -> String)
-> ([ErrAlreadyResolved] -> ShowS)
-> Show ErrAlreadyResolved
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrAlreadyResolved] -> ShowS
$cshowList :: [ErrAlreadyResolved] -> ShowS
show :: ErrAlreadyResolved -> String
$cshow :: ErrAlreadyResolved -> String
showsPrec :: Int -> ErrAlreadyResolved -> ShowS
$cshowsPrec :: Int -> ErrAlreadyResolved -> ShowS
Show)
instance HsExn.Exception ErrAlreadyResolved

-- | A 'Fulfiller' is used to fulfill a promise.
newtype Fulfiller a = Fulfiller
    { Fulfiller a -> Either Exception a -> STM ()
callback :: Either Exception a -> STM ()
    }

-- | Fulfill a promise by supplying the specified value. It is an error to
-- call 'fulfill' if the promise has already been fulfilled (or broken).
fulfill :: MonadSTM m => Fulfiller a -> a -> m ()
fulfill :: Fulfiller a -> a -> m ()
fulfill Fulfiller a
f a
val = Fulfiller a -> Either Exception a -> m ()
forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Either Exception a -> m ()
breakOrFulfill Fulfiller a
f (a -> Either Exception a
forall a b. b -> Either a b
Right a
val)

-- | Break a promise. When the user of the promise executes 'wait', the
-- specified exception will be raised. It is an error to call 'breakPromise'
-- if the promise has already been fulfilled (or broken).
breakPromise :: MonadSTM m => Fulfiller a -> Exception -> m ()
breakPromise :: Fulfiller a -> Exception -> m ()
breakPromise Fulfiller a
f Exception
exn = Fulfiller a -> Either Exception a -> m ()
forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Either Exception a -> m ()
breakOrFulfill Fulfiller a
f (Exception -> Either Exception a
forall a b. a -> Either a b
Left Exception
exn)

-- | 'breakOrFulfill' calls either 'breakPromise' or 'fulfill', depending
-- on the argument.
breakOrFulfill :: MonadSTM m => Fulfiller a -> Either Exception a -> m ()
breakOrFulfill :: Fulfiller a -> Either Exception a -> m ()
breakOrFulfill Fulfiller{Either Exception a -> STM ()
callback :: Either Exception a -> STM ()
$sel:callback:Fulfiller :: forall a. Fulfiller a -> Either Exception a -> STM ()
callback} Either Exception a
result = STM () -> m ()
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ Either Exception a -> STM ()
callback Either Exception a
result

-- | Wait for a promise to resolve, and return the result. If the promise
-- is broken, this raises an exception instead (see 'breakPromise').
wait :: MonadSTM m => Promise a -> m a
wait :: Promise a -> m a
wait Promise{TVar (Maybe (Either Exception a))
$sel:var:Promise :: forall a. Promise a -> TVar (Maybe (Either Exception a))
var :: TVar (Maybe (Either Exception a))
var} = STM a -> m a
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM a -> m a) -> STM a -> m a
forall a b. (a -> b) -> a -> b
$ do
    Maybe (Either Exception a)
val <- TVar (Maybe (Either Exception a))
-> STM (Maybe (Either Exception a))
forall a. TVar a -> STM a
readTVar TVar (Maybe (Either Exception a))
var
    case Maybe (Either Exception a)
val of
        Maybe (Either Exception a)
Nothing ->
            STM a
forall a. STM a
retry
        Just (Right a
result) ->
            a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
result
        Just (Left Exception
exn) ->
            Exception -> STM a
forall e a. Exception e => e -> STM a
throwSTM Exception
exn

-- | Create a promise that is already fulfilled, with the given value.
newReadyPromise :: MonadSTM m => a -> m (Promise a)
newReadyPromise :: a -> m (Promise a)
newReadyPromise a
value = STM (Promise a) -> m (Promise a)
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM (Promise a) -> m (Promise a))
-> STM (Promise a) -> m (Promise a)
forall a b. (a -> b) -> a -> b
$ TVar (Maybe (Either Exception a)) -> Promise a
forall a. TVar (Maybe (Either Exception a)) -> Promise a
Promise (TVar (Maybe (Either Exception a)) -> Promise a)
-> STM (TVar (Maybe (Either Exception a))) -> STM (Promise a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Either Exception a)
-> STM (TVar (Maybe (Either Exception a)))
forall a. a -> STM (TVar a)
newTVar (Either Exception a -> Maybe (Either Exception a)
forall a. a -> Maybe a
Just (a -> Either Exception a
forall a b. b -> Either a b
Right a
value))

-- | Create a new promise and an associated fulfiller.
newPromise :: MonadSTM m => m (Promise a, Fulfiller a)
newPromise :: m (Promise a, Fulfiller a)
newPromise = STM (Promise a, Fulfiller a) -> m (Promise a, Fulfiller a)
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM (Promise a, Fulfiller a) -> m (Promise a, Fulfiller a))
-> STM (Promise a, Fulfiller a) -> m (Promise a, Fulfiller a)
forall a b. (a -> b) -> a -> b
$ do
    TVar (Maybe (Either Exception a))
var <- Maybe (Either Exception a)
-> STM (TVar (Maybe (Either Exception a)))
forall a. a -> STM (TVar a)
newTVar Maybe (Either Exception a)
forall a. Maybe a
Nothing
    (Promise a, Fulfiller a) -> STM (Promise a, Fulfiller a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ( Promise :: forall a. TVar (Maybe (Either Exception a)) -> Promise a
Promise{TVar (Maybe (Either Exception a))
var :: TVar (Maybe (Either Exception a))
$sel:var:Promise :: TVar (Maybe (Either Exception a))
var}
        , Fulfiller :: forall a. (Either Exception a -> STM ()) -> Fulfiller a
Fulfiller
            { $sel:callback:Fulfiller :: Either Exception a -> STM ()
callback = \Either Exception a
result -> do
                Maybe (Either Exception a)
val <- TVar (Maybe (Either Exception a))
-> STM (Maybe (Either Exception a))
forall a. TVar a -> STM a
readTVar TVar (Maybe (Either Exception a))
var
                case Maybe (Either Exception a)
val of
                    Maybe (Either Exception a)
Nothing ->
                        TVar (Maybe (Either Exception a))
-> Maybe (Either Exception a) -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe (Either Exception a))
var (Either Exception a -> Maybe (Either Exception a)
forall a. a -> Maybe a
Just Either Exception a
result)
                    Just Either Exception a
_ ->
                        ErrAlreadyResolved -> STM ()
forall e a. Exception e => e -> STM a
throwSTM ErrAlreadyResolved
ErrAlreadyResolved
            }
        )

-- | Create a new promise which also excecutes an STM action when it is resolved.
newPromiseWithCallback :: MonadSTM m => (Either Exception a -> STM ()) -> m (Promise a, Fulfiller a)
newPromiseWithCallback :: (Either Exception a -> STM ()) -> m (Promise a, Fulfiller a)
newPromiseWithCallback Either Exception a -> STM ()
callback = STM (Promise a, Fulfiller a) -> m (Promise a, Fulfiller a)
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM (Promise a, Fulfiller a) -> m (Promise a, Fulfiller a))
-> STM (Promise a, Fulfiller a) -> m (Promise a, Fulfiller a)
forall a b. (a -> b) -> a -> b
$ do
    (Promise a
promise, Fulfiller{$sel:callback:Fulfiller :: forall a. Fulfiller a -> Either Exception a -> STM ()
callback=Either Exception a -> STM ()
oldCallback}) <- STM (Promise a, Fulfiller a)
forall (m :: * -> *) a. MonadSTM m => m (Promise a, Fulfiller a)
newPromise
    (Promise a, Fulfiller a) -> STM (Promise a, Fulfiller a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ( Promise a
promise
        , Fulfiller :: forall a. (Either Exception a -> STM ()) -> Fulfiller a
Fulfiller
            { $sel:callback:Fulfiller :: Either Exception a -> STM ()
callback = \Either Exception a
result -> Either Exception a -> STM ()
oldCallback Either Exception a
result STM () -> STM () -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Either Exception a -> STM ()
callback Either Exception a
result
            }
        )

-- | Like 'newPromiseWithCallback', but doesn't return the promise.
newCallback :: MonadSTM m => (Either Exception a -> STM ()) -> m (Fulfiller a)
newCallback :: (Either Exception a -> STM ()) -> m (Fulfiller a)
newCallback = STM (Fulfiller a) -> m (Fulfiller a)
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM (Fulfiller a) -> m (Fulfiller a))
-> ((Either Exception a -> STM ()) -> STM (Fulfiller a))
-> (Either Exception a -> STM ())
-> m (Fulfiller a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Promise a, Fulfiller a) -> Fulfiller a)
-> STM (Promise a, Fulfiller a) -> STM (Fulfiller a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Promise a, Fulfiller a) -> Fulfiller a
forall a b. (a, b) -> b
snd (STM (Promise a, Fulfiller a) -> STM (Fulfiller a))
-> ((Either Exception a -> STM ()) -> STM (Promise a, Fulfiller a))
-> (Either Exception a -> STM ())
-> STM (Fulfiller a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either Exception a -> STM ()) -> STM (Promise a, Fulfiller a)
forall (m :: * -> *) a.
MonadSTM m =>
(Either Exception a -> STM ()) -> m (Promise a, Fulfiller a)
newPromiseWithCallback

-- | A promise is a value that may not be ready yet.
newtype Promise a = Promise
    { Promise a -> TVar (Maybe (Either Exception a))
var :: TVar (Maybe (Either Exception a))
    }
    deriving(Promise a -> Promise a -> Bool
(Promise a -> Promise a -> Bool)
-> (Promise a -> Promise a -> Bool) -> Eq (Promise a)
forall a. Promise a -> Promise a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Promise a -> Promise a -> Bool
$c/= :: forall a. Promise a -> Promise a -> Bool
== :: Promise a -> Promise a -> Bool
$c== :: forall a. Promise a -> Promise a -> Bool
Eq)