Merge pull request #123 from input-output-hk/coot/forkFinally

Added forkFinally to MonadFork

Author: coot

io-classes/CHANGELOG.md

@@ -6,6 +6,8 @@
 
 ### Non-breaking changes
 
+* Added `forkFinally` to `MonadFork`.
+
 ## 1.3.0.0
 
 - `io-sim-1.3.0.0`.

io-classes/src/Control/Monad/Class/MonadFork.hs

@@ -10,7 +10,7 @@ module Control.Monad.Class.MonadFork
   ) where
 
 import qualified Control.Concurrent as IO
-import           Control.Exception (AsyncException (ThreadKilled), Exception)
+import           Control.Exception (AsyncException (ThreadKilled), Exception, SomeException)
 import           Control.Monad.Reader (ReaderT (..), lift)
 import           Data.Kind (Type)
 import qualified GHC.Conc.Sync as IO (labelThread)
@@ -35,6 +35,7 @@ class MonadThread m => MonadFork m where
   forkIO           :: m () -> m (ThreadId m)
   forkOn           :: Int -> m () -> m (ThreadId m)
   forkIOWithUnmask :: ((forall a. m a -> m a) -> m ()) -> m (ThreadId m)
+  forkFinally      :: m a -> (Either SomeException a -> m ()) -> m (ThreadId m)
   throwTo          :: Exception e => ThreadId m -> e -> m ()
 
   killThread       :: ThreadId m -> m ()
@@ -52,6 +53,7 @@ instance MonadFork IO where
   forkIO           = IO.forkIO
   forkOn           = IO.forkOn
   forkIOWithUnmask = IO.forkIOWithUnmask
+  forkFinally      = IO.forkFinally
   throwTo          = IO.throwTo
   killThread       = IO.killThread
   yield            = IO.yield
@@ -68,5 +70,7 @@ instance MonadFork m => MonadFork (ReaderT e m) where
                          let restore' :: ReaderT e m a -> ReaderT e m a
                              restore' (ReaderT f) = ReaderT $ restore . f
                          in runReaderT (k restore') e
+  forkFinally f k     = ReaderT $ \e -> forkFinally (runReaderT f e)
+                                      $ \err -> runReaderT (k err) e
   throwTo e t = lift (throwTo e t)
   yield       = lift yield

io-sim/src/Control/Monad/IOSim/Types.hs

@@ -458,6 +458,8 @@ instance MonadFork (IOSim s) where
   forkIO task        = IOSim $ oneShot $ \k -> Fork task k
   forkOn _ task      = IOSim $ oneShot $ \k -> Fork task k
   forkIOWithUnmask f = forkIO (f unblock)
+  forkFinally task k = mask $ \restore ->
+                       forkIO $ try (restore task) >>= k
   throwTo tid e      = IOSim $ oneShot $ \k -> ThrowTo (toException e) tid (k ())
   yield              = IOSim $ oneShot $ \k -> YieldSim (k ())