{-# LANGUAGE CPP, NoImplicitPrelude, FlexibleContexts, RankNTypes #-}

#if __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Safe #-}
#endif

{- |
Module      :  Control.Concurrent.Lifted
Copyright   :  Bas van Dijk
License     :  BSD-style

Maintainer  :  Bas van Dijk <v.dijk.bas@gmail.com>
Stability   :  experimental

This is a wrapped version of "Control.Concurrent" with types generalized
from 'IO' to all monads in either 'MonadBase' or 'MonadBaseControl'.
-}

module Control.Concurrent.Lifted
    ( -- * Concurrent Haskell
      ThreadId

      -- * Basic concurrency operations
    , myThreadId
    , fork
#if MIN_VERSION_base(4,4,0)
    , forkWithUnmask
#endif
#if MIN_VERSION_base(4,6,0)
    , forkFinally
#endif
    , killThread
    , throwTo

#if MIN_VERSION_base(4,4,0)
      -- ** Threads with affinity
    , forkOn
    , forkOnWithUnmask
    , getNumCapabilities
#if MIN_VERSION_base(4,6,0)
    , setNumCapabilities
#endif
    , threadCapability
#endif

      -- * Scheduling
    , yield

      -- ** Blocking
      -- ** Waiting
    , threadDelay
    , threadWaitRead
    , threadWaitWrite

      -- * Communication abstractions
    , module Control.Concurrent.MVar.Lifted
    , module Control.Concurrent.Chan.Lifted
    , module Control.Concurrent.QSem.Lifted
    , module Control.Concurrent.QSemN.Lifted
#if !MIN_VERSION_base(4,7,0)
    , module Control.Concurrent.SampleVar.Lifted
#endif

#if !MIN_VERSION_base(4,6,0)
      -- * Merging of streams
    , merge
    , nmerge
#endif

      -- * Bound Threads
    , C.rtsSupportsBoundThreads
    , forkOS
    , isCurrentThreadBound
    , runInBoundThread
    , runInUnboundThread

#if MIN_VERSION_base(4,6,0)
      -- * Weak references to ThreadIds
    , mkWeakThreadId
#endif
    ) where


--------------------------------------------------------------------------------
-- Imports
--------------------------------------------------------------------------------

-- from base:
import Prelude            ( (.) )
import Data.Bool          ( Bool )
import Data.Int           ( Int )
import Data.Function      ( ($) )
import System.IO          ( IO )
import System.Posix.Types ( Fd )
#if MIN_VERSION_base(4,6,0)
import Control.Monad      ( (>>=) )
import Data.Either        ( Either )
import System.Mem.Weak    ( Weak )
#endif

import           Control.Concurrent ( ThreadId )
import qualified Control.Concurrent as C

-- from transformers-base:
import Control.Monad.Base ( MonadBase, liftBase )

-- from monad-control:
import Control.Monad.Trans.Control ( MonadBaseControl, liftBaseOp_, liftBaseDiscard )

#if MIN_VERSION_base(4,4,0)
import Control.Monad.Trans.Control ( liftBaseWith )
import Control.Monad               ( void )
#endif

-- from lifted-base (this package):
import Control.Concurrent.MVar.Lifted
import Control.Concurrent.Chan.Lifted
import Control.Concurrent.QSem.Lifted
import Control.Concurrent.QSemN.Lifted
#if !MIN_VERSION_base(4,7,0)
import Control.Concurrent.SampleVar.Lifted
#endif
import Control.Exception.Lifted ( throwTo
#if MIN_VERSION_base(4,6,0)
                                , SomeException, try, mask
#endif
                                )
#include "inlinable.h"


--------------------------------------------------------------------------------
-- Control.Concurrent
--------------------------------------------------------------------------------

-- | Generalized version of 'C.myThreadId'.
myThreadId :: MonadBase IO m => m ThreadId
myThreadId :: forall (m :: * -> *). MonadBase IO m => m ThreadId
myThreadId = IO ThreadId -> m ThreadId
forall α. IO α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase IO ThreadId
C.myThreadId
{-# INLINABLE myThreadId #-}

-- | Generalized version of 'C.forkIO'.
--
-- Note that, while the forked computation @m ()@ has access to the captured
-- state, all its side-effects in @m@ are discarded. It is run only for its
-- side-effects in 'IO'.
fork :: MonadBaseControl IO m => m () -> m ThreadId
fork :: forall (m :: * -> *). MonadBaseControl IO m => m () -> m ThreadId
fork = (IO () -> IO ThreadId) -> m () -> m ThreadId
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(b () -> b a) -> m () -> m a
liftBaseDiscard IO () -> IO ThreadId
C.forkIO
{-# INLINABLE fork #-}

#if MIN_VERSION_base(4,4,0)
-- | Generalized version of 'C.forkIOWithUnmask'.
--
-- Note that, while the forked computation @m ()@ has access to the captured
-- state, all its side-effects in @m@ are discarded. It is run only for its
-- side-effects in 'IO'.
forkWithUnmask :: MonadBaseControl IO m => ((forall a. m a -> m a) -> m ()) -> m ThreadId
forkWithUnmask :: forall (m :: * -> *).
MonadBaseControl IO m =>
((forall a. m a -> m a) -> m ()) -> m ThreadId
forkWithUnmask (forall a. m a -> m a) -> m ()
f = (RunInBase m IO -> IO ThreadId) -> m ThreadId
forall a. (RunInBase m IO -> IO a) -> m a
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b a) -> m a
liftBaseWith ((RunInBase m IO -> IO ThreadId) -> m ThreadId)
-> (RunInBase m IO -> IO ThreadId) -> m ThreadId
forall a b. (a -> b) -> a -> b
$ \RunInBase m IO
runInIO ->
                     ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
C.forkIOWithUnmask (((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId)
-> ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask ->
                       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 ())
RunInBase m IO
runInIO (m () -> IO (StM m ())) -> m () -> IO (StM m ())
forall a b. (a -> b) -> a -> b
$ (forall a. m a -> m a) -> m ()
f ((forall a. m a -> m a) -> m ()) -> (forall a. m a -> m a) -> m ()
forall a b. (a -> b) -> a -> b
$ (IO (StM m a) -> IO (StM m a)) -> m a -> m a
forall (b :: * -> *) (m :: * -> *) a c.
MonadBaseControl b m =>
(b (StM m a) -> b (StM m c)) -> m a -> m c
liftBaseOp_ IO (StM m a) -> IO (StM m a)
forall a. IO a -> IO a
unmask
{-# INLINABLE forkWithUnmask #-}
#endif

#if MIN_VERSION_base(4,6,0)
-- | Generalized version of 'C.forkFinally'.
--
-- Note that in @forkFinally action and_then@, while the forked
-- @action@ and the @and_then@ function have access to the captured
-- state, all their side-effects in @m@ are discarded. They're run
-- only for their side-effects in 'IO'.
forkFinally :: MonadBaseControl IO m
            => m a -> (Either SomeException a -> m ()) -> m ThreadId
forkFinally :: forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> (Either SomeException a -> m ()) -> m ThreadId
forkFinally m a
action Either SomeException a -> m ()
and_then =
    ((forall a. m a -> m a) -> m ThreadId) -> m ThreadId
forall (m :: * -> *) b.
MonadBaseControl IO m =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. m a -> m a) -> m ThreadId) -> m ThreadId)
-> ((forall a. m a -> m a) -> m ThreadId) -> m ThreadId
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
restore ->
      m () -> m ThreadId
forall (m :: * -> *). MonadBaseControl IO m => m () -> m ThreadId
fork (m () -> m ThreadId) -> m () -> m ThreadId
forall a b. (a -> b) -> a -> b
$ m a -> m (Either SomeException a)
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> m (Either e a)
try (m a -> m a
forall a. m a -> m a
restore m a
action) m (Either SomeException a)
-> (Either SomeException a -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either SomeException a -> m ()
and_then
{-# INLINABLE forkFinally #-}
#endif

-- | Generalized version of 'C.killThread'.
killThread :: MonadBase IO m => ThreadId -> m ()
killThread :: forall (m :: * -> *). MonadBase IO m => ThreadId -> m ()
killThread = IO () -> m ()
forall α. IO α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> m ()) -> (ThreadId -> IO ()) -> ThreadId -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThreadId -> IO ()
C.killThread
{-# INLINABLE  killThread #-}

#if MIN_VERSION_base(4,4,0)
-- | Generalized version of 'C.forkOn'.
--
-- Note that, while the forked computation @m ()@ has access to the captured
-- state, all its side-effects in @m@ are discarded. It is run only for its
-- side-effects in 'IO'.
forkOn :: MonadBaseControl IO m => Int -> m () -> m ThreadId
forkOn :: forall (m :: * -> *).
MonadBaseControl IO m =>
Int -> m () -> m ThreadId
forkOn = (IO () -> IO ThreadId) -> m () -> m ThreadId
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(b () -> b a) -> m () -> m a
liftBaseDiscard ((IO () -> IO ThreadId) -> m () -> m ThreadId)
-> (Int -> IO () -> IO ThreadId) -> Int -> m () -> m ThreadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IO () -> IO ThreadId
C.forkOn
{-# INLINABLE forkOn #-}

-- | Generalized version of 'C.forkOnWithUnmask'.
--
-- Note that, while the forked computation @m ()@ has access to the captured
-- state, all its side-effects in @m@ are discarded. It is run only for its
-- side-effects in 'IO'.
forkOnWithUnmask :: MonadBaseControl IO m => Int -> ((forall a. m a -> m a) -> m ()) -> m ThreadId
forkOnWithUnmask :: forall (m :: * -> *).
MonadBaseControl IO m =>
Int -> ((forall a. m a -> m a) -> m ()) -> m ThreadId
forkOnWithUnmask Int
cap (forall a. m a -> m a) -> m ()
f = (RunInBase m IO -> IO ThreadId) -> m ThreadId
forall a. (RunInBase m IO -> IO a) -> m a
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b a) -> m a
liftBaseWith ((RunInBase m IO -> IO ThreadId) -> m ThreadId)
-> (RunInBase m IO -> IO ThreadId) -> m ThreadId
forall a b. (a -> b) -> a -> b
$ \RunInBase m IO
runInIO ->
                           Int -> ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
C.forkOnWithUnmask Int
cap (((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId)
-> ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask ->
                             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 ())
RunInBase m IO
runInIO (m () -> IO (StM m ())) -> m () -> IO (StM m ())
forall a b. (a -> b) -> a -> b
$ (forall a. m a -> m a) -> m ()
f ((forall a. m a -> m a) -> m ()) -> (forall a. m a -> m a) -> m ()
forall a b. (a -> b) -> a -> b
$ (IO (StM m a) -> IO (StM m a)) -> m a -> m a
forall (b :: * -> *) (m :: * -> *) a c.
MonadBaseControl b m =>
(b (StM m a) -> b (StM m c)) -> m a -> m c
liftBaseOp_ IO (StM m a) -> IO (StM m a)
forall a. IO a -> IO a
unmask
{-# INLINABLE forkOnWithUnmask #-}

-- | Generalized version of 'C.getNumCapabilities'.
getNumCapabilities :: MonadBase IO m => m Int
getNumCapabilities :: forall (m :: * -> *). MonadBase IO m => m Int
getNumCapabilities = IO Int -> m Int
forall α. IO α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase IO Int
C.getNumCapabilities
{-# INLINABLE getNumCapabilities #-}

#if MIN_VERSION_base(4,6,0)
-- | Generalized version of 'C.setNumCapabilities'.
setNumCapabilities :: MonadBase IO m => Int -> m ()
setNumCapabilities :: forall (m :: * -> *). MonadBase IO m => Int -> m ()
setNumCapabilities = IO () -> m ()
forall α. IO α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> m ()) -> (Int -> IO ()) -> Int -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IO ()
C.setNumCapabilities
{-# INLINABLE setNumCapabilities #-}
#endif

-- | Generalized version of 'C.threadCapability'.
threadCapability :: MonadBase IO m => ThreadId -> m (Int, Bool)
threadCapability :: forall (m :: * -> *). MonadBase IO m => ThreadId -> m (Int, Bool)
threadCapability = IO (Int, Bool) -> m (Int, Bool)
forall α. IO α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (Int, Bool) -> m (Int, Bool))
-> (ThreadId -> IO (Int, Bool)) -> ThreadId -> m (Int, Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThreadId -> IO (Int, Bool)
C.threadCapability
{-# INLINABLE threadCapability #-}
#endif

-- | Generalized version of 'C.yield'.
yield :: MonadBase IO m => m ()
yield :: forall (m :: * -> *). MonadBase IO m => m ()
yield = IO () -> m ()
forall α. IO α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase IO ()
C.yield
{-# INLINABLE yield #-}

-- | Generalized version of 'C.threadDelay'.
threadDelay :: MonadBase IO m => Int -> m ()
threadDelay :: forall (m :: * -> *). MonadBase IO m => Int -> m ()
threadDelay = IO () -> m ()
forall α. IO α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> m ()) -> (Int -> IO ()) -> Int -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  Int -> IO ()
C.threadDelay
{-# INLINABLE threadDelay #-}

-- | Generalized version of 'C.threadWaitRead'.
threadWaitRead :: MonadBase IO m => Fd -> m ()
threadWaitRead :: forall (m :: * -> *). MonadBase IO m => Fd -> m ()
threadWaitRead = IO () -> m ()
forall α. IO α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> m ()) -> (Fd -> IO ()) -> Fd -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fd -> IO ()
C.threadWaitRead
{-# INLINABLE threadWaitRead #-}

-- | Generalized version of 'C.threadWaitWrite'.
threadWaitWrite :: MonadBase IO m => Fd -> m ()
threadWaitWrite :: forall (m :: * -> *). MonadBase IO m => Fd -> m ()
threadWaitWrite = IO () -> m ()
forall α. IO α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> m ()) -> (Fd -> IO ()) -> Fd -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fd -> IO ()
C.threadWaitWrite
{-# INLINABLE threadWaitWrite #-}

#if !MIN_VERSION_base(4,6,0)
-- | Generalized version of 'C.mergeIO'.
merge :: MonadBase IO m => [a] -> [a] -> m [a]
merge xs ys = liftBase $ C.mergeIO xs ys
{-# INLINABLE merge #-}

-- | Generalized version of 'C.nmergeIO'.
nmerge :: MonadBase IO m => [[a]] -> m [a]
nmerge = liftBase . C.nmergeIO
{-# INLINABLE nmerge #-}
#endif

-- | Generalized version of 'C.forkOS'.
--
-- Note that, while the forked computation @m ()@ has access to the captured
-- state, all its side-effects in @m@ are discarded. It is run only for its
-- side-effects in 'IO'.
forkOS :: MonadBaseControl IO m => m () -> m ThreadId
forkOS :: forall (m :: * -> *). MonadBaseControl IO m => m () -> m ThreadId
forkOS = (IO () -> IO ThreadId) -> m () -> m ThreadId
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(b () -> b a) -> m () -> m a
liftBaseDiscard IO () -> IO ThreadId
C.forkOS
{-# INLINABLE forkOS #-}

-- | Generalized version of 'C.isCurrentThreadBound'.
isCurrentThreadBound :: MonadBase IO m => m Bool
isCurrentThreadBound :: forall (m :: * -> *). MonadBase IO m => m Bool
isCurrentThreadBound = IO Bool -> m Bool
forall α. IO α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase IO Bool
C.isCurrentThreadBound
{-# INLINABLE isCurrentThreadBound #-}

-- | Generalized version of 'C.runInBoundThread'.
runInBoundThread :: MonadBaseControl IO m => m a -> m a
runInBoundThread :: forall (m :: * -> *) a. MonadBaseControl IO m => m a -> m a
runInBoundThread = (IO (StM m a) -> IO (StM m a)) -> m a -> m a
forall (b :: * -> *) (m :: * -> *) a c.
MonadBaseControl b m =>
(b (StM m a) -> b (StM m c)) -> m a -> m c
liftBaseOp_ IO (StM m a) -> IO (StM m a)
forall a. IO a -> IO a
C.runInBoundThread
{-# INLINABLE runInBoundThread #-}

-- | Generalized version of 'C.runInUnboundThread'.
runInUnboundThread :: MonadBaseControl IO m => m a -> m a
runInUnboundThread :: forall (m :: * -> *) a. MonadBaseControl IO m => m a -> m a
runInUnboundThread = (IO (StM m a) -> IO (StM m a)) -> m a -> m a
forall (b :: * -> *) (m :: * -> *) a c.
MonadBaseControl b m =>
(b (StM m a) -> b (StM m c)) -> m a -> m c
liftBaseOp_ IO (StM m a) -> IO (StM m a)
forall a. IO a -> IO a
C.runInUnboundThread
{-# INLINABLE runInUnboundThread #-}

#if MIN_VERSION_base(4,6,0)
-- | Generalized versio  of 'C.mkWeakThreadId'.
mkWeakThreadId :: MonadBase IO m => ThreadId -> m (Weak ThreadId)
mkWeakThreadId :: forall (m :: * -> *).
MonadBase IO m =>
ThreadId -> m (Weak ThreadId)
mkWeakThreadId = IO (Weak ThreadId) -> m (Weak ThreadId)
forall α. IO α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (Weak ThreadId) -> m (Weak ThreadId))
-> (ThreadId -> IO (Weak ThreadId))
-> ThreadId
-> m (Weak ThreadId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThreadId -> IO (Weak ThreadId)
C.mkWeakThreadId
{-# INLINABLE mkWeakThreadId #-}
#endif