packages feed

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 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