{-# LANGUAGE CPP #-}

-- | Spawn provides an interface to Concurrent.forkIO which is supposed
-- to be implementable for both Hugs and GHC.
--
-- This is the GHC implementation.
module Events.Spawn(
   spawn -- :: IO () -> IO (IO ())
   ) where

import Control.Concurrent
import Control.Exception

-- | Do a fork, returning an action which may attempt to
-- kill the forked thread.  (Or may not . . .)
spawn :: IO () -> IO (IO ())
spawn :: IO () -> IO (IO ())
spawn IO ()
action =
   do
      let quietAction :: IO ()
quietAction = IO () -> IO ()
goesQuietly IO ()
action
      ThreadId
threadId <- IO () -> IO ThreadId
forkIO IO ()
quietAction
      IO () -> IO (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (ThreadId -> IO ()
killThread ThreadId
threadId)


-- --------------------------------------------------------------------------
-- goesQuietly
-- --------------------------------------------------------------------------

goesQuietly :: IO () -> IO ()
goesQuietly :: IO () -> IO ()
goesQuietly IO ()
action =
   do
      Either () ()
result <-
         (SomeException -> Maybe ()) -> IO () -> IO (Either () ())
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> IO (Either b a)
tryJust
            (\ SomeException
exception -> case SomeException -> Maybe AsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exception of
               Just AsyncException
ThreadKilled -> () -> Maybe ()
forall a. a -> Maybe a
Just ()
               Maybe AsyncException
_ -> case SomeException -> Maybe BlockedIndefinitelyOnMVar
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exception of
#if __GLASGOW_HASKELL__ >= 612
                 Just BlockedIndefinitelyOnMVar
BlockedIndefinitelyOnMVar -> () -> Maybe ()
forall a. a -> Maybe a
Just ()
#else
                 Just BlockedOnDeadMVar -> Just ()
#endif
                 Maybe BlockedIndefinitelyOnMVar
_ -> Maybe ()
forall a. Maybe a
Nothing
               )
            IO ()
action
      case Either () ()
result of
         Left () -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
         Right () -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()