-- |
-- Module      : Streamly.Internal.Control.ForkLifted
-- Copyright   : (c) 2017 Composewell Technologies
-- License     : BSD-3-Clause
-- Maintainer  : streamly@composewell.com
-- Stability   : experimental
-- Portability : GHC

module Streamly.Internal.Control.ForkLifted
    (
      doFork
    , fork
    , forkManaged
    )
where

import Control.Concurrent (ThreadId, forkIO)
import Control.Exception (SomeException(..), catch, mask)
import Data.Functor (void)
import Streamly.Internal.Control.Concurrent (MonadRunInIO, RunInIO(..), withRunInIO, withRunInIONoRestore)
import Streamly.Internal.Control.ForkIO (rawForkIO, forkManagedWith)

-- | Fork a thread to run the given computation, installing the provided
-- exception handler. Lifted to any monad with 'MonadRunInIO m'
-- capability.
--
-- TODO: the RunInIO argument can be removed, we can directly pass the action
-- as "mrun action" instead.
{-# INLINE doFork #-}
doFork :: MonadRunInIO m
    => m ()
    -> RunInIO m
    -> (SomeException -> IO ())
    -> m ThreadId
doFork :: m () -> RunInIO m -> (SomeException -> IO ()) -> m ThreadId
doFork m ()
action (RunInIO forall b. m b -> IO (StM m b)
mrun) SomeException -> IO ()
exHandler =
    ((forall b. m b -> IO (StM m b)) -> IO (StM m ThreadId))
-> m ThreadId
forall (m :: * -> *) b.
MonadRunInIO m =>
((forall a. m a -> IO (StM m a)) -> IO (StM m b)) -> m b
withRunInIO (((forall b. m b -> IO (StM m b)) -> IO (StM m ThreadId))
 -> m ThreadId)
-> ((forall b. m b -> IO (StM m b)) -> IO (StM m ThreadId))
-> m ThreadId
forall a b. (a -> b) -> a -> b
$ \forall b. m b -> IO (StM m b)
run ->
        ((forall a. IO a -> IO a) -> IO (StM m ThreadId))
-> IO (StM m ThreadId)
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO (StM m ThreadId))
 -> IO (StM m ThreadId))
-> ((forall a. IO a -> IO a) -> IO (StM m ThreadId))
-> IO (StM m ThreadId)
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
                ThreadId
tid <- IO () -> IO ThreadId
rawForkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (IO () -> IO ()
forall a. IO a -> IO a
restore (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO (StM m ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (StM m ()) -> IO ()) -> IO (StM m ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ m () -> IO (StM m ())
forall b. m b -> IO (StM m b)
mrun m ()
action)
                                         SomeException -> IO ()
exHandler
                m ThreadId -> IO (StM m ThreadId)
forall b. m b -> IO (StM m b)
run (ThreadId -> m ThreadId
forall (m :: * -> *) a. Monad m => a -> m a
return ThreadId
tid)

-- | 'fork' lifted to any monad with 'MonadBaseControl IO m' capability.
--
{-# INLINABLE fork #-}
fork :: MonadRunInIO m => m () -> m ThreadId
fork :: m () -> m ThreadId
fork m ()
m = ((forall a. m a -> IO (StM m a)) -> IO ThreadId) -> m ThreadId
forall (m :: * -> *) b.
MonadRunInIO m =>
((forall a. m a -> IO (StM m a)) -> IO b) -> m b
withRunInIONoRestore (((forall a. m a -> IO (StM m a)) -> IO ThreadId) -> m ThreadId)
-> ((forall a. m a -> IO (StM m a)) -> IO ThreadId) -> m ThreadId
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO (StM m a)
run -> IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO (StM m ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (StM m ()) -> IO ()) -> IO (StM m ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ m () -> IO (StM m ())
forall a. m a -> IO (StM m a)
run m ()
m

-- | Fork a thread that is automatically killed as soon as the reference to the
-- returned threadId is garbage collected.
--
{-# INLINABLE forkManaged #-}
forkManaged :: MonadRunInIO m => m () -> m ThreadId
forkManaged :: m () -> m ThreadId
forkManaged = (m () -> m ThreadId) -> m () -> m ThreadId
forall (m :: * -> *).
MonadIO m =>
(m () -> m ThreadId) -> m () -> m ThreadId
forkManagedWith m () -> m ThreadId
forall (m :: * -> *). MonadRunInIO m => m () -> m ThreadId
fork