diff --git a/quasar.cabal b/quasar.cabal index ab58ee964641dac34065b5ad6a21f2b70e47bd11..a151df5e288f7ef3af7460edfc60d4ddbf6a165a 100644 --- a/quasar.cabal +++ b/quasar.cabal @@ -76,6 +76,7 @@ library transformers, unordered-containers, exposed-modules: + Quasar.Awaitable Quasar.Core Quasar.Observable Quasar.Observable.Delta diff --git a/src/Quasar/Awaitable.hs b/src/Quasar/Awaitable.hs new file mode 100644 index 0000000000000000000000000000000000000000..6933fb87df6cfe58197abaf3e3ece942bcbca5d7 --- /dev/null +++ b/src/Quasar/Awaitable.hs @@ -0,0 +1,67 @@ +module Quasar.Awaitable ( + IsAwaitable(..), + awaitSTM, + Awaitable, + successfulAwaitable, + failedAwaitable, + completedAwaitable, + awaitableFromSTM, + peekAwaitable, +) where + + +import Control.Concurrent.STM +import Control.Monad.Catch +import Quasar.Prelude + + +class IsAwaitable r a | a -> r where + peekSTM :: a -> STM (Maybe (Either SomeException r)) + peekSTM = peekSTM . toAwaitable + + toAwaitable :: a -> Awaitable r + toAwaitable x = Awaitable (peekSTM x) + + {-# MINIMAL toAwaitable | peekSTM #-} + + +-- | Wait until the promise is settled and return the result. +awaitSTM :: IsAwaitable r a => a -> STM (Either SomeException r) +awaitSTM = peekSTM >=> maybe retry pure + + +newtype Awaitable r = Awaitable (STM (Maybe (Either SomeException r))) + +instance IsAwaitable r (Awaitable r) where + peekSTM (Awaitable x) = x + toAwaitable = id + +instance Functor Awaitable where + fmap fn = Awaitable . fmap (fmap (fmap fn)) . peekSTM + + +completedAwaitable :: Either SomeException r -> Awaitable r +completedAwaitable = Awaitable . pure . Just + +successfulAwaitable :: r -> Awaitable r +successfulAwaitable = completedAwaitable . Right + +failedAwaitable :: SomeException -> Awaitable r +failedAwaitable = completedAwaitable . Left + + +peekAwaitable :: (IsAwaitable r a, MonadIO m) => a -> m (Maybe (Either SomeException r)) +peekAwaitable = liftIO . atomically . peekSTM + + +awaitableFromSTM :: STM (Maybe (Either SomeException r)) -> IO (Awaitable r) +awaitableFromSTM fn = do + cache <- newTVarIO (Left fn) + pure . Awaitable $ + readTVar cache >>= \case + Left generatorFn -> do + value <- generatorFn + writeTVar cache (Right value) + pure value + Right value -> pure value + diff --git a/src/Quasar/Core.hs b/src/Quasar/Core.hs index cf08fd30266b1668b2d7f5ab3ca8a05737891aee..15ffc90b780116b3c03cd0e2b6ee3c85f1512b40 100644 --- a/src/Quasar/Core.hs +++ b/src/Quasar/Core.hs @@ -1,18 +1,4 @@ module Quasar.Core ( - -- * Awaitable - IsAwaitable(..), - awaitSTM, - Awaitable, - successfulAwaitable, - failedAwaitable, - completedAwaitable, - peekAwaitable, - - -- * AsyncVar - AsyncVar, - newAsyncVar, - putAsyncVar, - -- * AsyncIO AsyncIO, async, @@ -20,6 +6,11 @@ module Quasar.Core ( runAsyncIO, awaitResult, + -- * AsyncVar + AsyncVar, + newAsyncVar, + putAsyncVar, + -- * Disposable IsDisposable(..), Disposable, @@ -37,69 +28,9 @@ import Control.Exception (MaskingState(..), getMaskingState) import Control.Monad.Catch import Data.Maybe (isJust) import Data.Void (absurd) +import Quasar.Awaitable import Quasar.Prelude --- * Awaitable - -class IsAwaitable r a | a -> r where - peekSTM :: a -> STM (Maybe (Either SomeException r)) - peekSTM = peekSTM . toAwaitable - - toAwaitable :: a -> Awaitable r - toAwaitable = SomeAwaitable - - {-# MINIMAL toAwaitable | peekSTM #-} - - --- | Wait until the promise is settled and return the result. -awaitSTM :: IsAwaitable r a => a -> STM (Either SomeException r) -awaitSTM = peekSTM >=> maybe retry pure - - -data Awaitable r = forall a. IsAwaitable r a => SomeAwaitable a - -instance IsAwaitable r (Awaitable r) where - peekSTM (SomeAwaitable x) = peekSTM x - toAwaitable = id - -instance Functor Awaitable where - fmap fn = toAwaitable . FnAwaitable . fmap (fmap (fmap fn)) . peekSTM - - - -newtype CompletedAwaitable r = CompletedAwaitable (Either SomeException r) -instance IsAwaitable r (CompletedAwaitable r) where - peekSTM (CompletedAwaitable value) = pure $ Just value - -completedAwaitable :: Either SomeException r -> Awaitable r -completedAwaitable = toAwaitable . CompletedAwaitable - -successfulAwaitable :: r -> Awaitable r -successfulAwaitable = completedAwaitable . Right - -failedAwaitable :: SomeException -> Awaitable r -failedAwaitable = completedAwaitable . Left - - -peekAwaitable :: (IsAwaitable r a, MonadIO m) => a -> m (Maybe (Either SomeException r)) -peekAwaitable = liftIO . atomically . peekSTM - - -newtype FnAwaitable r = FnAwaitable (STM (Maybe (Either SomeException r))) -instance IsAwaitable r (FnAwaitable r) where - peekSTM (FnAwaitable fn) = fn - -awaitableSTM :: STM (Maybe (Either SomeException r)) -> IO (Awaitable r) -awaitableSTM fn = do - cache <- newTVarIO (Left fn) - pure . toAwaitable . FnAwaitable $ - readTVar cache >>= \case - Left generatorFn -> do - value <- generatorFn - writeTVar cache (Right value) - pure value - Right value -> pure value - -- * AsyncIO @@ -266,7 +197,7 @@ awaitEither :: (IsAwaitable ra a , IsAwaitable rb b) => a -> b -> AsyncIO (Eithe awaitEither x y = AsyncIOPlumbing $ \_ _ -> AsyncIOAsync <$> awaitEitherPlumbing x y awaitEitherPlumbing :: (IsAwaitable ra a , IsAwaitable rb b) => a -> b -> IO (Awaitable (Either ra rb)) -awaitEitherPlumbing x y = awaitableSTM $ peekEitherSTM x y +awaitEitherPlumbing x y = awaitableFromSTM $ peekEitherSTM x y peekEitherSTM :: (IsAwaitable ra a , IsAwaitable rb b) => a -> b -> STM (Maybe (Either SomeException (Either ra rb))) peekEitherSTM x y = diff --git a/test/Quasar/AsyncSpec.hs b/test/Quasar/AsyncSpec.hs index 79b2b0b04ff3ddec66a93a8641762c00a7452e9f..868a9fa4fc8b8c6cc37d0be4d8f58dff9b6ec03f 100644 --- a/test/Quasar/AsyncSpec.hs +++ b/test/Quasar/AsyncSpec.hs @@ -6,6 +6,7 @@ import Control.Monad (void, (<=<)) import Control.Monad.IO.Class import Prelude import Test.Hspec +import Quasar.Awaitable import Quasar.Core import System.Timeout