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

#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Trustworthy #-}
#endif

--------------------------------------------------------------------------------
-- |
-- Module     : Control.Concurrent.Thread
-- Copyright  : (c) 2010-2012 Bas van Dijk & Roel van Dijk
-- License    : BSD3 (see the file LICENSE)
-- Maintainer : Bas van Dijk <v.dijk.bas@gmail.com>
--            , Roel van Dijk <vandijk.roel@gmail.com>
--
-- Standard threads extended with the ability to /wait/ for their return value.
--
-- This module exports equivalently named functions from @Control.Concurrent@
-- (and @GHC.Conc@). Avoid ambiguities by importing this module qualified. May
-- we suggest:
--
-- @
-- import qualified Control.Concurrent.Thread as Thread ( ... )
-- @
--
-- The following is an example how to use this module:
--
-- @
--
-- import qualified Control.Concurrent.Thread as Thread ( 'forkIO', 'result' )
--
-- main = do (tid, wait) <- Thread.'forkIO' $ do x <- someExpensiveComputation
--                                            return x
--          doSomethingElse
--          x <- Thread.'result' =<< 'wait'
--          doSomethingWithResult x
-- @
--
--------------------------------------------------------------------------------

module Control.Concurrent.Thread
  ( -- * Forking threads
    forkIO
  , forkOS
  , forkOn
  , forkIOWithUnmask
  , forkOnWithUnmask

    -- * Results
  , Result
  , result
  ) where


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

-- from base:
import qualified Control.Concurrent ( forkOS
                                    , forkIOWithUnmask
                                    , forkOnWithUnmask
                                    )
import Control.Concurrent           ( ThreadId )
import Control.Concurrent.MVar      ( newEmptyMVar, putMVar, readMVar )
import Control.Exception            ( SomeException, try, throwIO, mask )
import Control.Monad                ( return, (>>=) )
import Data.Either                  ( Either(..), either )
import Data.Function                ( (.), ($) )
import Data.Int                     ( Int )
import System.IO                    ( IO )

-- from threads:
import Control.Concurrent.Raw       ( rawForkIO, rawForkOn )


--------------------------------------------------------------------------------
-- * Forking threads
--------------------------------------------------------------------------------

-- | Like @Control.Concurrent.'Control.Concurrent.forkIO'@ but returns
-- a computation that when executed blocks until the thread terminates
-- then returns the final value of the thread.
forkIO :: IO a -> IO (ThreadId, IO (Result a))
forkIO :: forall a. IO a -> IO (ThreadId, IO (Result a))
forkIO = forall a.
(IO () -> IO ThreadId) -> IO a -> IO (ThreadId, IO (Result a))
fork IO () -> IO ThreadId
rawForkIO

-- | Like @Control.Concurrent.'Control.Concurrent.forkOS'@ but returns
-- a computation that when executed blocks until the thread terminates
-- then returns the final value of the thread.
forkOS :: IO a -> IO (ThreadId, IO (Result a))
forkOS :: forall a. IO a -> IO (ThreadId, IO (Result a))
forkOS = forall a.
(IO () -> IO ThreadId) -> IO a -> IO (ThreadId, IO (Result a))
fork IO () -> IO ThreadId
Control.Concurrent.forkOS

-- | Like @Control.Concurrent.'Control.Concurrent.forkOn'@ but returns
-- a computation that when executed blocks until the thread terminates
-- then returns the final value of the thread.
forkOn :: Int -> IO a -> IO (ThreadId, IO (Result a))
forkOn :: forall a. Int -> IO a -> IO (ThreadId, IO (Result a))
forkOn = forall a.
(IO () -> IO ThreadId) -> IO a -> IO (ThreadId, IO (Result a))
fork forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IO () -> IO ThreadId
rawForkOn

-- | Like @Control.Concurrent.'Control.Concurrent.forkIOWithUnmask'@ but returns
-- a computation that when executed blocks until the thread terminates
-- then returns the final value of the thread.
forkIOWithUnmask
    :: ((forall b. IO b -> IO b) -> IO a) -> IO (ThreadId, IO (Result a))
forkIOWithUnmask :: forall a.
((forall b. IO b -> IO b) -> IO a) -> IO (ThreadId, IO (Result a))
forkIOWithUnmask = forall a.
(((forall b. IO b -> IO b) -> IO ()) -> IO ThreadId)
-> ((forall b. IO b -> IO b) -> IO a)
-> IO (ThreadId, IO (Result a))
forkWithUnmask ((forall b. IO b -> IO b) -> IO ()) -> IO ThreadId
Control.Concurrent.forkIOWithUnmask

-- | Like @Control.Concurrent.'Control.Concurrent.forkOnWithUnmask'@ but returns
-- a computation that when executed blocks until the thread terminates
-- then returns the final value of the thread.
forkOnWithUnmask
    :: Int -> ((forall b. IO b -> IO b) -> IO a) -> IO (ThreadId, IO (Result a))
forkOnWithUnmask :: forall a.
Int
-> ((forall b. IO b -> IO b) -> IO a)
-> IO (ThreadId, IO (Result a))
forkOnWithUnmask = forall a.
(((forall b. IO b -> IO b) -> IO ()) -> IO ThreadId)
-> ((forall b. IO b -> IO b) -> IO a)
-> IO (ThreadId, IO (Result a))
forkWithUnmask forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ((forall b. IO b -> IO b) -> IO ()) -> IO ThreadId
Control.Concurrent.forkOnWithUnmask


--------------------------------------------------------------------------------
-- Utils
--------------------------------------------------------------------------------

fork :: (IO () -> IO ThreadId) -> (IO a -> IO (ThreadId, IO (Result a)))
fork :: forall a.
(IO () -> IO ThreadId) -> IO a -> IO (ThreadId, IO (Result a))
fork IO () -> IO ThreadId
doFork = \IO a
a -> do
  MVar (Result a)
res <- forall a. IO (MVar a)
newEmptyMVar
  ThreadId
tid <- forall b. ((forall b. IO b -> IO b) -> IO b) -> IO b
mask forall a b. (a -> b) -> a -> b
$ \forall b. IO b -> IO b
restore -> IO () -> IO ThreadId
doFork forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
try (forall b. IO b -> IO b
restore IO a
a) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. MVar a -> a -> IO ()
putMVar MVar (Result a)
res
  forall (m :: * -> *) a. Monad m => a -> m a
return (ThreadId
tid, forall a. MVar a -> IO a
readMVar MVar (Result a)
res)

forkWithUnmask
    :: (((forall b. IO b -> IO b) -> IO ()) -> IO ThreadId)
    ->  ((forall b. IO b -> IO b) -> IO a)  -> IO (ThreadId, IO (Result a))
forkWithUnmask :: forall a.
(((forall b. IO b -> IO b) -> IO ()) -> IO ThreadId)
-> ((forall b. IO b -> IO b) -> IO a)
-> IO (ThreadId, IO (Result a))
forkWithUnmask ((forall b. IO b -> IO b) -> IO ()) -> IO ThreadId
doForkWithUnmask = \(forall b. IO b -> IO b) -> IO a
f -> do
  MVar (Result a)
res <- forall a. IO (MVar a)
newEmptyMVar
  ThreadId
tid <- forall b. ((forall b. IO b -> IO b) -> IO b) -> IO b
mask forall a b. (a -> b) -> a -> b
$ \forall b. IO b -> IO b
restore ->
           ((forall b. IO b -> IO b) -> IO ()) -> IO ThreadId
doForkWithUnmask forall a b. (a -> b) -> a -> b
$ \forall b. IO b -> IO b
unmask ->
             forall e a. Exception e => IO a -> IO (Either e a)
try (forall b. IO b -> IO b
restore forall a b. (a -> b) -> a -> b
$ (forall b. IO b -> IO b) -> IO a
f forall b. IO b -> IO b
unmask) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. MVar a -> a -> IO ()
putMVar MVar (Result a)
res
  forall (m :: * -> *) a. Monad m => a -> m a
return (ThreadId
tid, forall a. MVar a -> IO a
readMVar MVar (Result a)
res)


--------------------------------------------------------------------------------
-- Results
--------------------------------------------------------------------------------

-- | A result of a thread is either some exception that was thrown in the thread
-- and wasn't catched or the actual value that was returned by the thread.
type Result a = Either SomeException a

-- | Retrieve the actual value from the result.
--
-- When the result is 'SomeException' the exception is thrown.
result :: Result a -> IO a
result :: forall a. Result a -> IO a
result = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e a. Exception e => e -> IO a
throwIO forall (m :: * -> *) a. Monad m => a -> m a
return