From 73e448b1e892ea9f969b7040e2be7d7d1e267871 Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Sun, 25 Jul 2021 19:24:43 +0200
Subject: [PATCH] Move AsyncVar to Quasar.Awaitable and remove some helper
functions
---
src/Quasar/Awaitable.hs | 57 +++++++++++++++++++++++++++++++++++++++-
src/Quasar/Core.hs | 51 -----------------------------------
test/Quasar/AsyncSpec.hs | 12 ++++-----
3 files changed, 62 insertions(+), 58 deletions(-)
diff --git a/src/Quasar/Awaitable.hs b/src/Quasar/Awaitable.hs
index 6933fb8..0f8d311 100644
--- a/src/Quasar/Awaitable.hs
+++ b/src/Quasar/Awaitable.hs
@@ -1,4 +1,5 @@
module Quasar.Awaitable (
+ -- * Awaitable
IsAwaitable(..),
awaitSTM,
Awaitable,
@@ -7,8 +8,20 @@ module Quasar.Awaitable (
completedAwaitable,
awaitableFromSTM,
peekAwaitable,
-) where
+ -- * AsyncVar
+ AsyncVar,
+ newAsyncVar,
+ newAsyncVarSTM,
+ putAsyncVarEither,
+ putAsyncVarEitherSTM,
+ putAsyncVar,
+ putAsyncVar_,
+ failAsyncVar,
+ failAsyncVar_,
+ putAsyncVarEither_,
+ putAsyncVarEitherSTM_,
+) where
import Control.Concurrent.STM
import Control.Monad.Catch
@@ -65,3 +78,45 @@ awaitableFromSTM fn = do
pure value
Right value -> pure value
+
+
+-- ** AsyncVar
+
+-- | The default implementation for an `Awaitable` that can be fulfilled later.
+newtype AsyncVar r = AsyncVar (TMVar (Either SomeException r))
+
+instance IsAwaitable r (AsyncVar r) where
+ peekSTM (AsyncVar var) = tryReadTMVar var
+
+
+newAsyncVarSTM :: STM (AsyncVar r)
+newAsyncVarSTM = AsyncVar <$> newEmptyTMVar
+
+newAsyncVar :: MonadIO m => m (AsyncVar r)
+newAsyncVar = liftIO $ AsyncVar <$> newEmptyTMVarIO
+
+
+putAsyncVarEither :: forall a m. MonadIO m => AsyncVar a -> Either SomeException a -> m Bool
+putAsyncVarEither var = liftIO . atomically . putAsyncVarEitherSTM var
+
+putAsyncVarEitherSTM :: AsyncVar a -> Either SomeException a -> STM Bool
+putAsyncVarEitherSTM (AsyncVar var) = tryPutTMVar var
+
+
+putAsyncVar :: MonadIO m => AsyncVar a -> a -> m Bool
+putAsyncVar var = putAsyncVarEither var . Right
+
+putAsyncVar_ :: MonadIO m => AsyncVar a -> a -> m ()
+putAsyncVar_ var = void . putAsyncVar var
+
+failAsyncVar :: MonadIO m => AsyncVar a -> SomeException -> m Bool
+failAsyncVar var = putAsyncVarEither var . Left
+
+failAsyncVar_ :: MonadIO m => AsyncVar a -> SomeException -> m ()
+failAsyncVar_ var = void . failAsyncVar var
+
+putAsyncVarEither_ :: MonadIO m => AsyncVar a -> Either SomeException a -> m ()
+putAsyncVarEither_ var = void . putAsyncVarEither var
+
+putAsyncVarEitherSTM_ :: AsyncVar a -> Either SomeException a -> STM ()
+putAsyncVarEitherSTM_ var = void . putAsyncVarEitherSTM var
diff --git a/src/Quasar/Core.hs b/src/Quasar/Core.hs
index 863b7e8..b5e56e4 100644
--- a/src/Quasar/Core.hs
+++ b/src/Quasar/Core.hs
@@ -6,11 +6,6 @@ module Quasar.Core (
runAsyncIO,
awaitResult,
- -- * AsyncVar
- AsyncVar,
- newAsyncVar,
- putAsyncVar,
-
-- * Cancellation
withCancellationToken,
) where
@@ -136,52 +131,6 @@ awaitResult = (await =<<)
-- asyncThread :: m r -> AsyncIO r
--- * Async helpers
-
--- ** AsyncVar
-
--- | The default implementation for an `Awaitable` that can be fulfilled later.
-newtype AsyncVar r = AsyncVar (TMVar (Either SomeException r))
-
-instance IsAwaitable r (AsyncVar r) where
- peekSTM (AsyncVar var) = tryReadTMVar var
-
-tryPutAsyncVarEitherSTM :: AsyncVar a -> Either SomeException a -> STM Bool
-tryPutAsyncVarEitherSTM (AsyncVar var) = tryPutTMVar var
-
-tryPutAsyncVarEither :: forall a m. MonadIO m => AsyncVar a -> Either SomeException a -> m Bool
-tryPutAsyncVarEither var = liftIO . atomically . tryPutAsyncVarEitherSTM var
-
-
-newAsyncVarSTM :: STM (AsyncVar r)
-newAsyncVarSTM = AsyncVar <$> newEmptyTMVar
-
-newAsyncVar :: MonadIO m => m (AsyncVar r)
-newAsyncVar = liftIO $ AsyncVar <$> newEmptyTMVarIO
-
-
-putAsyncVar :: MonadIO m => AsyncVar a -> a -> m ()
-putAsyncVar var = putAsyncVarEither var . Right
-
-tryPutAsyncVar :: MonadIO m => AsyncVar a -> a -> m Bool
-tryPutAsyncVar var = tryPutAsyncVarEither var . Right
-
-tryPutAsyncVar_ :: MonadIO m => AsyncVar a -> a -> m ()
-tryPutAsyncVar_ var = void . tryPutAsyncVar var
-
-failAsyncVar :: MonadIO m => AsyncVar a -> SomeException -> m Bool
-failAsyncVar var = tryPutAsyncVarEither var . Left
-
-failAsyncVar_ :: MonadIO m => AsyncVar a -> SomeException -> m ()
-failAsyncVar_ var = void . failAsyncVar var
-
-putAsyncVarEither :: MonadIO m => AsyncVar a -> Either SomeException a -> m ()
-putAsyncVarEither avar value = liftIO $ do
- success <- tryPutAsyncVarEither avar value
- unless success $ fail "An AsyncVar can only be fulfilled once"
-
-tryPutAsyncVarEither_ :: MonadIO m => AsyncVar a -> Either SomeException a -> m ()
-tryPutAsyncVarEither_ var = void . tryPutAsyncVarEither var
-- * Awaiting multiple asyncs
diff --git a/test/Quasar/AsyncSpec.hs b/test/Quasar/AsyncSpec.hs
index 868a9fa..c1a00cc 100644
--- a/test/Quasar/AsyncSpec.hs
+++ b/test/Quasar/AsyncSpec.hs
@@ -2,7 +2,7 @@ module Quasar.AsyncSpec (spec) where
import Control.Concurrent
import Control.Concurrent.STM
-import Control.Monad (void, (<=<))
+import Control.Monad (void)
import Control.Monad.IO.Class
import Prelude
import Test.Hspec
@@ -22,7 +22,7 @@ spec = parallel $ do
it "accepts a value" $ do
avar <- newAsyncVar :: IO (AsyncVar ())
- putAsyncVar avar ()
+ putAsyncVar_ avar ()
describe "AsyncIO" $ do
it "binds pure operations" $ do
@@ -40,26 +40,26 @@ spec = parallel $ do
it "can fmap the result of an already finished async" $ do
avar <- newAsyncVar :: IO (AsyncVar ())
- putAsyncVar avar ()
+ putAsyncVar_ avar ()
runAsyncIO (id <$> await avar)
it "can fmap the result of an async that is completed later" $ do
avar <- newAsyncVar :: IO (AsyncVar ())
void $ forkIO $ do
threadDelay 100000
- putAsyncVar avar ()
+ putAsyncVar_ avar ()
runAsyncIO (id <$> await avar)
it "can bind the result of an already finished async" $ do
avar <- newAsyncVar :: IO (AsyncVar ())
- putAsyncVar avar ()
+ putAsyncVar_ avar ()
runAsyncIO (await avar >>= pure)
it "can bind the result of an async that is completed later" $ do
avar <- newAsyncVar :: IO (AsyncVar ())
void $ forkIO $ do
threadDelay 100000
- putAsyncVar avar ()
+ putAsyncVar_ avar ()
runAsyncIO (await avar >>= pure)
it "can terminate when encountering an asynchronous exception" $ do
--
GitLab