diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,6 +5,14 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/) and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## [0.2.0] - 2020-12-17 + +### Changed +- Rename `cancelScope` to `cancel`. + +### Removed +- Remove `ThreadFailed` exception wrapper. + ## [0.1.0.1] - 2020-11-30 ### Changed diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -88,7 +88,7 @@ canceled. ```haskell -cancelScope :: Scope -> IO () +cancel :: Scope -> IO () cancelled :: Context => IO (Maybe CancelToken) ``` diff --git a/ki.cabal b/ki.cabal --- a/ki.cabal +++ b/ki.cabal @@ -10,35 +10,35 @@ maintainer: Mitchell Rosen name: ki stability: experimental -synopsis: A lightweight, structured concurrency library -version: 0.1.0.1 +synopsis: A lightweight, structured-concurrency library +version: 0.2.0 description: A lightweight, structured-concurrency library. - + . This package comes in two variants: - + . * "Ki" exposes the most stripped-down variant; start here. - + . * "Ki.Implicit" extends "Ki" with an implicit context that's used to propagate soft cancellation signals. - + . Using this variant comes at a cost: - + . * You must manually add constraints to propagate the implicit context to where it's needed. - + . * To remain warning-free, you must delete the implicit context constraints where they are no longer needed. - + . If you don't need soft-cancellation, there is no benefit to using this variant, and you should stick with "Ki". - + . Because you'll only ever need one variant at a time, I recommend using a - + to rename one module to @Ki@ while hiding the others. This also simplifies the process of upgrading from "Ki.Implicit" to "Ki" if necessary. - + . @ mixins: ki (Ki.Implicit as Ki) @ @@ -68,6 +68,7 @@ LambdaCase NamedFieldPuns NoImplicitPrelude + NumericUnderscores RankNTypes RoleAnnotations ScopedTypeVariables @@ -111,9 +112,7 @@ Ki.Duration Ki.Prelude Ki.Scope - Ki.ScopeClosing Ki.Thread - Ki.ThreadFailed Ki.Timeout if flag(test) build-depends: diff --git a/src/Ki.hs b/src/Ki.hs --- a/src/Ki.hs +++ b/src/Ki.hs @@ -21,9 +21,9 @@ Thread.asyncWithUnmask, -- ** Await - await, - awaitSTM, - awaitFor, + Thread.await, + Thread.awaitSTM, + Thread.awaitFor, -- * Miscellaneous Duration, @@ -32,9 +32,6 @@ Duration.seconds, Timeout.timeoutSTM, sleep, - - -- * Exceptions - ThreadFailed (..), ) where @@ -46,36 +43,8 @@ import qualified Ki.Scope as Scope import Ki.Thread (Thread) import qualified Ki.Thread as Thread -import Ki.ThreadFailed (ThreadFailed (..)) import qualified Ki.Timeout as Timeout --- | Wait for a __thread__ to finish. --- --- /Throws/: --- --- * 'ThreadFailed' if the __thread__ threw an exception and was created with 'Ki.fork'. -await :: Thread a -> IO a -await = - Thread.await - --- | @STM@ variant of 'await'. --- --- /Throws/: --- --- * 'ThreadFailed' if the __thread__ threw an exception and was created with 'Ki.fork'. -awaitSTM :: Thread a -> STM a -awaitSTM = - Thread.awaitSTM - --- | Variant of 'await' that waits for up to the given duration. --- --- /Throws/: --- --- * 'ThreadFailed' if the __thread__ threw an exception and was created with 'Ki.fork'. -awaitFor :: Thread a -> Duration -> IO (Maybe a) -awaitFor = - Thread.awaitFor - -- $spawning-threads -- -- There are two variants of __thread__-creating functions with different exception-propagation semantics. @@ -93,7 +62,7 @@ -- /Throws/: -- -- * The exception thrown by the callback to 'scoped' itself, if any. --- * 'ThreadFailed' containing the first exception a __thread__ created with 'Ki.fork' throws, if any. +-- * The first exception thrown by or to a __thread__ created with 'Ki.fork', if any. -- -- ==== __Examples__ -- diff --git a/src/Ki/Implicit.hs b/src/Ki/Implicit.hs --- a/src/Ki/Implicit.hs +++ b/src/Ki/Implicit.hs @@ -27,15 +27,15 @@ asyncWithUnmask, -- ** Await - await, - awaitSTM, - awaitFor, + Thread.await, + Thread.awaitSTM, + Thread.awaitFor, -- * Soft-cancellation - Scope.cancelScope, + CancelToken, + Scope.cancel, cancelled, cancelledSTM, - CancelToken, -- * Miscellaneous Duration, @@ -44,9 +44,6 @@ Duration.seconds, timeoutSTM, sleep, - - -- * Exceptions - ThreadFailed (..), ) where @@ -59,7 +56,6 @@ import qualified Ki.Scope as Scope import Ki.Thread (Thread) import qualified Ki.Thread as Thread -import Ki.ThreadFailed (ThreadFailed (..)) import Ki.Timeout (timeoutSTM) -- $spawning-threads @@ -82,12 +78,12 @@ type Context = ?context :: Context.Context --- | Create a __thread__ within a __scope__ to compute a value concurrently. +-- | Create a __thread__ within a __scope__. -- -- /Throws/: -- -- * Calls 'error' if the __scope__ is /closed/. -async :: Scope -> (Context => IO a) -> IO (Thread (Either ThreadFailed a)) +async :: Scope -> (Context => IO a) -> IO (Thread (Either SomeException a)) async scope action = Thread.async scope (with scope action) @@ -96,37 +92,10 @@ -- /Throws/: -- -- * Calls 'error' if the __scope__ is /closed/. -asyncWithUnmask :: Scope -> (Context => (forall x. IO x -> IO x) -> IO a) -> IO (Thread (Either ThreadFailed a)) +asyncWithUnmask :: Scope -> (Context => (forall x. IO x -> IO x) -> IO a) -> IO (Thread (Either SomeException a)) asyncWithUnmask scope action = Thread.asyncWithUnmask scope (let ?context = Scope.context scope in action) --- | Wait for a __thread__ to finish. --- --- /Throws/: --- --- * 'ThreadFailed' if the __thread__ threw an exception and was created with 'fork'. -await :: Thread a -> IO a -await = - Thread.await - --- | @STM@ variant of 'await'. --- --- /Throws/: --- --- * 'ThreadFailed' if the __thread__ threw an exception and was created with 'fork'. -awaitSTM :: Thread a -> STM a -awaitSTM = - Thread.awaitSTM - --- | Variant of 'await' that waits for up to the given duration. --- --- /Throws/: --- --- * 'ThreadFailed' if the __thread__ threw an exception and was created with 'fork'. -awaitFor :: Thread a -> Duration -> IO (Maybe a) -awaitFor = - Thread.awaitFor - -- | Return whether the current __context__ is /cancelled/. -- -- __Threads__ running in a /cancelled/ __context__ should terminate as soon as possible. The cancel token may be thrown @@ -141,11 +110,10 @@ cancelledSTM = Context.contextCancelTokenSTM ?context --- | Create a __thread__ within a __scope__ to compute a value concurrently. +-- | Create a __thread__ within a __scope__. -- --- If the __thread__ throws an exception, the exception is wrapped in 'ThreadFailed' and immediately propagated up the --- call tree to the __thread__ that opened its __scope__, unless that exception is a 'CancelToken' that fulfills a --- /cancellation/ request. +-- If the __thread__ throws an exception, the exception is immediately propagated up the call tree to the __thread__ +-- that opened its __scope__, unless that exception is a 'CancelToken' that fulfills a /cancellation/ request. -- -- /Throws/: -- @@ -193,7 +161,7 @@ -- /Throws/: -- -- * The exception thrown by the callback to 'scoped' itself, if any. --- * 'ThreadFailed' containing the first exception a __thread__ created with 'fork' throws, if any. +-- * The first exception thrown by or to a __thread__ created with 'fork', if any. -- -- ==== __Examples__ -- @@ -211,7 +179,7 @@ -- -- /Throws/: -- --- * Throws 'CancelToken' if the current __context__ is /cancelled/. +-- * Throws 'CancelToken' if the current __context__ is (or becomes) /cancelled/. sleep :: Context => Duration -> IO () sleep duration = timeoutSTM duration (cancelledSTM >>= throwSTM) (pure ()) diff --git a/src/Ki/Internal.hs b/src/Ki/Internal.hs --- a/src/Ki/Internal.hs +++ b/src/Ki/Internal.hs @@ -4,9 +4,7 @@ module Ki.Ctx, module Ki.Duration, module Ki.Scope, - module Ki.ScopeClosing, module Ki.Thread, - module Ki.ThreadFailed, module Ki.Timeout, ) where @@ -16,7 +14,5 @@ import Ki.Ctx import Ki.Duration import Ki.Scope -import Ki.ScopeClosing import Ki.Thread -import Ki.ThreadFailed import Ki.Timeout diff --git a/src/Ki/Scope.hs b/src/Ki/Scope.hs --- a/src/Ki/Scope.hs +++ b/src/Ki/Scope.hs @@ -3,25 +3,30 @@ module Ki.Scope ( Scope (..), - cancelScope, + cancel, scopeCancelledSTM, scopeFork, scoped, wait, waitFor, waitSTM, + ScopeClosing (..), + ThreadFailed (..), ) where -import Control.Exception (fromException, pattern ErrorCall) +import Control.Exception + ( Exception (fromException, toException), + asyncExceptionFromException, + asyncExceptionToException, + pattern ErrorCall, + ) import qualified Data.Monoid as Monoid import qualified Data.Set as Set import Ki.Context (Context) import qualified Ki.Context as Context import Ki.Duration (Duration) import Ki.Prelude -import Ki.ScopeClosing (ScopeClosing (..)) -import Ki.ThreadFailed (ThreadFailedAsync (..)) import Ki.Timeout (timeoutSTM) -- | A __scope__ delimits the lifetime of all __threads__ created within it. @@ -49,8 +54,8 @@ pure Scope {context, closedVar, runningVar, startingVar} -- | /Cancel/ all __contexts__ derived from a __scope__. -cancelScope :: Scope -> IO () -cancelScope Scope {context} = +cancel :: Scope -> IO () +cancel Scope {context} = Context.cancelContext context scopeCancelledSTM :: Scope -> STM (IO a) @@ -74,7 +79,7 @@ atomically (blockUntilNoneRunning scope) pure exception -scopeFork :: Scope -> ((forall x. IO x -> IO x) -> IO a) -> (ThreadId -> Either SomeException a -> IO ()) -> IO ThreadId +scopeFork :: Scope -> ((forall x. IO x -> IO x) -> IO a) -> (Either SomeException a -> IO ()) -> IO ThreadId scopeFork Scope {closedVar, runningVar, startingVar} action k = uninterruptibleMask \restore -> do -- Record the thread as being about to start @@ -88,7 +93,7 @@ forkIO do childThreadId <- myThreadId result <- try (action restore) - k childThreadId result + k result atomically do running <- readTVar runningVar case Set.splitMember childThreadId running of @@ -116,11 +121,11 @@ whenJust closeScopeException throw pure value where - -- If applicable, unwrap the 'AsyncThreadFailed' (assumed to have come from one of our children). + -- If applicable, unwrap the 'ThreadFailed' (assumed to have come from one of our children). throw :: SomeException -> IO a throw exception = case fromException exception of - Just (ThreadFailedAsync threadFailedException) -> throwIO threadFailedException + Just (ThreadFailed threadFailedException) -> throwIO threadFailedException Nothing -> throwIO exception -- | Wait until all __threads__ created within a __scope__ finish. @@ -149,6 +154,27 @@ blockUntilNoneStarting :: Scope -> STM () blockUntilNoneStarting Scope {startingVar} = blockUntilTVar startingVar (== 0) + +-------------------------------------------------------------------------------- +-- Internal exception types + +-- | Exception thrown by a parent __thread__ to its children when the __scope__ is closing. +data ScopeClosing + = ScopeClosing + deriving stock (Eq, Show) + +instance Exception ScopeClosing where + toException = asyncExceptionToException + fromException = asyncExceptionFromException + +-- | Exception thrown by a child __thread__ to its parent, if it fails unexpectedly. +newtype ThreadFailed + = ThreadFailed SomeException + deriving stock (Show) + +instance Exception ThreadFailed where + toException = asyncExceptionToException + fromException = asyncExceptionFromException -------------------------------------------------------------------------------- -- Misc. utils diff --git a/src/Ki/ScopeClosing.hs b/src/Ki/ScopeClosing.hs deleted file mode 100644 --- a/src/Ki/ScopeClosing.hs +++ /dev/null @@ -1,16 +0,0 @@ -module Ki.ScopeClosing - ( ScopeClosing (..), - ) -where - -import Control.Exception (Exception (..), asyncExceptionFromException, asyncExceptionToException) -import Ki.Prelude - --- | Exception thrown by a parent __thread__ to its children when the __scope__ is closing. -data ScopeClosing - = ScopeClosing - deriving stock (Eq, Show) - -instance Exception ScopeClosing where - toException = asyncExceptionToException - fromException = asyncExceptionFromException diff --git a/src/Ki/Thread.hs b/src/Ki/Thread.hs --- a/src/Ki/Thread.hs +++ b/src/Ki/Thread.hs @@ -1,5 +1,5 @@ module Ki.Thread - ( Thread, + ( Thread (..), async, asyncWithUnmask, await, @@ -13,21 +13,16 @@ where import Control.Exception (Exception (fromException)) -import Data.Bifunctor (first) import qualified Ki.Context as Context import Ki.Duration (Duration) import Ki.Prelude import Ki.Scope (Scope (Scope)) import qualified Ki.Scope as Scope -import Ki.ScopeClosing (ScopeClosing (ScopeClosing)) -import Ki.ThreadFailed (ThreadFailed (ThreadFailed), ThreadFailedAsync (ThreadFailedAsync)) import Ki.Timeout (timeoutSTM) -- | A running __thread__. -data Thread a = Thread - { threadId :: !ThreadId, - action :: !(STM a) - } +data Thread a + = Thread !ThreadId !(STM a) deriving stock (Functor, Generic) instance Eq (Thread a) where @@ -38,12 +33,12 @@ compare (Thread id1 _) (Thread id2 _) = compare id1 id2 --- | Create a __thread__ within a __scope__ to compute a value concurrently. +-- | Create a __thread__ within a __scope__. -- -- /Throws/: -- -- * Calls 'error' if the __scope__ is /closed/. -async :: Scope -> IO a -> IO (Thread (Either ThreadFailed a)) +async :: Scope -> IO a -> IO (Thread (Either SomeException a)) async scope action = asyncWithRestore scope \restore -> restore action @@ -52,41 +47,35 @@ -- /Throws/: -- -- * Calls 'error' if the __scope__ is /closed/. -asyncWithUnmask :: Scope -> ((forall x. IO x -> IO x) -> IO a) -> IO (Thread (Either ThreadFailed a)) +asyncWithUnmask :: Scope -> ((forall x. IO x -> IO x) -> IO a) -> IO (Thread (Either SomeException a)) asyncWithUnmask scope action = asyncWithRestore scope \restore -> restore (action unsafeUnmask) -asyncWithRestore :: forall a. Scope -> ((forall x. IO x -> IO x) -> IO a) -> IO (Thread (Either ThreadFailed a)) +asyncWithRestore :: forall a. Scope -> ((forall x. IO x -> IO x) -> IO a) -> IO (Thread (Either SomeException a)) asyncWithRestore scope action = do resultVar <- newEmptyTMVarIO - childThreadId <- - Scope.scopeFork scope action \childThreadId result -> - putTMVarIO resultVar (first (ThreadFailed childThreadId) result) + childThreadId <- Scope.scopeFork scope action (putTMVarIO resultVar) pure (Thread childThreadId (readTMVar resultVar)) +-- | Wait for a __thread__ to finish. await :: Thread a -> IO a await = atomically . awaitSTM -- | @STM@ variant of 'await'. awaitSTM :: Thread a -> STM a -awaitSTM Thread {action} = +awaitSTM (Thread _ action) = action -- | Variant of 'await' that gives up after the given duration. --- --- @ --- 'awaitFor' thread duration = --- 'timeout' duration (pure . Just \<$\> 'awaitSTM' thread) (pure Nothing) --- @ awaitFor :: Thread a -> Duration -> IO (Maybe a) awaitFor thread duration = timeoutSTM duration (pure . Just <$> awaitSTM thread) (pure Nothing) --- | Create a __thread__ within a __scope__ to compute a value concurrently. +-- | Create a __thread__ within a __scope__. -- --- If the __thread__ throws an exception, the exception is wrapped in 'ThreadFailed' and immediately propagated up the --- call tree to the __thread__ that opened its __scope__. +-- If the __thread__ throws an exception, the exception is immediately propagated up the call tree to the __thread__ +-- that opened its __scope__. -- -- /Throws/: -- @@ -127,40 +116,45 @@ parentThreadId <- myThreadId resultVar <- newEmptyTMVarIO childThreadId <- - Scope.scopeFork scope action \childThreadId -> \case - Left exception -> do - whenM - (shouldPropagateException scope exception) - (throwTo parentThreadId (ThreadFailedAsync threadFailedException)) - putTMVarIO resultVar (Left threadFailedException) - where - threadFailedException :: ThreadFailed - threadFailedException = - ThreadFailed childThreadId exception - Right result -> putTMVarIO resultVar (Right result) - pure (Thread childThreadId (readTMVar resultVar >>= either throwSTM pure)) + Scope.scopeFork scope action \case + Left exception -> + -- Intentionally don't fill the result var. + -- + -- Prior to 0.2.0, we did put a 'Left exception' in the result var, so that if another thread awaited it, we'd + -- promptly deliver them the exception that brought this thread down. However, that exception was *wrapped* in + -- a 'ThreadFailed' exception, so the caller could distinguish between async exceptions *delivered to them* and + -- async exceptions coming *synchronously* out of the call to 'await'. + -- + -- At some point I reasoned that if one is following some basic structured concurrency guidelines, and not doing + -- weird/complicated things like passing threads around, then it is likely that a failed forked thread is just + -- about to propagate its exception to all callers of 'await' (presumably, its direct parent). + -- + -- Might GHC deliver a BlockedIndefinitelyOnSTM in the meantime, though? + maybePropagateException scope parentThreadId exception + Right result -> putTMVarIO resultVar result + pure (Thread childThreadId (readTMVar resultVar)) forkWithRestore_ :: Scope -> ((forall x. IO x -> IO x) -> IO ()) -> IO () forkWithRestore_ scope action = do parentThreadId <- myThreadId - _childThreadId <- - Scope.scopeFork scope action \childThreadId -> - onLeft \exception -> do - whenM - (shouldPropagateException scope exception) - (throwTo parentThreadId (ThreadFailedAsync (ThreadFailed childThreadId exception))) + _childThreadId <- Scope.scopeFork scope action (onLeft (maybePropagateException scope parentThreadId)) pure () -shouldPropagateException :: Scope -> SomeException -> IO Bool -shouldPropagateException Scope {closedVar, context} exception = - case fromException exception of - -- Our scope is (presumably) closing, so don't propagate this exception that presumably just came from our parent. - -- But if our scope's closedVar isn't True, that means this 'ScopeClosing' definitely came from somewhere else... - Just ScopeClosing -> not <$> readTVarIO closedVar - Nothing -> +maybePropagateException :: Scope -> ThreadId -> SomeException -> IO () +maybePropagateException Scope {closedVar, context} parentThreadId exception = + whenM shouldPropagateException (throwTo parentThreadId (Scope.ThreadFailed exception)) + where + shouldPropagateException :: IO Bool + shouldPropagateException = case fromException exception of - -- We (presumably) are honoring our own cancellation request, so don't propagate that either. - -- It's a bit complicated looking because we *do* want to throw this token if we (somehow) threw it - -- "inappropriately" in the sense that it wasn't ours to throw - it was smuggled from elsewhere. - Just token -> atomically ((/= token) <$> Context.contextCancelTokenSTM context <|> pure True) - Nothing -> pure True + -- Our scope is (presumably) closing, so don't propagate this exception that presumably just came from our + -- parent. But if our scope's closedVar isn't True, that means this 'ScopeClosing' definitely came from + -- somewhere else... + Just Scope.ScopeClosing -> not <$> readTVarIO closedVar + Nothing -> + case fromException exception of + -- We (presumably) are honoring our own cancellation request, so don't propagate that either. + -- It's a bit complicated looking because we *do* want to throw this token if we (somehow) threw it + -- "inappropriately" in the sense that it wasn't ours to throw - it was smuggled from elsewhere. + Just token -> atomically ((/= token) <$> Context.contextCancelTokenSTM context <|> pure True) + Nothing -> pure True diff --git a/src/Ki/ThreadFailed.hs b/src/Ki/ThreadFailed.hs deleted file mode 100644 --- a/src/Ki/ThreadFailed.hs +++ /dev/null @@ -1,27 +0,0 @@ -module Ki.ThreadFailed - ( ThreadFailed (..), - ThreadFailedAsync (..), - ) -where - -import Control.Exception (Exception (..), asyncExceptionFromException, asyncExceptionToException) -import Ki.Prelude - --- | A __thread__ failed, either by throwing or being thrown an exception. -data ThreadFailed = ThreadFailed - { threadId :: ThreadId, - exception :: SomeException - } - deriving stock (Show) - deriving anyclass (Exception) - --- | An async wrapper around 'ThreadFailed', used when a child __thread__ communicates its failure to its parent. This --- is preferred to throwing 'ThreadFailed' directly, so that client code (outside of this library) can follow --- best-practices when encountering a mysterious async exception: clean up resources and re-throw it. -newtype ThreadFailedAsync - = ThreadFailedAsync ThreadFailed - deriving stock (Show) - -instance Exception ThreadFailedAsync where - toException = asyncExceptionToException - fromException = asyncExceptionFromException diff --git a/test/dejafu-tests/DejaFuTests.hs b/test/dejafu-tests/DejaFuTests.hs --- a/test/dejafu-tests/DejaFuTests.hs +++ b/test/dejafu-tests/DejaFuTests.hs @@ -9,12 +9,9 @@ import Control.Concurrent.Classy hiding (fork, forkWithUnmask, wait) import Control.Exception ( Exception (..), - SomeException (..), asyncExceptionFromException, asyncExceptionToException, ) -import Control.Monad -import Data.Maybe import DejaFuTestUtils import Ki.Implicit import Prelude @@ -39,41 +36,11 @@ block -} - -- TODO move to unit test - test "`scoped` kills threads when it throws" (returns True) do - ref <- newIORef False - ignoring @A do - scoped \scope -> do - var <- newEmptyMVar - uninterruptibleMask_ do - forkWithUnmask_ scope \unmask -> do - putMVar var () - unmask block `onException` writeIORef ref True - takeMVar var - void (throw A) - readIORef ref - - -- TODO move to unit test - test "`scoped` kills threads when `fork` throws" (returns True) do - ref <- newIORef False - catch - ( scoped \scope -> do - uninterruptibleMask_ (forkWithUnmask_ scope \unmask -> unmask block `onException` writeIORef ref True) - fork_ scope (throw A) - wait scope - pure False - ) - ( \exception -> - case fromException exception of - Just (ThreadFailed _threadId (fromException -> Just A)) -> readIORef ref - _ -> pure False - ) - test "`scoped` closing while `fork` propagating never deadlocks" (nondeterministic [Right False, Right True]) do ref <- newIORef False catch (scoped \scope -> fork_ scope (throw A)) - (\(ThreadFailed _threadId _exception) -> writeIORef ref True) + (\A -> writeIORef ref True) readIORef ref test "thread waiting on its own scope deadlocks" deadlocks do @@ -96,16 +63,3 @@ instance Exception B where toException = asyncExceptionToException fromException = asyncExceptionFromException - --- finally :: P a -> P b -> P a --- finally action after = --- mask \restore -> do --- result <- restore action `onException` after --- _ <- after --- pure result - -onException :: P a -> P b -> P a -onException action cleanup = - catch @_ @SomeException action \ex -> do - _ <- cleanup - throw ex diff --git a/test/unit-tests/TestUtils.hs b/test/unit-tests/TestUtils.hs --- a/test/unit-tests/TestUtils.hs +++ b/test/unit-tests/TestUtils.hs @@ -1,7 +1,8 @@ {-# LANGUAGE TypeApplications #-} module TestUtils - ( fail, + ( ignoring, + fail, shouldReturn, shouldReturnSuchThat, shouldThrow, @@ -25,6 +26,10 @@ instance Exception TestFailure where displayException (TestFailure message) = message + +ignoring :: forall e. Exception e => IO () -> IO () +ignoring action = + catch action \(_ :: e) -> pure () fail :: String -> IO () fail = diff --git a/test/unit-tests/Tests.hs b/test/unit-tests/Tests.hs --- a/test/unit-tests/Tests.hs +++ b/test/unit-tests/Tests.hs @@ -23,33 +23,33 @@ test "new scope doesn't start out cancelled" do Ki.scoped \_ -> (isJust <$> Ki.cancelled) `shouldReturn` False - test "`cancelScope` observable by scope's `cancelled`" do + test "`cancel` observable by scope's `cancelled`" do Ki.scoped \scope -> do - Ki.cancelScope scope + Ki.cancel scope (isJust <$> Ki.cancelled) `shouldReturn` True - test "`cancelScope` observable by inner scope's `cancelled`" do + test "`cancel` observable by inner scope's `cancelled`" do Ki.scoped \scope -> Ki.scoped \_ -> do - Ki.cancelScope scope + Ki.cancel scope (isJust <$> Ki.cancelled) `shouldReturn` True - childtest "`cancelScope` observable by child's `cancelled`" \fork -> do + childtest "`cancel` observable by child's `cancelled`" \fork -> do ref <- newIORef Nothing Ki.scoped \scope -> do fork scope do - Ki.cancelScope scope + Ki.cancel scope Ki.cancelled >>= writeIORef ref Ki.wait scope (isJust <$> readIORef ref) `shouldReturn` True - childtest "`cancelScope` observable by grandchild's `cancelled`" \fork -> do + childtest "`cancel` observable by grandchild's `cancelled`" \fork -> do ref <- newIORef Nothing Ki.scoped \scope1 -> do fork scope1 do Ki.scoped \scope2 -> do fork scope2 do - Ki.cancelScope scope1 + Ki.cancel scope1 Ki.cancelled >>= writeIORef ref Ki.wait scope2 Ki.wait scope1 @@ -57,13 +57,13 @@ test "inner scope inherits cancellation" do Ki.scoped \scope1 -> do - Ki.cancelScope scope1 + Ki.cancel scope1 Ki.scoped \_ -> (isJust <$> Ki.cancelled) `shouldReturn` True childtest "child thread inherits cancellation" \fork -> do ref <- newIORef Nothing Ki.scoped \scope -> do - Ki.cancelScope scope + Ki.cancel scope fork scope (Ki.cancelled >>= writeIORef ref) Ki.wait scope (isJust <$> readIORef ref) `shouldReturn` True @@ -90,74 +90,72 @@ when (parentThreadId == childThreadId) (fail "didn't create a thread") Ki.wait scope - forktest "propagates sync exceptions" \fork -> do - shouldThrowSuchThat - ( Ki.scoped \scope -> do - fork scope (throwIO A) - Ki.wait scope - ) - (\(Ki.ThreadFailed _threadId exception) -> fromException exception == Just A) + forktest "propagates sync exceptions" \fork -> + ( Ki.scoped \scope -> do + fork scope (throwIO A) + Ki.wait scope + ) + `shouldThrow` A - forktest "propagates async exceptions" \fork -> do - shouldThrowSuchThat - ( Ki.scoped \scope -> do - fork scope (throwIO B) - Ki.wait scope - ) - (\(Ki.ThreadFailed _threadId exception) -> fromException exception == Just B) + forktest "propagates async exceptions" \fork -> + ( Ki.scoped \scope -> do + fork scope (throwIO B) + Ki.wait scope + ) + `shouldThrow` B forktest "doesn't propagate own cancel token exceptions" \fork -> Ki.scoped \scope -> do - Ki.cancelScope scope + Ki.cancel scope fork scope (atomically Ki.cancelledSTM >>= throwIO) Ki.wait scope forktest "propagates ScopeClosing if it isn't ours" \fork -> - shouldThrowSuchThat - ( Ki.scoped \scope -> do - fork scope (throwIO Ki.Internal.ScopeClosing) - Ki.wait scope - ) - (\(Ki.ThreadFailed _threadId exception) -> fromException exception == Just Ki.Internal.ScopeClosing) + ( Ki.scoped \scope -> do + fork scope (throwIO Ki.Internal.ScopeClosing) + Ki.wait scope + ) + `shouldThrow` Ki.Internal.ScopeClosing forktest "propagates others' cancel token exceptions" \fork -> - shouldThrowSuchThat - ( Ki.scoped \scope -> do - Ki.cancelScope scope - fork scope (throwIO (Ki.Internal.CancelToken 0)) - Ki.wait scope - ) - (\(Ki.ThreadFailed _threadId exception) -> fromException exception == Just (Ki.Internal.CancelToken 0)) + ( Ki.scoped \scope -> do + Ki.cancel scope + fork scope (throwIO (Ki.Internal.CancelToken 0)) + Ki.wait scope + ) + `shouldThrow` Ki.Internal.CancelToken 0 test "`async` returns sync exceptions" do Ki.scoped \scope -> do result <- Ki.async @() scope (throw A) Ki.await result `shouldReturnSuchThat` \case - Left (Ki.ThreadFailed _threadId exception) -> fromException exception == Just A + Left (fromException -> Just A) -> True _ -> False test "`async` returns async exceptions" do Ki.scoped \scope -> do result <- Ki.async @() scope (throw B) Ki.await result `shouldReturnSuchThat` \case - Left (Ki.ThreadFailed _threadId exception) -> fromException exception == Just B + Left (fromException -> Just B) -> True _ -> False - test "awaiting a failed `fork`ed thread throws the sync exception it failed with" do + test "awaiting a failed `fork`ed thread blocks" do Ki.scoped \scope -> do mask \unmask -> do thread <- Ki.fork @() scope (throw A) - unmask (Ki.wait scope) `catch` \(Ki.Internal.ThreadFailedAsync _) -> pure () - Ki.await thread - `shouldThrowSuchThat` \(Ki.ThreadFailed _threadId exception) -> fromException exception == Just A + unmask (Ki.wait scope) `catch` \(Ki.Internal.ThreadFailed _) -> pure () + Ki.await thread `shouldThrowSuchThat` \case + (fromException -> Just BlockedIndefinitelyOnSTM) -> True + _ -> False - test "awaiting a failed `fork`ed thread throws the async exception it failed with" do + test "awaiting a failed `fork`ed thread blocks" do Ki.scoped \scope -> do mask \unmask -> do thread <- Ki.fork @() scope (throw B) - unmask (Ki.wait scope) `catch` \(Ki.Internal.ThreadFailedAsync _) -> pure () - Ki.await thread - `shouldThrowSuchThat` \(Ki.ThreadFailed _threadId exception) -> fromException exception == Just B + unmask (Ki.wait scope) `catch` \(Ki.Internal.ThreadFailed _) -> pure () + Ki.await thread `shouldThrowSuchThat` \case + (fromException -> Just BlockedIndefinitelyOnSTM) -> True + _ -> False childtest "inherits masking state" \fork -> do Ki.scoped \scope -> do @@ -188,6 +186,29 @@ Ki.wait scope pure thread Ki.await thread `shouldReturn` () + + test "parent kills children when it throws" do + ref <- newIORef False + ignoring @A do + Ki.scoped \scope -> do + var <- newEmptyMVar + uninterruptibleMask_ do + Ki.forkWithUnmask_ scope \unmask -> do + putMVar var () + unmask (threadDelay 1_000_000) `onException` writeIORef ref True + takeMVar var + void (throw A) + readIORef ref `shouldReturn` True + + test "parent kills children when child throws" do + ref <- newIORef False + ignoring @A do + Ki.scoped \scope -> do + uninterruptibleMask_ do + (Ki.forkWithUnmask_ scope \unmask -> unmask (threadDelay 1_000_000) `onException` writeIORef ref True) + Ki.fork_ scope (throw A) + Ki.wait scope + readIORef ref `shouldReturn` True forktest :: String -> (Ki.Context => (Ki.Scope -> (Ki.Context => IO ()) -> IO ()) -> IO ()) -> IO () forktest name theTest = do