ki 0.1.0.1 → 0.2.0
raw patch · 13 files changed
+199/−302 lines, 13 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
- Ki: ThreadFailed :: ThreadId -> SomeException -> ThreadFailed
- Ki: [$sel:exception:ThreadFailed] :: ThreadFailed -> SomeException
- Ki: [$sel:threadId:ThreadFailed] :: ThreadFailed -> ThreadId
- Ki: data ThreadFailed
- Ki.Implicit: ThreadFailed :: ThreadId -> SomeException -> ThreadFailed
- Ki.Implicit: [$sel:exception:ThreadFailed] :: ThreadFailed -> SomeException
- Ki.Implicit: [$sel:threadId:ThreadFailed] :: ThreadFailed -> ThreadId
- Ki.Implicit: cancelScope :: Scope -> IO ()
- Ki.Implicit: data ThreadFailed
- Ki.Internal: ThreadFailedAsync :: ThreadFailed -> ThreadFailedAsync
- Ki.Internal: [$sel:exception:ThreadFailed] :: ThreadFailed -> SomeException
- Ki.Internal: [$sel:threadId:ThreadFailed] :: ThreadFailed -> ThreadId
- Ki.Internal: cancelScope :: Scope -> IO ()
- Ki.Internal: data ThreadFailed
- Ki.Internal: newtype ThreadFailedAsync
+ Ki.Implicit: cancel :: Scope -> IO ()
+ Ki.Internal: Thread :: !ThreadId -> !STM a -> Thread a
+ Ki.Internal: cancel :: Scope -> IO ()
+ Ki.Internal: newtype ThreadFailed
- Ki: async :: Scope -> IO a -> IO (Thread (Either ThreadFailed a))
+ Ki: async :: Scope -> IO a -> IO (Thread (Either SomeException a))
- Ki: asyncWithUnmask :: Scope -> ((forall x. IO x -> IO x) -> IO a) -> IO (Thread (Either ThreadFailed a))
+ Ki: asyncWithUnmask :: Scope -> ((forall x. IO x -> IO x) -> IO a) -> IO (Thread (Either SomeException a))
- Ki.Implicit: async :: Scope -> (Context => IO a) -> IO (Thread (Either ThreadFailed a))
+ Ki.Implicit: async :: Scope -> (Context => IO a) -> IO (Thread (Either SomeException a))
- Ki.Implicit: asyncWithUnmask :: Scope -> (Context => (forall x. IO x -> IO x) -> IO a) -> IO (Thread (Either ThreadFailed a))
+ Ki.Implicit: asyncWithUnmask :: Scope -> (Context => (forall x. IO x -> IO x) -> IO a) -> IO (Thread (Either SomeException a))
- Ki.Internal: ThreadFailed :: ThreadId -> SomeException -> ThreadFailed
+ Ki.Internal: ThreadFailed :: SomeException -> ThreadFailed
- Ki.Internal: async :: Scope -> IO a -> IO (Thread (Either ThreadFailed a))
+ Ki.Internal: async :: Scope -> IO a -> IO (Thread (Either SomeException a))
- Ki.Internal: asyncWithUnmask :: Scope -> ((forall x. IO x -> IO x) -> IO a) -> IO (Thread (Either ThreadFailed a))
+ Ki.Internal: asyncWithUnmask :: Scope -> ((forall x. IO x -> IO x) -> IO a) -> IO (Thread (Either SomeException a))
- Ki.Internal: scopeFork :: Scope -> ((forall x. IO x -> IO x) -> IO a) -> (ThreadId -> Either SomeException a -> IO ()) -> IO ThreadId
+ Ki.Internal: scopeFork :: Scope -> ((forall x. IO x -> IO x) -> IO a) -> (Either SomeException a -> IO ()) -> IO ThreadId
Files
- CHANGELOG.md +8/−0
- README.md +1/−1
- ki.cabal +13/−14
- src/Ki.hs +4/−35
- src/Ki/Implicit.hs +13/−45
- src/Ki/Internal.hs +0/−4
- src/Ki/Scope.hs +36/−10
- src/Ki/ScopeClosing.hs +0/−16
- src/Ki/Thread.hs +48/−54
- src/Ki/ThreadFailed.hs +0/−27
- test/dejafu-tests/DejaFuTests.hs +1/−47
- test/unit-tests/TestUtils.hs +6/−1
- test/unit-tests/Tests.hs +69/−48
CHANGELOG.md view
@@ -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
README.md view
@@ -88,7 +88,7 @@ canceled. ```haskell-cancelScope :: Scope -> IO ()+cancel :: Scope -> IO () cancelled :: Context => IO (Maybe CancelToken) ```
ki.cabal view
@@ -10,35 +10,35 @@ maintainer: Mitchell Rosen <mitchellwrosen@gmail.com> 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- <https://www.haskell.org/cabal/users-guide/developing-packages.html#pkg-field-mixins mixin stanza>+ <https://cabal.readthedocs.io/en/latest/cabal-package.html#pkg-field-mixins mixin stanza> 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:
src/Ki.hs view
@@ -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__ --
src/Ki/Implicit.hs view
@@ -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 ())
src/Ki/Internal.hs view
@@ -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
src/Ki/Scope.hs view
@@ -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
− src/Ki/ScopeClosing.hs
@@ -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
src/Ki/Thread.hs view
@@ -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
− src/Ki/ThreadFailed.hs
@@ -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
test/dejafu-tests/DejaFuTests.hs view
@@ -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
test/unit-tests/TestUtils.hs view
@@ -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 =
test/unit-tests/Tests.hs view
@@ -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