diff --git a/src/Quasar/Core.hs b/src/Quasar/Core.hs index 4d44ba65e3be2a7632f3c1ed681c96b0fe42f5b9..82d68a1ae3368f3e290d0e76eb5ccae72a7cb555 100644 --- a/src/Quasar/Core.hs +++ b/src/Quasar/Core.hs @@ -5,9 +5,6 @@ module Quasar.Core ( await, runAsyncIO, awaitResult, - - -- * Cancellation - withCancellationToken, ) where import Control.Concurrent (forkIOWithUnmask) @@ -165,45 +162,3 @@ peekEitherSTM x y = Just (Left ex) -> pure (Just (Left ex)) Just (Right r) -> pure (Just (Right (Right r))) Nothing -> pure Nothing - - --- * Cancellation - -newtype CancellationToken = CancellationToken (AsyncVar Void) - -instance IsAwaitable Void CancellationToken where - toAwaitable (CancellationToken var) = toAwaitable var - -newCancellationToken :: IO CancellationToken -newCancellationToken = CancellationToken <$> newAsyncVar - -cancel :: Exception e => CancellationToken -> e -> IO () -cancel (CancellationToken var) = failAsyncVar_ var . toException - -isCancellationRequested :: CancellationToken -> IO Bool -isCancellationRequested (CancellationToken var) = isJust <$> peekAwaitable var - -cancellationState :: CancellationToken -> IO (Maybe SomeException) -cancellationState (CancellationToken var) = (either Just (const Nothing) =<<) <$> peekAwaitable var - -throwIfCancellationRequested :: CancellationToken -> IO () -throwIfCancellationRequested (CancellationToken var) = - peekAwaitable var >>= \case - Just (Left ex) -> throwIO ex - _ -> pure () - -awaitUnlessCancellationRequested :: IsAwaitable a b => CancellationToken -> b -> AsyncIO a -awaitUnlessCancellationRequested cancellationToken = fmap (either absurd id) . awaitEither cancellationToken . toAwaitable - - -withCancellationToken :: (CancellationToken -> IO a) -> IO a -withCancellationToken action = do - cancellationToken <- newCancellationToken - resultMVar :: MVar (Either SomeException a) <- newEmptyMVar - - uninterruptibleMask $ \unmask -> do - void $ forkIOWithUnmask $ \threadUnmask -> do - putMVar resultMVar =<< try (threadUnmask (action cancellationToken)) - - -- TODO test if it is better to run readMVar recursively or to keep it uninterruptible - either throwIO pure =<< (unmask (readMVar resultMVar) `catchAll` (\ex -> cancel cancellationToken ex >> readMVar resultMVar)) diff --git a/test/Quasar/AsyncSpec.hs b/test/Quasar/AsyncSpec.hs index c1a00ccb07f32504ec0cfe4c11ac9b3eb83d62b7..5feed6da850a03e7700c4ca2a3225ea9d7615ea1 100644 --- a/test/Quasar/AsyncSpec.hs +++ b/test/Quasar/AsyncSpec.hs @@ -69,12 +69,3 @@ spec = parallel $ do -- Use bind to create an AsyncIOPlumbing, which is the interesting case that uses `uninterruptibleMask` when run await never >>= pure result `shouldBe` Nothing - - describe "CancellationToken" $ do - it "propagates outer exceptions to the cancellation token" $ do - result <- timeout 100000 $ withCancellationToken (runAsyncIO . await) - result `shouldBe` Nothing - - it "can return a value after cancellation" $ do - result <- timeout 100000 $ withCancellationToken (fmap (either (const True) (const False)) . atomically . awaitSTM) - result `shouldBe` Just True