ForkLifted.hs

-- |
-- 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 = doForkWith 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 bound action (RunInIO mrun) exHandler =
    withRunInIO $ \run ->
        mask $ \restore -> do
                let frk = if bound then forkOS else rawForkIO
                tid <- frk $ catch (restore $ void $ mrun action) exHandler
                run (return tid)

-- | 'fork' lifted to any monad with 'MonadBaseControl IO m' capability.
--
{-# INLINABLE fork #-}
fork :: MonadRunInIO m => m () -> m ThreadId
fork m = withRunInIONoRestore $ \run -> forkIO $ void $ run 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 = forkManagedWith fork