-- |
-- 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
    , doForkWith
    , fork
    , forkManaged
    )
where

import Control.Concurrent (ThreadId, forkIO, forkOS)
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 :: forall (m :: * -> *).
MonadRunInIO m =>
m () -> RunInIO m -> (SomeException -> IO ()) -> m ThreadId
doFork = Bool -> m () -> RunInIO m -> (SomeException -> IO ()) -> m ThreadId
forall (m :: * -> *).
MonadRunInIO m =>
Bool -> m () -> RunInIO m -> (SomeException -> IO ()) -> m ThreadId
doForkWith Bool
False

-- | Similar to 'doFork', but has a \"bound\" boolean parameter for specifying
-- whether 'forkOS' should be used instead of 'rawForkIO'.
{-# INLINE doForkWith #-}
doForkWith :: MonadRunInIO m
    => Bool
    -> m ()
    -> RunInIO m
    -> (SomeException -> IO ())
    -> m ThreadId
doForkWith :: forall (m :: * -> *).
MonadRunInIO m =>
Bool -> m () -> RunInIO m -> (SomeException -> IO ()) -> m ThreadId
doForkWith Bool
bound 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 <- (if Bool
bound then IO () -> IO ThreadId
forkOS else 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 a. a -> m a
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 :: forall (m :: * -> *). MonadRunInIO m => 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 :: forall (m :: * -> *). MonadRunInIO m => 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