{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP
           , MagicHash
           , UnboxedTuples
           , ScopedTypeVariables
           , RankNTypes
  #-}
{-# OPTIONS_GHC -Wno-deprecations #-}
-- kludge for the Control.Concurrent.QSem, Control.Concurrent.QSemN
-- and Control.Concurrent.SampleVar imports.

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Concurrent
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  experimental
-- Portability :  non-portable (concurrency)
--
-- A common interface to a collection of useful concurrency
-- abstractions.
--
-----------------------------------------------------------------------------

module Control.Concurrent (
        -- * Concurrent Haskell

        -- $conc_intro

        -- * Basic concurrency operations

        ThreadId,
        myThreadId,

        forkIO,
        forkFinally,
        forkIOWithUnmask,
        killThread,
        throwTo,

        -- ** Threads with affinity
        forkOn,
        forkOnWithUnmask,
        getNumCapabilities,
        setNumCapabilities,
        threadCapability,

        -- * Scheduling

        -- $conc_scheduling
        yield,

        -- ** Blocking

        -- $blocking

        -- ** Waiting
        threadDelay,
        threadWaitRead,
        threadWaitWrite,
        threadWaitReadSTM,
        threadWaitWriteSTM,

        -- * Communication abstractions

        module Control.Concurrent.MVar,
        module Control.Concurrent.Chan,
        module Control.Concurrent.QSem,
        module Control.Concurrent.QSemN,

        -- * Bound Threads
        -- $boundthreads
        rtsSupportsBoundThreads,
        forkOS,
        forkOSWithUnmask,
        isCurrentThreadBound,
        runInBoundThread,
        runInUnboundThread,

        -- * Weak references to ThreadIds
        mkWeakThreadId,

        -- * GHC's implementation of concurrency

        -- |This section describes features specific to GHC's
        -- implementation of Concurrent Haskell.

        -- ** Haskell threads and Operating System threads

        -- $osthreads

        -- ** Terminating the program

        -- $termination

        -- ** Pre-emption

        -- $preemption

        -- ** Deadlock

        -- $deadlock

    ) where

import Control.Exception.Base as Exception

import GHC.Conc hiding (threadWaitRead, threadWaitWrite,
                        threadWaitReadSTM, threadWaitWriteSTM)
import GHC.IO           ( unsafeUnmask, catchException )
import GHC.IORef        ( newIORef, readIORef, writeIORef )
import GHC.Base

import System.Posix.Types ( Fd )
import Foreign.StablePtr
import Foreign.C.Types

#if defined(mingw32_HOST_OS)
import Foreign.C
import System.IO
import Data.Functor ( void )
import Data.Int ( Int64 )
#else
import qualified GHC.Conc
#endif

import Control.Concurrent.MVar
import Control.Concurrent.Chan
import Control.Concurrent.QSem
import Control.Concurrent.QSemN

{- $conc_intro

The concurrency extension for Haskell is described in the paper
/Concurrent Haskell/
<http://www.haskell.org/ghc/docs/papers/concurrent-haskell.ps.gz>.

Concurrency is \"lightweight\", which means that both thread creation
and context switching overheads are extremely low.  Scheduling of
Haskell threads is done internally in the Haskell runtime system, and
doesn't make use of any operating system-supplied thread packages.

However, if you want to interact with a foreign library that expects your
program to use the operating system-supplied thread package, you can do so
by using 'forkOS' instead of 'forkIO'.

Haskell threads can communicate via 'MVar's, a kind of synchronised
mutable variable (see "Control.Concurrent.MVar").  Several common
concurrency abstractions can be built from 'MVar's, and these are
provided by the "Control.Concurrent" library.
In GHC, threads may also communicate via exceptions.
-}

{- $conc_scheduling

    Scheduling may be either pre-emptive or co-operative,
    depending on the implementation of Concurrent Haskell (see below
    for information related to specific compilers).  In a co-operative
    system, context switches only occur when you use one of the
    primitives defined in this module.  This means that programs such
    as:

>   main = forkIO (write 'a') >> write 'b'
>     where write c = putChar c >> write c

    will print either @aaaaaaaaaaaaaa...@ or @bbbbbbbbbbbb...@,
    instead of some random interleaving of @a@s and @b@s.  In
    practice, cooperative multitasking is sufficient for writing
    simple graphical user interfaces.
-}

{- $blocking
Different Haskell implementations have different characteristics with
regard to which operations block /all/ threads.

Using GHC without the @-threaded@ option, all foreign calls will block
all other Haskell threads in the system, although I\/O operations will
not.  With the @-threaded@ option, only foreign calls with the @unsafe@
attribute will block all other threads.

-}

-- | Fork a thread and call the supplied function when the thread is about
-- to terminate, with an exception or a returned value.  The function is
-- called with asynchronous exceptions masked.
--
-- > forkFinally action and_then =
-- >   mask $ \restore ->
-- >     forkIO $ try (restore action) >>= and_then
--
-- This function is useful for informing the parent when a child
-- terminates, for example.
--
-- @since 4.6.0.0
forkFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkFinally action and_then =
  mask $ \restore ->
    forkIO $ try (restore action) >>= and_then

-- ---------------------------------------------------------------------------
-- Bound Threads

{- $boundthreads
   #boundthreads#

Support for multiple operating system threads and bound threads as described
below is currently only available in the GHC runtime system if you use the
/-threaded/ option when linking.

Other Haskell systems do not currently support multiple operating system threads.

A bound thread is a haskell thread that is /bound/ to an operating system
thread. While the bound thread is still scheduled by the Haskell run-time
system, the operating system thread takes care of all the foreign calls made
by the bound thread.

To a foreign library, the bound thread will look exactly like an ordinary
operating system thread created using OS functions like @pthread_create@
or @CreateThread@.

Bound threads can be created using the 'forkOS' function below. All foreign
exported functions are run in a bound thread (bound to the OS thread that
called the function). Also, the @main@ action of every Haskell program is
run in a bound thread.

Why do we need this? Because if a foreign library is called from a thread
created using 'forkIO', it won't have access to any /thread-local state/ -
state variables that have specific values for each OS thread
(see POSIX's @pthread_key_create@ or Win32's @TlsAlloc@). Therefore, some
libraries (OpenGL, for example) will not work from a thread created using
'forkIO'. They work fine in threads created using 'forkOS' or when called
from @main@ or from a @foreign export@.

In terms of performance, 'forkOS' (aka bound) threads are much more
expensive than 'forkIO' (aka unbound) threads, because a 'forkOS'
thread is tied to a particular OS thread, whereas a 'forkIO' thread
can be run by any OS thread.  Context-switching between a 'forkOS'
thread and a 'forkIO' thread is many times more expensive than between
two 'forkIO' threads.

Note in particular that the main program thread (the thread running
@Main.main@) is always a bound thread, so for good concurrency
performance you should ensure that the main thread is not doing
repeated communication with other threads in the system.  Typically
this means forking subthreads to do the work using 'forkIO', and
waiting for the results in the main thread.

-}

-- | 'True' if bound threads are supported.
-- If @rtsSupportsBoundThreads@ is 'False', 'isCurrentThreadBound'
-- will always return 'False' and both 'forkOS' and 'runInBoundThread' will
-- fail.
foreign import ccall unsafe rtsSupportsBoundThreads :: Bool

{- |
Like 'forkIO', this sparks off a new thread to run the 'IO'
computation passed as the first argument, and returns the 'ThreadId'
of the newly created thread.

However, 'forkOS' creates a /bound/ thread, which is necessary if you
need to call foreign (non-Haskell) libraries that make use of
thread-local state, such as OpenGL (see "Control.Concurrent#boundthreads").

Using 'forkOS' instead of 'forkIO' makes no difference at all to the
scheduling behaviour of the Haskell runtime system.  It is a common
misconception that you need to use 'forkOS' instead of 'forkIO' to
avoid blocking all the Haskell threads when making a foreign call;
this isn't the case.  To allow foreign calls to be made without
blocking all the Haskell threads (with GHC), it is only necessary to
use the @-threaded@ option when linking your program, and to make sure
the foreign import is not marked @unsafe@.
-}

forkOS :: IO () -> IO ThreadId

foreign export ccall forkOS_entry
    :: StablePtr (IO ()) -> IO ()

foreign import ccall "forkOS_entry" forkOS_entry_reimported
    :: StablePtr (IO ()) -> IO ()

forkOS_entry :: StablePtr (IO ()) -> IO ()
forkOS_entry stableAction = do
        action <- deRefStablePtr stableAction
        action

foreign import ccall forkOS_createThread
    :: StablePtr (IO ()) -> IO CInt

failNonThreaded :: IO a
failNonThreaded = fail $ "RTS doesn't support multiple OS threads "
                       ++"(use ghc -threaded when linking)"

forkOS action0
    | rtsSupportsBoundThreads = do
        mv <- newEmptyMVar
        b <- Exception.getMaskingState
        let
            -- async exceptions are masked in the child if they are masked
            -- in the parent, as for forkIO (see #1048). forkOS_createThread
            -- creates a thread with exceptions masked by default.
            action1 = case b of
                        Unmasked -> unsafeUnmask action0
                        MaskedInterruptible -> action0
                        MaskedUninterruptible -> uninterruptibleMask_ action0

            action_plus = catch action1 childHandler

        entry <- newStablePtr (myThreadId >>= putMVar mv >> action_plus)
        err <- forkOS_createThread entry
        when (err /= 0) $ fail "Cannot create OS thread."
        tid <- takeMVar mv
        freeStablePtr entry
        return tid
    | otherwise = failNonThreaded

-- | Like 'forkIOWithUnmask', but the child thread is a bound thread,
-- as with 'forkOS'.
forkOSWithUnmask :: ((forall a . IO a -> IO a) -> IO ()) -> IO ThreadId
forkOSWithUnmask io = forkOS (io unsafeUnmask)

-- | Returns 'True' if the calling thread is /bound/, that is, if it is
-- safe to use foreign libraries that rely on thread-local state from the
-- calling thread.
isCurrentThreadBound :: IO Bool
isCurrentThreadBound = IO $ \ s# ->
    case isCurrentThreadBound# s# of
        (# s2#, flg #) -> (# s2#, isTrue# (flg /=# 0#) #)

{- |
Run the 'IO' computation passed as the first argument. If the calling thread
is not /bound/, a bound thread is created temporarily. @runInBoundThread@
doesn't finish until the 'IO' computation finishes.

You can wrap a series of foreign function calls that rely on thread-local state
with @runInBoundThread@ so that you can use them without knowing whether the
current thread is /bound/.
-}
runInBoundThread :: IO a -> IO a

runInBoundThread action
    | rtsSupportsBoundThreads = do
        bound <- isCurrentThreadBound
        if bound
            then action
            else do
                ref <- newIORef undefined
                let action_plus = Exception.try action >>= writeIORef ref
                bracket (newStablePtr action_plus)
                        freeStablePtr
                        (\cEntry -> forkOS_entry_reimported cEntry >> readIORef ref) >>=
                  unsafeResult
    | otherwise = failNonThreaded

{- |
Run the 'IO' computation passed as the first argument. If the calling thread
is /bound/, an unbound thread is created temporarily using 'forkIO'.
@runInBoundThread@ doesn't finish until the 'IO' computation finishes.

Use this function /only/ in the rare case that you have actually observed a
performance loss due to the use of bound threads. A program that
doesn't need its main thread to be bound and makes /heavy/ use of concurrency
(e.g. a web server), might want to wrap its @main@ action in
@runInUnboundThread@.

Note that exceptions which are thrown to the current thread are thrown in turn
to the thread that is executing the given computation. This ensures there's
always a way of killing the forked thread.
-}
runInUnboundThread :: IO a -> IO a

runInUnboundThread action = do
  bound <- isCurrentThreadBound
  if bound
    then do
      mv <- newEmptyMVar
      mask $ \restore -> do
        tid <- forkIO $ Exception.try (restore action) >>= putMVar mv
        let wait = takeMVar mv `catchException` \(e :: SomeException) ->
                     Exception.throwTo tid e >> wait
        wait >>= unsafeResult
    else action

unsafeResult :: Either SomeException a -> IO a
unsafeResult = either Exception.throwIO return

-- ---------------------------------------------------------------------------
-- threadWaitRead/threadWaitWrite

-- | Block the current thread until data is available to read on the
-- given file descriptor (GHC only).
--
-- This will throw an 'IOError' if the file descriptor was closed
-- while this thread was blocked.  To safely close a file descriptor
-- that has been used with 'threadWaitRead', use
-- 'GHC.Conc.closeFdWith'.
threadWaitRead :: Fd -> IO ()
threadWaitRead fd
#if defined(mingw32_HOST_OS)
  -- we have no IO manager implementing threadWaitRead on Windows.
  -- fdReady does the right thing, but we have to call it in a
  -- separate thread, otherwise threadWaitRead won't be interruptible,
  -- and this only works with -threaded.
  | threaded  = withThread (waitFd fd False)
  | otherwise = case fd of
                  0 -> do _ <- hWaitForInput stdin (-1)
                          return ()
                        -- hWaitForInput does work properly, but we can only
                        -- do this for stdin since we know its FD.
                  _ -> errorWithoutStackTrace "threadWaitRead requires -threaded on Windows, or use System.IO.hWaitForInput"
#else
  = GHC.Conc.threadWaitRead fd
#endif

-- | Block the current thread until data can be written to the
-- given file descriptor (GHC only).
--
-- This will throw an 'IOError' if the file descriptor was closed
-- while this thread was blocked.  To safely close a file descriptor
-- that has been used with 'threadWaitWrite', use
-- 'GHC.Conc.closeFdWith'.
threadWaitWrite :: Fd -> IO ()
threadWaitWrite fd
#if defined(mingw32_HOST_OS)
  | threaded  = withThread (waitFd fd True)
  | otherwise = errorWithoutStackTrace "threadWaitWrite requires -threaded on Windows"
#else
  = GHC.Conc.threadWaitWrite fd
#endif

-- | Returns an STM action that can be used to wait for data
-- to read from a file descriptor. The second returned value
-- is an IO action that can be used to deregister interest
-- in the file descriptor.
--
-- @since 4.7.0.0
threadWaitReadSTM :: Fd -> IO (STM (), IO ())
threadWaitReadSTM fd
#if defined(mingw32_HOST_OS)
  | threaded = do v <- newTVarIO Nothing
                  mask_ $ void $ forkIO $ do result <- try (waitFd fd False)
                                             atomically (writeTVar v $ Just result)
                  let waitAction = do result <- readTVar v
                                      case result of
                                        Nothing         -> retry
                                        Just (Right ()) -> return ()
                                        Just (Left e)   -> throwSTM (e :: IOException)
                  let killAction = return ()
                  return (waitAction, killAction)
  | otherwise = errorWithoutStackTrace "threadWaitReadSTM requires -threaded on Windows"
#else
  = GHC.Conc.threadWaitReadSTM fd
#endif

-- | Returns an STM action that can be used to wait until data
-- can be written to a file descriptor. The second returned value
-- is an IO action that can be used to deregister interest
-- in the file descriptor.
--
-- @since 4.7.0.0
threadWaitWriteSTM :: Fd -> IO (STM (), IO ())
threadWaitWriteSTM fd
#if defined(mingw32_HOST_OS)
  | threaded = do v <- newTVarIO Nothing
                  mask_ $ void $ forkIO $ do result <- try (waitFd fd True)
                                             atomically (writeTVar v $ Just result)
                  let waitAction = do result <- readTVar v
                                      case result of
                                        Nothing         -> retry
                                        Just (Right ()) -> return ()
                                        Just (Left e)   -> throwSTM (e :: IOException)
                  let killAction = return ()
                  return (waitAction, killAction)
  | otherwise = errorWithoutStackTrace "threadWaitWriteSTM requires -threaded on Windows"
#else
  = GHC.Conc.threadWaitWriteSTM fd
#endif

#if defined(mingw32_HOST_OS)
foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool

withThread :: IO a -> IO a
withThread io = do
  m <- newEmptyMVar
  _ <- mask_ $ forkIO $ try io >>= putMVar m
  x <- takeMVar m
  case x of
    Right a -> return a
    Left e  -> throwIO (e :: IOException)

waitFd :: Fd -> Bool -> IO ()
waitFd fd write = do
   throwErrnoIfMinus1_ "fdReady" $
        fdReady (fromIntegral fd) (if write then 1 else 0) (-1) 0

foreign import ccall safe "fdReady"
  fdReady :: CInt -> CBool -> Int64 -> CBool -> IO CInt
#endif

-- ---------------------------------------------------------------------------
-- More docs

{- $osthreads

      #osthreads# In GHC, threads created by 'forkIO' are lightweight threads, and
      are managed entirely by the GHC runtime.  Typically Haskell
      threads are an order of magnitude or two more efficient (in
      terms of both time and space) than operating system threads.

      The downside of having lightweight threads is that only one can
      run at a time, so if one thread blocks in a foreign call, for
      example, the other threads cannot continue.  The GHC runtime
      works around this by making use of full OS threads where
      necessary.  When the program is built with the @-threaded@
      option (to link against the multithreaded version of the
      runtime), a thread making a @safe@ foreign call will not block
      the other threads in the system; another OS thread will take
      over running Haskell threads until the original call returns.
      The runtime maintains a pool of these /worker/ threads so that
      multiple Haskell threads can be involved in external calls
      simultaneously.

      The "System.IO" library manages multiplexing in its own way.  On
      Windows systems it uses @safe@ foreign calls to ensure that
      threads doing I\/O operations don't block the whole runtime,
      whereas on Unix systems all the currently blocked I\/O requests
      are managed by a single thread (the /IO manager thread/) using
      a mechanism such as @epoll@ or @kqueue@, depending on what is
      provided by the host operating system.

      The runtime will run a Haskell thread using any of the available
      worker OS threads.  If you need control over which particular OS
      thread is used to run a given Haskell thread, perhaps because
      you need to call a foreign library that uses OS-thread-local
      state, then you need bound threads (see "Control.Concurrent#boundthreads").

      If you don't use the @-threaded@ option, then the runtime does
      not make use of multiple OS threads.  Foreign calls will block
      all other running Haskell threads until the call returns.  The
      "System.IO" library still does multiplexing, so there can be multiple
      threads doing I\/O, and this is handled internally by the runtime using
      @select@.
-}

{- $termination

      In a standalone GHC program, only the main thread is
      required to terminate in order for the process to terminate.
      Thus all other forked threads will simply terminate at the same
      time as the main thread (the terminology for this kind of
      behaviour is \"daemonic threads\").

      If you want the program to wait for child threads to
      finish before exiting, you need to program this yourself.  A
      simple mechanism is to have each child thread write to an
      'MVar' when it completes, and have the main
      thread wait on all the 'MVar's before
      exiting:

>   myForkIO :: IO () -> IO (MVar ())
>   myForkIO io = do
>     mvar <- newEmptyMVar
>     forkFinally io (\_ -> putMVar mvar ())
>     return mvar

      Note that we use 'forkFinally' to make sure that the
      'MVar' is written to even if the thread dies or
      is killed for some reason.

      A better method is to keep a global list of all child
      threads which we should wait for at the end of the program:

>    children :: MVar [MVar ()]
>    children = unsafePerformIO (newMVar [])
>
>    waitForChildren :: IO ()
>    waitForChildren = do
>      cs <- takeMVar children
>      case cs of
>        []   -> return ()
>        m:ms -> do
>           putMVar children ms
>           takeMVar m
>           waitForChildren
>
>    forkChild :: IO () -> IO ThreadId
>    forkChild io = do
>        mvar <- newEmptyMVar
>        childs <- takeMVar children
>        putMVar children (mvar:childs)
>        forkFinally io (\_ -> putMVar mvar ())
>
>     main =
>       later waitForChildren $
>       ...

      The main thread principle also applies to calls to Haskell from
      outside, using @foreign export@.  When the @foreign export@ed
      function is invoked, it starts a new main thread, and it returns
      when this main thread terminates.  If the call causes new
      threads to be forked, they may remain in the system after the
      @foreign export@ed function has returned.
-}

{- $preemption

      GHC implements pre-emptive multitasking: the execution of
      threads are interleaved in a random fashion.  More specifically,
      a thread may be pre-empted whenever it allocates some memory,
      which unfortunately means that tight loops which do no
      allocation tend to lock out other threads (this only seems to
      happen with pathological benchmark-style code, however).

      The rescheduling timer runs on a 20ms granularity by
      default, but this may be altered using the
      @-i\<n\>@ RTS option.  After a rescheduling
      \"tick\" the running thread is pre-empted as soon as
      possible.

      One final note: the
      @aaaa@ @bbbb@ example may not
      work too well on GHC (see Scheduling, above), due
      to the locking on a 'System.IO.Handle'.  Only one thread
      may hold the lock on a 'System.IO.Handle' at any one
      time, so if a reschedule happens while a thread is holding the
      lock, the other thread won't be able to run.  The upshot is that
      the switch from @aaaa@ to
      @bbbbb@ happens infrequently.  It can be
      improved by lowering the reschedule tick period.  We also have a
      patch that causes a reschedule whenever a thread waiting on a
      lock is woken up, but haven't found it to be useful for anything
      other than this example :-)
-}

{- $deadlock

GHC attempts to detect when threads are deadlocked using the garbage
collector.  A thread that is not reachable (cannot be found by
following pointers from live objects) must be deadlocked, and in this
case the thread is sent an exception.  The exception is either
'BlockedIndefinitelyOnMVar', 'BlockedIndefinitelyOnSTM',
'NonTermination', or 'Deadlock', depending on the way in which the
thread is deadlocked.

Note that this feature is intended for debugging, and should not be
relied on for the correct operation of your program.  There is no
guarantee that the garbage collector will be accurate enough to detect
your deadlock, and no guarantee that the garbage collector will run in
a timely enough manner.  Basically, the same caveats as for finalizers
apply to deadlock detection.

There is a subtle interaction between deadlock detection and
finalizers (as created by 'Foreign.Concurrent.newForeignPtr' or the
functions in "System.Mem.Weak"): if a thread is blocked waiting for a
finalizer to run, then the thread will be considered deadlocked and
sent an exception.  So preferably don't do this, but if you have no
alternative then it is possible to prevent the thread from being
considered deadlocked by making a 'StablePtr' pointing to it.  Don't
forget to release the 'StablePtr' later with 'freeStablePtr'.
-}


{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude, ExistentialQuantification #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Exception
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  experimental
-- Portability :  non-portable (extended exceptions)
--
-- This module provides support for raising and catching both built-in
-- and user-defined exceptions.
--
-- In addition to exceptions thrown by 'IO' operations, exceptions may
-- be thrown by pure code (imprecise exceptions) or by external events
-- (asynchronous exceptions), but may only be caught in the 'IO' monad.
-- For more details, see:
--
--  * /A semantics for imprecise exceptions/, by Simon Peyton Jones,
--    Alastair Reid, Tony Hoare, Simon Marlow, Fergus Henderson,
--    in /PLDI'99/.
--
--  * /Asynchronous exceptions in Haskell/, by Simon Marlow, Simon Peyton
--    Jones, Andy Moran and John Reppy, in /PLDI'01/.
--
--  * /An Extensible Dynamically-Typed Hierarchy of Exceptions/,
--    by Simon Marlow, in /Haskell '06/.
--
-----------------------------------------------------------------------------

module Control.Exception (

        -- * The Exception type
        SomeException(..),
        Exception(..),          -- class
        IOException,            -- instance Eq, Ord, Show, Typeable, Exception
        ArithException(..),     -- instance Eq, Ord, Show, Typeable, Exception
        ArrayException(..),     -- instance Eq, Ord, Show, Typeable, Exception
        AssertionFailed(..),
        SomeAsyncException(..),
        AsyncException(..),     -- instance Eq, Ord, Show, Typeable, Exception
        asyncExceptionToException, asyncExceptionFromException,

        NonTermination(..),
        NestedAtomically(..),
        BlockedIndefinitelyOnMVar(..),
        BlockedIndefinitelyOnSTM(..),
        AllocationLimitExceeded(..),
        CompactionFailed(..),
        Deadlock(..),
        NoMethodError(..),
        PatternMatchFail(..),
        RecConError(..),
        RecSelError(..),
        RecUpdError(..),
        ErrorCall(..),
        TypeError(..),

        -- * Throwing exceptions
        throw,
        throwIO,
        ioError,
        throwTo,

        -- * Catching Exceptions

        -- $catching

        -- ** Catching all exceptions

        -- $catchall

        -- ** The @catch@ functions
        catch,
        catches, Handler(..),
        catchJust,

        -- ** The @handle@ functions
        handle,
        handleJust,

        -- ** The @try@ functions
        try,
        tryJust,

        -- ** The @evaluate@ function
        evaluate,

        -- ** The @mapException@ function
        mapException,

        -- * Asynchronous Exceptions

        -- $async

        -- ** Asynchronous exception control

        -- |The following functions allow a thread to control delivery of
        -- asynchronous exceptions during a critical region.

        mask,
        mask_,
        uninterruptibleMask,
        uninterruptibleMask_,
        MaskingState(..),
        getMaskingState,
        interruptible,
        allowInterrupt,

        -- *** Applying @mask@ to an exception handler

        -- $block_handler

        -- *** Interruptible operations

        -- $interruptible

        -- * Assertions

        assert,

        -- * Utilities

        bracket,
        bracket_,
        bracketOnError,

        finally,
        onException,

  ) where

import Control.Exception.Base

import GHC.Base
import GHC.IO (interruptible)

-- | You need this when using 'catches'.
data Handler a = forall e . Exception e => Handler (e -> IO a)

-- | @since 4.6.0.0
instance Functor Handler where
     fmap f (Handler h) = Handler (fmap f . h)

{- |
Sometimes you want to catch two different sorts of exception. You could
do something like

> f = expr `catch` \ (ex :: ArithException) -> handleArith ex
>          `catch` \ (ex :: IOException)    -> handleIO    ex

However, there are a couple of problems with this approach. The first is
that having two exception handlers is inefficient. However, the more
serious issue is that the second exception handler will catch exceptions
in the first, e.g. in the example above, if @handleArith@ throws an
@IOException@ then the second exception handler will catch it.

Instead, we provide a function 'catches', which would be used thus:

> f = expr `catches` [Handler (\ (ex :: ArithException) -> handleArith ex),
>                     Handler (\ (ex :: IOException)    -> handleIO    ex)]
-}
catches :: IO a -> [Handler a] -> IO a
catches io handlers = io `catch` catchesHandler handlers

catchesHandler :: [Handler a] -> SomeException -> IO a
catchesHandler handlers e = foldr tryHandler (throw e) handlers
    where tryHandler (Handler handler) res
              = case fromException e of
                Just e' -> handler e'
                Nothing -> res

-- -----------------------------------------------------------------------------
-- Catching exceptions

{- $catching

There are several functions for catching and examining
exceptions; all of them may only be used from within the
'IO' monad.

Here's a rule of thumb for deciding which catch-style function to
use:

 * If you want to do some cleanup in the event that an exception
   is raised, use 'finally', 'bracket' or 'onException'.

 * To recover after an exception and do something else, the best
   choice is to use one of the 'try' family.

 * ... unless you are recovering from an asynchronous exception, in which
   case use 'catch' or 'catchJust'.

The difference between using 'try' and 'catch' for recovery is that in
'catch' the handler is inside an implicit 'mask' (see \"Asynchronous
Exceptions\") which is important when catching asynchronous
exceptions, but when catching other kinds of exception it is
unnecessary.  Furthermore it is possible to accidentally stay inside
the implicit 'mask' by tail-calling rather than returning from the
handler, which is why we recommend using 'try' rather than 'catch' for
ordinary exception recovery.

A typical use of 'tryJust' for recovery looks like this:

>  do r <- tryJust (guard . isDoesNotExistError) $ getEnv "HOME"
>     case r of
>       Left  e    -> ...
>       Right home -> ...

-}

-- -----------------------------------------------------------------------------
-- Asynchronous exceptions

-- | When invoked inside 'mask', this function allows a masked
-- asynchronous exception to be raised, if one exists.  It is
-- equivalent to performing an interruptible operation (see
-- #interruptible), but does not involve any actual blocking.
--
-- When called outside 'mask', or inside 'uninterruptibleMask', this
-- function has no effect.
--
-- @since 4.4.0.0
allowInterrupt :: IO ()
allowInterrupt = interruptible $ return ()

{- $async

 #AsynchronousExceptions# Asynchronous exceptions are so-called because they arise due to
external influences, and can be raised at any point during execution.
'StackOverflow' and 'HeapOverflow' are two examples of
system-generated asynchronous exceptions.

The primary source of asynchronous exceptions, however, is
'throwTo':

>  throwTo :: ThreadId -> Exception -> IO ()

'throwTo' (also 'Control.Concurrent.killThread') allows one
running thread to raise an arbitrary exception in another thread.  The
exception is therefore asynchronous with respect to the target thread,
which could be doing anything at the time it receives the exception.
Great care should be taken with asynchronous exceptions; it is all too
easy to introduce race conditions by the over zealous use of
'throwTo'.
-}

{- $block_handler
There\'s an implied 'mask' around every exception handler in a call
to one of the 'catch' family of functions.  This is because that is
what you want most of the time - it eliminates a common race condition
in starting an exception handler, because there may be no exception
handler on the stack to handle another exception if one arrives
immediately.  If asynchronous exceptions are masked on entering the
handler, though, we have time to install a new exception handler
before being interrupted.  If this weren\'t the default, one would have
to write something like

>      mask $ \restore ->
>           catch (restore (...))
>                 (\e -> handler)

If you need to unmask asynchronous exceptions again in the exception
handler, @restore@ can be used there too.

Note that 'try' and friends /do not/ have a similar default, because
there is no exception handler in this case.  Don't use 'try' for
recovering from an asynchronous exception.
-}

{- $interruptible

 #interruptible#
Some operations are /interruptible/, which means that they can receive
asynchronous exceptions even in the scope of a 'mask'.  Any function
which may itself block is defined as interruptible; this includes
'Control.Concurrent.MVar.takeMVar'
(but not 'Control.Concurrent.MVar.tryTakeMVar'),
and most operations which perform
some I\/O with the outside world.  The reason for having
interruptible operations is so that we can write things like

>      mask $ \restore -> do
>         a <- takeMVar m
>         catch (restore (...))
>               (\e -> ...)

if the 'Control.Concurrent.MVar.takeMVar' was not interruptible,
then this particular
combination could lead to deadlock, because the thread itself would be
blocked in a state where it can\'t receive any asynchronous exceptions.
With 'Control.Concurrent.MVar.takeMVar' interruptible, however, we can be
safe in the knowledge that the thread can receive exceptions right up
until the point when the 'Control.Concurrent.MVar.takeMVar' succeeds.
Similar arguments apply for other interruptible operations like
'System.IO.openFile'.

It is useful to think of 'mask' not as a way to completely prevent
asynchronous exceptions, but as a way to switch from asynchronous mode
to polling mode.  The main difficulty with asynchronous
exceptions is that they normally can occur anywhere, but within a
'mask' an asynchronous exception is only raised by operations that are
interruptible (or call other interruptible operations).  In many cases
these operations may themselves raise exceptions, such as I\/O errors,
so the caller will usually be prepared to handle exceptions arising from the
operation anyway.  To perform an explicit poll for asynchronous exceptions
inside 'mask', use 'allowInterrupt'.

Sometimes it is too onerous to handle exceptions in the middle of a
critical piece of stateful code.  There are three ways to handle this
kind of situation:

 * Use STM.  Since a transaction is always either completely executed
   or not at all, transactions are a good way to maintain invariants
   over state in the presence of asynchronous (and indeed synchronous)
   exceptions.

 * Use 'mask', and avoid interruptible operations.  In order to do
   this, we have to know which operations are interruptible.  It is
   impossible to know for any given library function whether it might
   invoke an interruptible operation internally; so instead we give a
   list of guaranteed-not-to-be-interruptible operations below.

 * Use 'uninterruptibleMask'.  This is generally not recommended,
   unless you can guarantee that any interruptible operations invoked
   during the scope of 'uninterruptibleMask' can only ever block for
   a short time.  Otherwise, 'uninterruptibleMask' is a good way to
   make your program deadlock and be unresponsive to user interrupts.

The following operations are guaranteed not to be interruptible:

 * operations on 'Data.IORef.IORef' from "Data.IORef"

 * STM transactions that do not use 'GHC.Conc.retry'

 * everything from the @Foreign@ modules

 * everything from "Control.Exception" except for 'throwTo'

 * 'Control.Concurrent.MVar.tryTakeMVar', 'Control.Concurrent.MVar.tryPutMVar',
   'Control.Concurrent.MVar.isEmptyMVar'

 * 'Control.Concurrent.MVar.takeMVar' if the 'Control.Concurrent.MVar.MVar' is
   definitely full, and conversely 'Control.Concurrent.MVar.putMVar' if the
   'Control.Concurrent.MVar.MVar' is definitely empty

 * 'Control.Concurrent.MVar.newEmptyMVar', 'Control.Concurrent.MVar.newMVar'

 * 'Control.Concurrent.forkIO', 'Control.Concurrent.myThreadId'

-}

{- $catchall

It is possible to catch all exceptions, by using the type 'SomeException':

> catch f (\e -> ... (e :: SomeException) ...)

HOWEVER, this is normally not what you want to do!

For example, suppose you want to read a file, but if it doesn't exist
then continue as if it contained \"\".  You might be tempted to just
catch all exceptions and return \"\" in the handler. However, this has
all sorts of undesirable consequences.  For example, if the user
presses control-C at just the right moment then the 'UserInterrupt'
exception will be caught, and the program will continue running under
the belief that the file contains \"\".  Similarly, if another thread
tries to kill the thread reading the file then the 'ThreadKilled'
exception will be ignored.

Instead, you should only catch exactly the exceptions that you really
want. In this case, this would likely be more specific than even
\"any IO exception\"; a permissions error would likely also want to be
handled differently. Instead, you would probably want something like:

> e <- tryJust (guard . isDoesNotExistError) (readFile f)
> let str = either (const "") id e

There are occasions when you really do need to catch any sort of
exception. However, in most cases this is just so you can do some
cleaning up; you aren't actually interested in the exception itself.
For example, if you open a file then you want to close it again,
whether processing the file executes normally or throws an exception.
However, in these cases you can use functions like 'bracket', 'finally'
and 'onException', which never actually pass you the exception, but
just call the cleanup functions at the appropriate points.

But sometimes you really do need to catch any exception, and actually
see what the exception is. One example is at the very top-level of a
program, you may wish to catch any exception, print it to a logfile or
the screen, and then exit gracefully. For these cases, you can use
'catch' (or one of the other exception-catching functions) with the
'SomeException' type.
-}


{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Monad
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  provisional
-- Portability :  portable
--
-- The 'Functor', 'Monad' and 'MonadPlus' classes,
-- with some useful operations on monads.

module Control.Monad
    (
    -- * Functor and monad classes

      Functor(fmap)
    , Monad((>>=), (>>), return, fail)
    , MonadPlus(mzero, mplus)
    -- * Functions

    -- ** Naming conventions
    -- $naming

    -- ** Basic @Monad@ functions

    , mapM
    , mapM_
    , forM
    , forM_
    , sequence
    , sequence_
    , (=<<)
    , (>=>)
    , (<=<)
    , forever
    , void

    -- ** Generalisations of list functions

    , join
    , msum
    , mfilter
    , filterM
    , mapAndUnzipM
    , zipWithM
    , zipWithM_
    , foldM
    , foldM_
    , replicateM
    , replicateM_

    -- ** Conditional execution of monadic expressions

    , guard
    , when
    , unless

    -- ** Monadic lifting operators

    , liftM
    , liftM2
    , liftM3
    , liftM4
    , liftM5

    , ap

    -- ** Strict monadic functions

    , (<$!>)
    ) where

import Data.Foldable ( Foldable, sequence_, sequenceA_, msum, mapM_, foldlM, forM_ )
import Data.Functor ( void, (<$>) )
import Data.Traversable ( forM, mapM, traverse, sequence, sequenceA )

import GHC.Base hiding ( mapM, sequence )
import GHC.List ( zipWith, unzip )
import GHC.Num  ( (-) )

-- -----------------------------------------------------------------------------
-- Functions mandated by the Prelude

-- | Conditional failure of 'Alternative' computations. Defined by
--
-- @
-- guard True  = 'pure' ()
-- guard False = 'empty'
-- @
--
-- ==== __Examples__
--
-- Common uses of 'guard' include conditionally signaling an error in
-- an error monad and conditionally rejecting the current choice in an
-- 'Alternative'-based parser.
--
-- As an example of signaling an error in the error monad 'Maybe',
-- consider a safe division function @safeDiv x y@ that returns
-- 'Nothing' when the denominator @y@ is zero and @'Just' (x \`div\`
-- y)@ otherwise. For example:
--
-- @
-- >>> safeDiv 4 0
-- Nothing
-- >>> safeDiv 4 2
-- Just 2
-- @
--
-- A definition of @safeDiv@ using guards, but not 'guard':
--
-- @
-- safeDiv :: Int -> Int -> Maybe Int
-- safeDiv x y | y /= 0    = Just (x \`div\` y)
--             | otherwise = Nothing
-- @
--
-- A definition of @safeDiv@ using 'guard' and 'Monad' @do@-notation:
--
-- @
-- safeDiv :: Int -> Int -> Maybe Int
-- safeDiv x y = do
--   guard (y /= 0)
--   return (x \`div\` y)
-- @
guard           :: (Alternative f) => Bool -> f ()
guard True      =  pure ()
guard False     =  empty

-- | This generalizes the list-based 'Data.List.filter' function.

{-# INLINE filterM #-}
filterM          :: (Applicative m) => (a -> m Bool) -> [a] -> m [a]
filterM p        = foldr (\ x -> liftA2 (\ flg -> if flg then (x:) else id) (p x)) (pure [])

infixr 1 <=<, >=>

-- | Left-to-right composition of Kleisli arrows.
(>=>)       :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c)
f >=> g     = \x -> f x >>= g

-- | Right-to-left composition of Kleisli arrows. @('>=>')@, with the arguments
-- flipped.
--
-- Note how this operator resembles function composition @('.')@:
--
-- > (.)   ::            (b ->   c) -> (a ->   b) -> a ->   c
-- > (<=<) :: Monad m => (b -> m c) -> (a -> m b) -> a -> m c
(<=<)       :: Monad m => (b -> m c) -> (a -> m b) -> (a -> m c)
(<=<)       = flip (>=>)

-- | Repeat an action indefinitely.
--
-- ==== __Examples__
--
-- A common use of 'forever' is to process input from network sockets,
-- 'System.IO.Handle's, and channels
-- (e.g. 'Control.Concurrent.MVar.MVar' and
-- 'Control.Concurrent.Chan.Chan').
--
-- For example, here is how we might implement an [echo
-- server](https://en.wikipedia.org/wiki/Echo_Protocol), using
-- 'forever' both to listen for client connections on a network socket
-- and to echo client input on client connection handles:
--
-- @
-- echoServer :: Socket -> IO ()
-- echoServer socket = 'forever' $ do
--   client <- accept socket
--   'Control.Concurrent.forkFinally' (echo client) (\\_ -> hClose client)
--   where
--     echo :: Handle -> IO ()
--     echo client = 'forever' $
--       hGetLine client >>= hPutStrLn client
-- @
forever     :: (Applicative f) => f a -> f b
{-# INLINE forever #-}
forever a   = let a' = a *> a' in a'
-- Use explicit sharing here, as it prevents a space leak regardless of
-- optimizations.

-- -----------------------------------------------------------------------------
-- Other monad functions

-- | The 'mapAndUnzipM' function maps its first argument over a list, returning
-- the result as a pair of lists. This function is mainly used with complicated
-- data structures or a state monad.
mapAndUnzipM      :: (Applicative m) => (a -> m (b,c)) -> [a] -> m ([b], [c])
{-# INLINE mapAndUnzipM #-}
-- Inline so that fusion with 'unzip' and 'traverse' has a chance to fire.
-- See Note [Inline @unzipN@ functions] in GHC/OldList.hs.
mapAndUnzipM f xs =  unzip <$> traverse f xs

-- | The 'zipWithM' function generalizes 'zipWith' to arbitrary applicative functors.
zipWithM          :: (Applicative m) => (a -> b -> m c) -> [a] -> [b] -> m [c]
{-# INLINE zipWithM #-}
-- Inline so that fusion with zipWith and sequenceA have a chance to fire
-- See Note [Fusion for zipN/zipWithN] in List.hs]
zipWithM f xs ys  =  sequenceA (zipWith f xs ys)

-- | 'zipWithM_' is the extension of 'zipWithM' which ignores the final result.
zipWithM_         :: (Applicative m) => (a -> b -> m c) -> [a] -> [b] -> m ()
{-# INLINE zipWithM_ #-}
-- Inline so that fusion with zipWith and sequenceA have a chance to fire
-- See Note [Fusion for zipN/zipWithN] in List.hs]
zipWithM_ f xs ys =  sequenceA_ (zipWith f xs ys)

{- | The 'foldM' function is analogous to 'Data.Foldable.foldl', except that its result is
encapsulated in a monad. Note that 'foldM' works from left-to-right over
the list arguments. This could be an issue where @('>>')@ and the `folded
function' are not commutative.

> foldM f a1 [x1, x2, ..., xm]
>
> ==
>
> do
>   a2 <- f a1 x1
>   a3 <- f a2 x2
>   ...
>   f am xm

If right-to-left evaluation is required, the input list should be reversed.

Note: 'foldM' is the same as 'foldlM'
-}

foldM          :: (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m b
{-# INLINABLE foldM #-}
{-# SPECIALISE foldM :: (a -> b -> IO a) -> a -> [b] -> IO a #-}
{-# SPECIALISE foldM :: (a -> b -> Maybe a) -> a -> [b] -> Maybe a #-}
foldM          = foldlM

-- | Like 'foldM', but discards the result.
foldM_         :: (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m ()
{-# INLINABLE foldM_ #-}
{-# SPECIALISE foldM_ :: (a -> b -> IO a) -> a -> [b] -> IO () #-}
{-# SPECIALISE foldM_ :: (a -> b -> Maybe a) -> a -> [b] -> Maybe () #-}
foldM_ f a xs  = foldlM f a xs >> return ()

{-
Note [Worker/wrapper transform on replicateM/replicateM_]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

The implementations of replicateM and replicateM_ both leverage the
worker/wrapper transform. The simpler implementation of replicateM_, as an
example, would be:

    replicateM_ 0 _ = pure ()
    replicateM_ n f = f *> replicateM_ (n - 1) f

However, the self-recursive nature of this implementation inhibits inlining,
which means we never get to specialise to the action (`f` in the code above).
By contrast, the implementation below with a local loop makes it possible to
inline the entire definition (as happens for foldr, for example) thereby
specialising for the particular action.

For further information, see this Trac comment, which includes side-by-side
Core: https://ghc.haskell.org/trac/ghc/ticket/11795#comment:6
-}

-- | @'replicateM' n act@ performs the action @n@ times,
-- gathering the results.
replicateM        :: (Applicative m) => Int -> m a -> m [a]
{-# INLINABLE replicateM #-}
{-# SPECIALISE replicateM :: Int -> IO a -> IO [a] #-}
{-# SPECIALISE replicateM :: Int -> Maybe a -> Maybe [a] #-}
replicateM cnt0 f =
    loop cnt0
  where
    loop cnt
        | cnt <= 0  = pure []
        | otherwise = liftA2 (:) f (loop (cnt - 1))

-- | Like 'replicateM', but discards the result.
replicateM_       :: (Applicative m) => Int -> m a -> m ()
{-# INLINABLE replicateM_ #-}
{-# SPECIALISE replicateM_ :: Int -> IO a -> IO () #-}
{-# SPECIALISE replicateM_ :: Int -> Maybe a -> Maybe () #-}
replicateM_ cnt0 f =
    loop cnt0
  where
    loop cnt
        | cnt <= 0  = pure ()
        | otherwise = f *> loop (cnt - 1)

-- | The reverse of 'when'.
unless            :: (Applicative f) => Bool -> f () -> f ()
{-# INLINABLE unless #-}
{-# SPECIALISE unless :: Bool -> IO () -> IO () #-}
{-# SPECIALISE unless :: Bool -> Maybe () -> Maybe () #-}
unless p s        =  if p then pure () else s

infixl 4 <$!>

-- | Strict version of 'Data.Functor.<$>'.
--
-- @since 4.8.0.0
(<$!>) :: Monad m => (a -> b) -> m a -> m b
{-# INLINE (<$!>) #-}
f <$!> m = do
  x <- m
  let z = f x
  z `seq` return z

-- -----------------------------------------------------------------------------
-- Other MonadPlus functions

-- | Direct 'MonadPlus' equivalent of 'Data.List.filter'.
--
-- ==== __Examples__
--
-- The 'Data.List.filter' function is just 'mfilter' specialized to
-- the list monad:
--
-- @
-- 'Data.List.filter' = ( 'mfilter' :: (a -> Bool) -> [a] -> [a] )
-- @
--
-- An example using 'mfilter' with the 'Maybe' monad:
--
-- @
-- >>> mfilter odd (Just 1)
-- Just 1
-- >>> mfilter odd (Just 2)
-- Nothing
-- @
mfilter :: (MonadPlus m) => (a -> Bool) -> m a -> m a
{-# INLINABLE mfilter #-}
mfilter p ma = do
  a <- ma
  if p a then return a else mzero

{- $naming

The functions in this library use the following naming conventions:

* A postfix \'@M@\' always stands for a function in the Kleisli category:
  The monad type constructor @m@ is added to function results
  (modulo currying) and nowhere else.  So, for example,

> filter  ::              (a ->   Bool) -> [a] ->   [a]
> filterM :: (Monad m) => (a -> m Bool) -> [a] -> m [a]

* A postfix \'@_@\' changes the result type from @(m a)@ to @(m ())@.
  Thus, for example:

> sequence  :: Monad m => [m a] -> m [a]
> sequence_ :: Monad m => [m a] -> m ()

* A prefix \'@m@\' generalizes an existing function to a monadic form.
  Thus, for example:

> filter  ::                (a -> Bool) -> [a] -> [a]
> mfilter :: MonadPlus m => (a -> Bool) -> m a -> m a

-}


{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Concurrent.Chan
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  experimental
-- Portability :  non-portable (concurrency)
--
-- Unbounded channels.
--
-- The channels are implemented with @MVar@s and therefore inherit all the
-- caveats that apply to @MVar@s (possibility of races, deadlocks etc). The
-- stm (software transactional memory) library has a more robust implementation
-- of channels called @TChan@s.
--
-----------------------------------------------------------------------------

module Control.Concurrent.Chan
  (
          -- * The 'Chan' type
        Chan,                   -- abstract

          -- * Operations
        newChan,
        writeChan,
        readChan,
        dupChan,

          -- * Stream interface
        getChanContents,
        writeList2Chan,
   ) where

import System.IO.Unsafe         ( unsafeInterleaveIO )
import Control.Concurrent.MVar
import Control.Exception (mask_)

#define _UPK_(x) {-# UNPACK #-} !(x)

-- A channel is represented by two @MVar@s keeping track of the two ends
-- of the channel contents,i.e.,  the read- and write ends. Empty @MVar@s
-- are used to handle consumers trying to read from an empty channel.

-- |'Chan' is an abstract type representing an unbounded FIFO channel.
data Chan a
 = Chan _UPK_(MVar (Stream a))
        _UPK_(MVar (Stream a)) -- Invariant: the Stream a is always an empty MVar
   deriving Eq -- ^ @since 4.4.0.0

type Stream a = MVar (ChItem a)

data ChItem a = ChItem a _UPK_(Stream a)
  -- benchmarks show that unboxing the MVar here is worthwhile, because
  -- although it leads to higher allocation, the channel data takes up
  -- less space and is therefore quicker to GC.

-- See the Concurrent Haskell paper for a diagram explaining the
-- how the different channel operations proceed.

-- @newChan@ sets up the read and write end of a channel by initialising
-- these two @MVar@s with an empty @MVar@.

-- |Build and returns a new instance of 'Chan'.
newChan :: IO (Chan a)
newChan = do
   hole  <- newEmptyMVar
   readVar  <- newMVar hole
   writeVar <- newMVar hole
   return (Chan readVar writeVar)

-- To put an element on a channel, a new hole at the write end is created.
-- What was previously the empty @MVar@ at the back of the channel is then
-- filled in with a new stream element holding the entered value and the
-- new hole.

-- |Write a value to a 'Chan'.
writeChan :: Chan a -> a -> IO ()
writeChan (Chan _ writeVar) val = do
  new_hole <- newEmptyMVar
  mask_ $ do
    old_hole <- takeMVar writeVar
    putMVar old_hole (ChItem val new_hole)
    putMVar writeVar new_hole

-- The reason we don't simply do this:
--
--    modifyMVar_ writeVar $ \old_hole -> do
--      putMVar old_hole (ChItem val new_hole)
--      return new_hole
--
-- is because if an asynchronous exception is received after the 'putMVar'
-- completes and before modifyMVar_ installs the new value, it will set the
-- Chan's write end to a filled hole.

-- |Read the next value from the 'Chan'. Blocks when the channel is empty. Since
-- the read end of a channel is an 'MVar', this operation inherits fairness
-- guarantees of 'MVar's (e.g. threads blocked in this operation are woken up in
-- FIFO order).
--
-- Throws 'Control.Exception.BlockedIndefinitelyOnMVar' when the channel is
-- empty and no other thread holds a reference to the channel.
readChan :: Chan a -> IO a
readChan (Chan readVar _) = do
  modifyMVar readVar $ \read_end -> do
    (ChItem val new_read_end) <- readMVar read_end
        -- Use readMVar here, not takeMVar,
        -- else dupChan doesn't work
    return (new_read_end, val)

-- |Duplicate a 'Chan': the duplicate channel begins empty, but data written to
-- either channel from then on will be available from both.  Hence this creates
-- a kind of broadcast channel, where data written by anyone is seen by
-- everyone else.
--
-- (Note that a duplicated channel is not equal to its original.
-- So: @fmap (c /=) $ dupChan c@ returns @True@ for all @c@.)
dupChan :: Chan a -> IO (Chan a)
dupChan (Chan _ writeVar) = do
   hole       <- readMVar writeVar
   newReadVar <- newMVar hole
   return (Chan newReadVar writeVar)

-- Operators for interfacing with functional streams.

-- |Return a lazy list representing the contents of the supplied
-- 'Chan', much like 'System.IO.hGetContents'.
getChanContents :: Chan a -> IO [a]
getChanContents ch
  = unsafeInterleaveIO (do
        x  <- readChan ch
        xs <- getChanContents ch
        return (x:xs)
    )

-- |Write an entire list of items to a 'Chan'.
writeList2Chan :: Chan a -> [a] -> IO ()
writeList2Chan ch ls = sequence_ (map (writeChan ch) ls)


{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude, UnboxedTuples, MagicHash #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Concurrent.MVar
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  experimental
-- Portability :  non-portable (concurrency)
--
-- An @'MVar' t@ is mutable location that is either empty or contains a
-- value of type @t@.  It has two fundamental operations: 'putMVar'
-- which fills an 'MVar' if it is empty and blocks otherwise, and
-- 'takeMVar' which empties an 'MVar' if it is full and blocks
-- otherwise.  They can be used in multiple different ways:
--
--   1. As synchronized mutable variables,
--
--   2. As channels, with 'takeMVar' and 'putMVar' as receive and send, and
--
--   3. As a binary semaphore @'MVar' ()@, with 'takeMVar' and 'putMVar' as
--      wait and signal.
--
-- They were introduced in the paper
-- <https://www.haskell.org/ghc/docs/papers/concurrent-haskell.ps.gz "Concurrent Haskell">
-- by Simon Peyton Jones, Andrew Gordon and Sigbjorn Finne, though
-- some details of their implementation have since then changed (in
-- particular, a put on a full 'MVar' used to error, but now merely
-- blocks.)
--
-- === Applicability
--
-- 'MVar's offer more flexibility than 'Data.IORef.IORef's, but less flexibility
-- than 'GHC.Conc.STM'.  They are appropriate for building synchronization
-- primitives and performing simple interthread communication; however
-- they are very simple and susceptible to race conditions, deadlocks or
-- uncaught exceptions.  Do not use them if you need perform larger
-- atomic operations such as reading from multiple variables: use 'GHC.Conc.STM'
-- instead.
--
-- In particular, the "bigger" functions in this module ('swapMVar',
-- 'withMVar', 'modifyMVar_' and 'modifyMVar') are simply
-- the composition of a 'takeMVar' followed by a 'putMVar' with
-- exception safety.
-- These only have atomicity guarantees if all other threads
-- perform a 'takeMVar' before a 'putMVar' as well;  otherwise, they may
-- block.
--
-- === Fairness
--
-- No thread can be blocked indefinitely on an 'MVar' unless another
-- thread holds that 'MVar' indefinitely.  One usual implementation of
-- this fairness guarantee is that threads blocked on an 'MVar' are
-- served in a first-in-first-out fashion, but this is not guaranteed
-- in the semantics.
--
-- === Gotchas
--
-- Like many other Haskell data structures, 'MVar's are lazy.  This
-- means that if you place an expensive unevaluated thunk inside an
-- 'MVar', it will be evaluated by the thread that consumes it, not the
-- thread that produced it.  Be sure to 'evaluate' values to be placed
-- in an 'MVar' to the appropriate normal form, or utilize a strict
-- MVar provided by the strict-concurrency package.
--
-- === Ordering
--
-- 'MVar' operations are always observed to take place in the order
-- they are written in the program, regardless of the memory model of
-- the underlying machine.  This is in contrast to 'Data.IORef.IORef' operations
-- which may appear out-of-order to another thread in some cases.
--
-- === Example
--
-- Consider the following concurrent data structure, a skip channel.
-- This is a channel for an intermittent source of high bandwidth
-- information (for example, mouse movement events.)  Writing to the
-- channel never blocks, and reading from the channel only returns the
-- most recent value, or blocks if there are no new values.  Multiple
-- readers are supported with a @dupSkipChan@ operation.
--
-- A skip channel is a pair of 'MVar's. The first 'MVar' contains the
-- current value, and a list of semaphores that need to be notified
-- when it changes. The second 'MVar' is a semaphore for this particular
-- reader: it is full if there is a value in the channel that this
-- reader has not read yet, and empty otherwise.
--
-- @
--     data SkipChan a = SkipChan (MVar (a, [MVar ()])) (MVar ())
--
--     newSkipChan :: IO (SkipChan a)
--     newSkipChan = do
--         sem <- newEmptyMVar
--         main <- newMVar (undefined, [sem])
--         return (SkipChan main sem)
--
--     putSkipChan :: SkipChan a -> a -> IO ()
--     putSkipChan (SkipChan main _) v = do
--         (_, sems) <- takeMVar main
--         putMVar main (v, [])
--         mapM_ (\sem -> putMVar sem ()) sems
--
--     getSkipChan :: SkipChan a -> IO a
--     getSkipChan (SkipChan main sem) = do
--         takeMVar sem
--         (v, sems) <- takeMVar main
--         putMVar main (v, sem:sems)
--         return v
--
--     dupSkipChan :: SkipChan a -> IO (SkipChan a)
--     dupSkipChan (SkipChan main _) = do
--         sem <- newEmptyMVar
--         (v, sems) <- takeMVar main
--         putMVar main (v, sem:sems)
--         return (SkipChan main sem)
-- @
--
-- This example was adapted from the original Concurrent Haskell paper.
-- For more examples of 'MVar's being used to build higher-level
-- synchronization primitives, see 'Control.Concurrent.Chan' and
-- 'Control.Concurrent.QSem'.
--
-----------------------------------------------------------------------------

module Control.Concurrent.MVar
        (
          -- * @MVar@s
          MVar
        , newEmptyMVar
        , newMVar
        , takeMVar
        , putMVar
        , readMVar
        , swapMVar
        , tryTakeMVar
        , tryPutMVar
        , isEmptyMVar
        , withMVar
        , withMVarMasked
        , modifyMVar_
        , modifyMVar
        , modifyMVarMasked_
        , modifyMVarMasked
        , tryReadMVar
        , mkWeakMVar
        , addMVarFinalizer
    ) where

import GHC.MVar ( MVar(..), newEmptyMVar, newMVar, takeMVar, putMVar,
                  tryTakeMVar, tryPutMVar, isEmptyMVar, readMVar,
                  tryReadMVar
                )
import qualified GHC.MVar
import GHC.Weak
import GHC.Base

import Control.Exception.Base

{-|
  Take a value from an 'MVar', put a new value into the 'MVar' and
  return the value taken. This function is atomic only if there are
  no other producers for this 'MVar'.
-}
swapMVar :: MVar a -> a -> IO a
swapMVar mvar new =
  mask_ $ do
    old <- takeMVar mvar
    putMVar mvar new
    return old

{-|
  'withMVar' is an exception-safe wrapper for operating on the contents
  of an 'MVar'.  This operation is exception-safe: it will replace the
  original contents of the 'MVar' if an exception is raised (see
  "Control.Exception").  However, it is only atomic if there are no
  other producers for this 'MVar'.
-}
{-# INLINE withMVar #-}
-- inlining has been reported to have dramatic effects; see
-- http://www.haskell.org//pipermail/haskell/2006-May/017907.html
withMVar :: MVar a -> (a -> IO b) -> IO b
withMVar m io =
  mask $ \restore -> do
    a <- takeMVar m
    b <- restore (io a) `onException` putMVar m a
    putMVar m a
    return b

{-|
  Like 'withMVar', but the @IO@ action in the second argument is executed
  with asynchronous exceptions masked.

  @since 4.7.0.0
-}
{-# INLINE withMVarMasked #-}
withMVarMasked :: MVar a -> (a -> IO b) -> IO b
withMVarMasked m io =
  mask_ $ do
    a <- takeMVar m
    b <- io a `onException` putMVar m a
    putMVar m a
    return b

{-|
  An exception-safe wrapper for modifying the contents of an 'MVar'.
  Like 'withMVar', 'modifyMVar' will replace the original contents of
  the 'MVar' if an exception is raised during the operation.  This
  function is only atomic if there are no other producers for this
  'MVar'.
-}
{-# INLINE modifyMVar_ #-}
modifyMVar_ :: MVar a -> (a -> IO a) -> IO ()
modifyMVar_ m io =
  mask $ \restore -> do
    a  <- takeMVar m
    a' <- restore (io a) `onException` putMVar m a
    putMVar m a'

{-|
  A slight variation on 'modifyMVar_' that allows a value to be
  returned (@b@) in addition to the modified value of the 'MVar'.
-}
{-# INLINE modifyMVar #-}
modifyMVar :: MVar a -> (a -> IO (a,b)) -> IO b
modifyMVar m io =
  mask $ \restore -> do
    a      <- takeMVar m
    (a',b) <- restore (io a >>= evaluate) `onException` putMVar m a
    putMVar m a'
    return b

{-|
  Like 'modifyMVar_', but the @IO@ action in the second argument is executed with
  asynchronous exceptions masked.

  @since 4.6.0.0
-}
{-# INLINE modifyMVarMasked_ #-}
modifyMVarMasked_ :: MVar a -> (a -> IO a) -> IO ()
modifyMVarMasked_ m io =
  mask_ $ do
    a  <- takeMVar m
    a' <- io a `onException` putMVar m a
    putMVar m a'

{-|
  Like 'modifyMVar', but the @IO@ action in the second argument is executed with
  asynchronous exceptions masked.

  @since 4.6.0.0
-}
{-# INLINE modifyMVarMasked #-}
modifyMVarMasked :: MVar a -> (a -> IO (a,b)) -> IO b
modifyMVarMasked m io =
  mask_ $ do
    a      <- takeMVar m
    (a',b) <- (io a >>= evaluate) `onException` putMVar m a
    putMVar m a'
    return b

{-# DEPRECATED addMVarFinalizer "use 'mkWeakMVar' instead" #-} -- deprecated in 7.6
addMVarFinalizer :: MVar a -> IO () -> IO ()
addMVarFinalizer = GHC.MVar.addMVarFinalizer

-- | Make a 'Weak' pointer to an 'MVar', using the second argument as
-- a finalizer to run when 'MVar' is garbage-collected
--
-- @since 4.6.0.0
mkWeakMVar :: MVar a -> IO () -> IO (Weak (MVar a))
mkWeakMVar m@(MVar m#) (IO f) = IO $ \s ->
    case mkWeak# m# m f s of (# s1, w #) -> (# s1, Weak w #)


{-# LANGUAGE Safe #-}
{-# LANGUAGE BangPatterns #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Concurrent.QSem
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  experimental
-- Portability :  non-portable (concurrency)
--
-- Simple quantity semaphores.
--
-----------------------------------------------------------------------------

module Control.Concurrent.QSem
        ( -- * Simple Quantity Semaphores
          QSem,         -- abstract
          newQSem,      -- :: Int  -> IO QSem
          waitQSem,     -- :: QSem -> IO ()
          signalQSem    -- :: QSem -> IO ()
        ) where

import Control.Concurrent.MVar ( MVar, newEmptyMVar, takeMVar, tryTakeMVar
                          , putMVar, newMVar, tryPutMVar)
import Control.Exception
import Data.Maybe

-- | 'QSem' is a quantity semaphore in which the resource is acquired
-- and released in units of one. It provides guaranteed FIFO ordering
-- for satisfying blocked `waitQSem` calls.
--
-- The pattern
--
-- >   bracket_ waitQSem signalQSem (...)
--
-- is safe; it never loses a unit of the resource.
--
newtype QSem = QSem (MVar (Int, [MVar ()], [MVar ()]))

-- The semaphore state (i, xs, ys):
--
--   i is the current resource value
--
--   (xs,ys) is the queue of blocked threads, where the queue is
--           given by xs ++ reverse ys.  We can enqueue new blocked threads
--           by consing onto ys, and dequeue by removing from the head of xs.
--
-- A blocked thread is represented by an empty (MVar ()).  To unblock
-- the thread, we put () into the MVar.
--
-- A thread can dequeue itself by also putting () into the MVar, which
-- it must do if it receives an exception while blocked in waitQSem.
-- This means that when unblocking a thread in signalQSem we must
-- first check whether the MVar is already full; the MVar lock on the
-- semaphore itself resolves race conditions between signalQSem and a
-- thread attempting to dequeue itself.

-- |Build a new 'QSem' with a supplied initial quantity.
--  The initial quantity must be at least 0.
newQSem :: Int -> IO QSem
newQSem initial
  | initial < 0 = fail "newQSem: Initial quantity must be non-negative"
  | otherwise   = do
      sem <- newMVar (initial, [], [])
      return (QSem sem)

-- |Wait for a unit to become available
waitQSem :: QSem -> IO ()
waitQSem (QSem m) =
  mask_ $ do
    (i,b1,b2) <- takeMVar m
    if i == 0
       then do
         b <- newEmptyMVar
         putMVar m (i, b1, b:b2)
         wait b
       else do
         let !z = i-1
         putMVar m (z, b1, b2)
         return ()
  where
    wait b = takeMVar b `onException` do
                (uninterruptibleMask_ $ do -- Note [signal uninterruptible]
                   (i,b1,b2) <- takeMVar m
                   r <- tryTakeMVar b
                   r' <- if isJust r
                            then signal (i,b1,b2)
                            else do putMVar b (); return (i,b1,b2)
                   putMVar m r')

-- |Signal that a unit of the 'QSem' is available
signalQSem :: QSem -> IO ()
signalQSem (QSem m) =
  uninterruptibleMask_ $ do -- Note [signal uninterruptible]
    r <- takeMVar m
    r' <- signal r
    putMVar m r'

-- Note [signal uninterruptible]
--
--   If we have
--
--      bracket waitQSem signalQSem (...)
--
--   and an exception arrives at the signalQSem, then we must not lose
--   the resource.  The signalQSem is masked by bracket, but taking
--   the MVar might block, and so it would be interruptible.  Hence we
--   need an uninterruptibleMask here.
--
--   This isn't ideal: during high contention, some threads won't be
--   interruptible.  The QSemSTM implementation has better behaviour
--   here, but it performs much worse than this one in some
--   benchmarks.

signal :: (Int,[MVar ()],[MVar ()]) -> IO (Int,[MVar ()],[MVar ()])
signal (i,a1,a2) =
 if i == 0
   then loop a1 a2
   else let !z = i+1 in return (z, a1, a2)
 where
   loop [] [] = return (1, [], [])
   loop [] b2 = loop (reverse b2) []
   loop (b:bs) b2 = do
     r <- tryPutMVar b ()
     if r then return (0, bs, b2)
          else loop bs b2


{-# LANGUAGE Safe #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Concurrent.QSemN
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  experimental
-- Portability :  non-portable (concurrency)
--
-- Quantity semaphores in which each thread may wait for an arbitrary
-- \"amount\".
--
-----------------------------------------------------------------------------

module Control.Concurrent.QSemN
        (  -- * General Quantity Semaphores
          QSemN,        -- abstract
          newQSemN,     -- :: Int   -> IO QSemN
          waitQSemN,    -- :: QSemN -> Int -> IO ()
          signalQSemN   -- :: QSemN -> Int -> IO ()
      ) where

import Control.Concurrent.MVar ( MVar, newEmptyMVar, takeMVar, tryTakeMVar
                          , putMVar, newMVar
                          , tryPutMVar, isEmptyMVar)
import Control.Exception
import Data.Maybe

-- | 'QSemN' is a quantity semaphore in which the resource is acquired
-- and released in units of one. It provides guaranteed FIFO ordering
-- for satisfying blocked `waitQSemN` calls.
--
-- The pattern
--
-- >   bracket_ (waitQSemN n) (signalQSemN n) (...)
--
-- is safe; it never loses any of the resource.
--
newtype QSemN = QSemN (MVar (Int, [(Int, MVar ())], [(Int, MVar ())]))

-- The semaphore state (i, xs, ys):
--
--   i is the current resource value
--
--   (xs,ys) is the queue of blocked threads, where the queue is
--           given by xs ++ reverse ys.  We can enqueue new blocked threads
--           by consing onto ys, and dequeue by removing from the head of xs.
--
-- A blocked thread is represented by an empty (MVar ()).  To unblock
-- the thread, we put () into the MVar.
--
-- A thread can dequeue itself by also putting () into the MVar, which
-- it must do if it receives an exception while blocked in waitQSemN.
-- This means that when unblocking a thread in signalQSemN we must
-- first check whether the MVar is already full; the MVar lock on the
-- semaphore itself resolves race conditions between signalQSemN and a
-- thread attempting to dequeue itself.

-- |Build a new 'QSemN' with a supplied initial quantity.
--  The initial quantity must be at least 0.
newQSemN :: Int -> IO QSemN
newQSemN initial
  | initial < 0 = fail "newQSemN: Initial quantity must be non-negative"
  | otherwise   = do
      sem <- newMVar (initial, [], [])
      return (QSemN sem)

-- |Wait for the specified quantity to become available
waitQSemN :: QSemN -> Int -> IO ()
waitQSemN (QSemN m) sz =
  mask_ $ do
    (i,b1,b2) <- takeMVar m
    let z = i-sz
    if z < 0
       then do
         b <- newEmptyMVar
         putMVar m (i, b1, (sz,b):b2)
         wait b
       else do
         putMVar m (z, b1, b2)
         return ()
  where
    wait b = do
        takeMVar b `onException`
                (uninterruptibleMask_ $ do -- Note [signal uninterruptible]
                   (i,b1,b2) <- takeMVar m
                   r <- tryTakeMVar b
                   r' <- if isJust r
                            then signal sz (i,b1,b2)
                            else do putMVar b (); return (i,b1,b2)
                   putMVar m r')

-- |Signal that a given quantity is now available from the 'QSemN'.
signalQSemN :: QSemN -> Int -> IO ()
signalQSemN (QSemN m) sz = uninterruptibleMask_ $ do
  r <- takeMVar m
  r' <- signal sz r
  putMVar m r'

signal :: Int
       -> (Int,[(Int,MVar ())],[(Int,MVar ())])
       -> IO (Int,[(Int,MVar ())],[(Int,MVar ())])

signal sz0 (i,a1,a2) = loop (sz0 + i) a1 a2
 where
   loop 0  bs b2 = return (0,  bs, b2)
   loop sz [] [] = return (sz, [], [])
   loop sz [] b2 = loop sz (reverse b2) []
   loop sz ((j,b):bs) b2
     | j > sz = do
       r <- isEmptyMVar b
       if r then return (sz, (j,b):bs, b2)
            else loop sz bs b2
     | otherwise = do
       r <- tryPutMVar b ()
       if r then loop (sz-j) bs b2
            else loop sz bs b2


{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude, MagicHash #-}
{-# LANGUAGE StandaloneDeriving #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Exception.Base
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  experimental
-- Portability :  non-portable (extended exceptions)
--
-- Extensible exceptions, except for multiple handlers.
--
-----------------------------------------------------------------------------

module Control.Exception.Base (

        -- * The Exception type
        SomeException(..),
        Exception(..),
        IOException,
        ArithException(..),
        ArrayException(..),
        AssertionFailed(..),
        SomeAsyncException(..), AsyncException(..),
        asyncExceptionToException, asyncExceptionFromException,
        NonTermination(..),
        NestedAtomically(..),
        BlockedIndefinitelyOnMVar(..),
        FixIOException (..),
        BlockedIndefinitelyOnSTM(..),
        AllocationLimitExceeded(..),
        CompactionFailed(..),
        Deadlock(..),
        NoMethodError(..),
        PatternMatchFail(..),
        RecConError(..),
        RecSelError(..),
        RecUpdError(..),
        ErrorCall(..),
        TypeError(..), -- #10284, custom error type for deferred type errors

        -- * Throwing exceptions
        throwIO,
        throw,
        ioError,
        throwTo,

        -- * Catching Exceptions

        -- ** The @catch@ functions
        catch,
        catchJust,

        -- ** The @handle@ functions
        handle,
        handleJust,

        -- ** The @try@ functions
        try,
        tryJust,
        onException,

        -- ** The @evaluate@ function
        evaluate,

        -- ** The @mapException@ function
        mapException,

        -- * Asynchronous Exceptions

        -- ** Asynchronous exception control
        mask,
        mask_,
        uninterruptibleMask,
        uninterruptibleMask_,
        MaskingState(..),
        getMaskingState,

        -- * Assertions

        assert,

        -- * Utilities

        bracket,
        bracket_,
        bracketOnError,

        finally,

        -- * Calls for GHC runtime
        recSelError, recConError, runtimeError,
        nonExhaustiveGuardsError, patError, noMethodBindingError,
        absentError, absentSumFieldError, typeError,
        nonTermination, nestedAtomically,
  ) where

import GHC.Base
import GHC.IO hiding (bracket,finally,onException)
import GHC.IO.Exception
import GHC.Exception
import GHC.Show
-- import GHC.Exception hiding ( Exception )
import GHC.Conc.Sync

import Data.Either

-----------------------------------------------------------------------------
-- Catching exceptions

-- | The function 'catchJust' is like 'catch', but it takes an extra
-- argument which is an /exception predicate/, a function which
-- selects which type of exceptions we\'re interested in.
--
-- > catchJust (\e -> if isDoesNotExistErrorType (ioeGetErrorType e) then Just () else Nothing)
-- >           (readFile f)
-- >           (\_ -> do hPutStrLn stderr ("No such file: " ++ show f)
-- >                     return "")
--
-- Any other exceptions which are not matched by the predicate
-- are re-raised, and may be caught by an enclosing
-- 'catch', 'catchJust', etc.
catchJust
        :: Exception e
        => (e -> Maybe b)         -- ^ Predicate to select exceptions
        -> IO a                   -- ^ Computation to run
        -> (b -> IO a)            -- ^ Handler
        -> IO a
catchJust p a handler = catch a handler'
  where handler' e = case p e of
                        Nothing -> throwIO e
                        Just b  -> handler b

-- | A version of 'catch' with the arguments swapped around; useful in
-- situations where the code for the handler is shorter.  For example:
--
-- >   do handle (\NonTermination -> exitWith (ExitFailure 1)) $
-- >      ...
handle     :: Exception e => (e -> IO a) -> IO a -> IO a
handle     =  flip catch

-- | A version of 'catchJust' with the arguments swapped around (see
-- 'handle').
handleJust :: Exception e => (e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
handleJust p =  flip (catchJust p)

-----------------------------------------------------------------------------
-- 'mapException'

-- | This function maps one exception into another as proposed in the
-- paper \"A semantics for imprecise exceptions\".

-- Notice that the usage of 'unsafePerformIO' is safe here.

mapException :: (Exception e1, Exception e2) => (e1 -> e2) -> a -> a
mapException f v = unsafePerformIO (catch (evaluate v)
                                          (\x -> throwIO (f x)))

-----------------------------------------------------------------------------
-- 'try' and variations.

-- | Similar to 'catch', but returns an 'Either' result which is
-- @('Right' a)@ if no exception of type @e@ was raised, or @('Left' ex)@
-- if an exception of type @e@ was raised and its value is @ex@.
-- If any other type of exception is raised than it will be propogated
-- up to the next enclosing exception handler.
--
-- >  try a = catch (Right `liftM` a) (return . Left)

try :: Exception e => IO a -> IO (Either e a)
try a = catch (a >>= \ v -> return (Right v)) (\e -> return (Left e))

-- | A variant of 'try' that takes an exception predicate to select
-- which exceptions are caught (c.f. 'catchJust').  If the exception
-- does not match the predicate, it is re-thrown.
tryJust :: Exception e => (e -> Maybe b) -> IO a -> IO (Either b a)
tryJust p a = do
  r <- try a
  case r of
        Right v -> return (Right v)
        Left  e -> case p e of
                        Nothing -> throwIO e
                        Just b  -> return (Left b)

-- | Like 'finally', but only performs the final action if there was an
-- exception raised by the computation.
onException :: IO a -> IO b -> IO a
onException io what = io `catch` \e -> do _ <- what
                                          throwIO (e :: SomeException)

-----------------------------------------------------------------------------
-- Some Useful Functions

-- | When you want to acquire a resource, do some work with it, and
-- then release the resource, it is a good idea to use 'bracket',
-- because 'bracket' will install the necessary exception handler to
-- release the resource in the event that an exception is raised
-- during the computation.  If an exception is raised, then 'bracket' will
-- re-raise the exception (after performing the release).
--
-- A common example is opening a file:
--
-- > bracket
-- >   (openFile "filename" ReadMode)
-- >   (hClose)
-- >   (\fileHandle -> do { ... })
--
-- The arguments to 'bracket' are in this order so that we can partially apply
-- it, e.g.:
--
-- > withFile name mode = bracket (openFile name mode) hClose
--
bracket
        :: IO a         -- ^ computation to run first (\"acquire resource\")
        -> (a -> IO b)  -- ^ computation to run last (\"release resource\")
        -> (a -> IO c)  -- ^ computation to run in-between
        -> IO c         -- returns the value from the in-between computation
bracket before after thing =
  mask $ \restore -> do
    a <- before
    r <- restore (thing a) `onException` after a
    _ <- after a
    return r

-- | A specialised variant of 'bracket' with just a computation to run
-- afterward.
--
finally :: IO a         -- ^ computation to run first
        -> IO b         -- ^ computation to run afterward (even if an exception
                        -- was raised)
        -> IO a         -- returns the value from the first computation
a `finally` sequel =
  mask $ \restore -> do
    r <- restore a `onException` sequel
    _ <- sequel
    return r

-- | A variant of 'bracket' where the return value from the first computation
-- is not required.
bracket_ :: IO a -> IO b -> IO c -> IO c
bracket_ before after thing = bracket before (const after) (const thing)

-- | Like 'bracket', but only performs the final action if there was an
-- exception raised by the in-between computation.
bracketOnError
        :: IO a         -- ^ computation to run first (\"acquire resource\")
        -> (a -> IO b)  -- ^ computation to run last (\"release resource\")
        -> (a -> IO c)  -- ^ computation to run in-between
        -> IO c         -- returns the value from the in-between computation
bracketOnError before after thing =
  mask $ \restore -> do
    a <- before
    restore (thing a) `onException` after a

-----

-- |A pattern match failed. The @String@ gives information about the
-- source location of the pattern.
newtype PatternMatchFail = PatternMatchFail String

-- | @since 4.0
instance Show PatternMatchFail where
    showsPrec _ (PatternMatchFail err) = showString err

-- | @since 4.0
instance Exception PatternMatchFail

-----

-- |A record selector was applied to a constructor without the
-- appropriate field. This can only happen with a datatype with
-- multiple constructors, where some fields are in one constructor
-- but not another. The @String@ gives information about the source
-- location of the record selector.
newtype RecSelError = RecSelError String

-- | @since 4.0
instance Show RecSelError where
    showsPrec _ (RecSelError err) = showString err

-- | @since 4.0
instance Exception RecSelError

-----

-- |An uninitialised record field was used. The @String@ gives
-- information about the source location where the record was
-- constructed.
newtype RecConError = RecConError String

-- | @since 4.0
instance Show RecConError where
    showsPrec _ (RecConError err) = showString err

-- | @since 4.0
instance Exception RecConError

-----

-- |A record update was performed on a constructor without the
-- appropriate field. This can only happen with a datatype with
-- multiple constructors, where some fields are in one constructor
-- but not another. The @String@ gives information about the source
-- location of the record update.
newtype RecUpdError = RecUpdError String

-- | @since 4.0
instance Show RecUpdError where
    showsPrec _ (RecUpdError err) = showString err

-- | @since 4.0
instance Exception RecUpdError

-----

-- |A class method without a definition (neither a default definition,
-- nor a definition in the appropriate instance) was called. The
-- @String@ gives information about which method it was.
newtype NoMethodError = NoMethodError String

-- | @since 4.0
instance Show NoMethodError where
    showsPrec _ (NoMethodError err) = showString err

-- | @since 4.0
instance Exception NoMethodError

-----

-- |An expression that didn't typecheck during compile time was called.
-- This is only possible with -fdefer-type-errors. The @String@ gives
-- details about the failed type check.
--
-- @since 4.9.0.0
newtype TypeError = TypeError String

-- | @since 4.9.0.0
instance Show TypeError where
    showsPrec _ (TypeError err) = showString err

-- | @since 4.9.0.0
instance Exception TypeError

-----

-- |Thrown when the runtime system detects that the computation is
-- guaranteed not to terminate. Note that there is no guarantee that
-- the runtime system will notice whether any given computation is
-- guaranteed to terminate or not.
data NonTermination = NonTermination

-- | @since 4.0
instance Show NonTermination where
    showsPrec _ NonTermination = showString "<<loop>>"

-- | @since 4.0
instance Exception NonTermination

-----

-- |Thrown when the program attempts to call @atomically@, from the @stm@
-- package, inside another call to @atomically@.
data NestedAtomically = NestedAtomically

-- | @since 4.0
instance Show NestedAtomically where
    showsPrec _ NestedAtomically = showString "Control.Concurrent.STM.atomically was nested"

-- | @since 4.0
instance Exception NestedAtomically

-----

recSelError, recConError, runtimeError,
  nonExhaustiveGuardsError, patError, noMethodBindingError,
  absentError, typeError
        :: Addr# -> a   -- All take a UTF8-encoded C string

recSelError              s = throw (RecSelError ("No match in record selector "
                                                 ++ unpackCStringUtf8# s))  -- No location info unfortunately
runtimeError             s = errorWithoutStackTrace (unpackCStringUtf8# s)                   -- No location info unfortunately
absentError              s = errorWithoutStackTrace ("Oops!  Entered absent arg " ++ unpackCStringUtf8# s)

nonExhaustiveGuardsError s = throw (PatternMatchFail (untangle s "Non-exhaustive guards in"))
recConError              s = throw (RecConError      (untangle s "Missing field in record construction"))
noMethodBindingError     s = throw (NoMethodError    (untangle s "No instance nor default method for class operation"))
patError                 s = throw (PatternMatchFail (untangle s "Non-exhaustive patterns in"))
typeError                s = throw (TypeError        (unpackCStringUtf8# s))

-- GHC's RTS calls this
nonTermination :: SomeException
nonTermination = toException NonTermination

-- GHC's RTS calls this
nestedAtomically :: SomeException
nestedAtomically = toException NestedAtomically

-- Introduced by unarise for unused unboxed sum fields
absentSumFieldError :: a
absentSumFieldError = absentError " in unboxed sum."#


{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude #-}

-- |
-- Module      :  Control.Monad.Fail
-- Copyright   :  (C) 2015 David Luposchainsky,
--                (C) 2015 Herbert Valerio Riedel
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  provisional
-- Portability :  portable
--
-- Transitional module providing the 'MonadFail' class and primitive
-- instances.
--
-- This module can be imported for defining forward compatible
-- 'MonadFail' instances:
--
-- @
-- import qualified Control.Monad.Fail as Fail
--
-- instance Monad Foo where
--   (>>=) = {- ...bind impl... -}
--
--   -- Provide legacy 'fail' implementation for when
--   -- new-style MonadFail desugaring is not enabled.
--   fail = Fail.fail
--
-- instance Fail.MonadFail Foo where
--   fail = {- ...fail implementation... -}
-- @
--
-- See <https://prime.haskell.org/wiki/Libraries/Proposals/MonadFail>
-- for more details.
--
-- @since 4.9.0.0
--
module Control.Monad.Fail ( MonadFail(fail) ) where

import GHC.Base (String, Monad(), Maybe(Nothing), IO())
import {-# SOURCE #-} GHC.IO (failIO)

-- | When a value is bound in @do@-notation, the pattern on the left
-- hand side of @<-@ might not match. In this case, this class
-- provides a function to recover.
--
-- A 'Monad' without a 'MonadFail' instance may only be used in conjunction
-- with pattern that always match, such as newtypes, tuples, data types with
-- only a single data constructor, and irrefutable patterns (@~pat@).
--
-- Instances of 'MonadFail' should satisfy the following law: @fail s@ should
-- be a left zero for 'Control.Monad.>>=',
--
-- @
-- fail s >>= f  =  fail s
-- @
--
-- If your 'Monad' is also 'Control.Monad.MonadPlus', a popular definition is
--
-- @
-- fail _ = mzero
-- @
--
-- @since 4.9.0.0
class Monad m => MonadFail m where
    fail :: String -> m a

-- | @since 4.9.0.0
instance MonadFail Maybe where
    fail _ = Nothing

-- | @since 4.9.0.0
instance MonadFail [] where
    {-# INLINE fail #-}
    fail _ = []

-- | @since 4.9.0.0
instance MonadFail IO where
    fail = failIO


{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeOperators #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Monad.Fix
-- Copyright   :  (c) Andy Gill 2001,
--                (c) Oregon Graduate Institute of Science and Technology, 2002
-- License     :  BSD-style (see the file libraries/base/LICENSE)
-- Maintainer  :  libraries@haskell.org
-- Stability   :  experimental
-- Portability :  portable
--
-- Monadic fixpoints.
--
-- For a detailed discussion, see Levent Erkok's thesis,
-- /Value Recursion in Monadic Computations/, Oregon Graduate Institute, 2002.
--
-----------------------------------------------------------------------------

module Control.Monad.Fix (
        MonadFix(mfix),
        fix
  ) where

import Data.Either
import Data.Function ( fix )
import Data.Maybe
import Data.Monoid ( Dual(..), Sum(..), Product(..)
                   , First(..), Last(..), Alt(..), Ap(..) )
import Data.Ord ( Down(..) )
import GHC.Base ( Monad, NonEmpty(..), errorWithoutStackTrace, (.) )
import GHC.Generics
import GHC.List ( head, tail )
import Control.Monad.ST.Imp
import System.IO

-- | Monads having fixed points with a \'knot-tying\' semantics.
-- Instances of 'MonadFix' should satisfy the following laws:
--
-- [Purity]
--      @'mfix' ('Control.Monad.return' . h)  =  'Control.Monad.return' ('fix' h)@
--
-- [Left shrinking (or Tightening)]
--      @'mfix' (\\x -> a >>= \\y -> f x y)  =  a >>= \\y -> 'mfix' (\\x -> f x y)@
--
-- [Sliding]
--      @'mfix' ('Control.Monad.liftM' h . f)  =  'Control.Monad.liftM' h ('mfix' (f . h))@,
--      for strict @h@.
--
-- [Nesting]
--      @'mfix' (\\x -> 'mfix' (\\y -> f x y))  =  'mfix' (\\x -> f x x)@
--
-- This class is used in the translation of the recursive @do@ notation
-- supported by GHC and Hugs.
class (Monad m) => MonadFix m where
        -- | The fixed point of a monadic computation.
        -- @'mfix' f@ executes the action @f@ only once, with the eventual
        -- output fed back as the input.  Hence @f@ should not be strict,
        -- for then @'mfix' f@ would diverge.
        mfix :: (a -> m a) -> m a

-- Instances of MonadFix for Prelude monads

-- | @since 2.01
instance MonadFix Maybe where
    mfix f = let a = f (unJust a) in a
             where unJust (Just x) = x
                   unJust Nothing  = errorWithoutStackTrace "mfix Maybe: Nothing"

-- | @since 2.01
instance MonadFix [] where
    mfix f = case fix (f . head) of
               []    -> []
               (x:_) -> x : mfix (tail . f)

-- | @since 4.9.0.0
instance MonadFix NonEmpty where
  mfix f = case fix (f . neHead) of
             ~(x :| _) -> x :| mfix (neTail . f)
    where
      neHead ~(a :| _) = a
      neTail ~(_ :| as) = as

-- | @since 2.01
instance MonadFix IO where
    mfix = fixIO

-- | @since 2.01
instance MonadFix ((->) r) where
    mfix f = \ r -> let a = f a r in a

-- | @since 4.3.0.0
instance MonadFix (Either e) where
    mfix f = let a = f (unRight a) in a
             where unRight (Right x) = x
                   unRight (Left  _) = errorWithoutStackTrace "mfix Either: Left"

-- | @since 2.01
instance MonadFix (ST s) where
        mfix = fixST

-- Instances of Data.Monoid wrappers

-- | @since 4.8.0.0
instance MonadFix Dual where
    mfix f   = Dual (fix (getDual . f))

-- | @since 4.8.0.0
instance MonadFix Sum where
    mfix f   = Sum (fix (getSum . f))

-- | @since 4.8.0.0
instance MonadFix Product where
    mfix f   = Product (fix (getProduct . f))

-- | @since 4.8.0.0
instance MonadFix First where
    mfix f   = First (mfix (getFirst . f))

-- | @since 4.8.0.0
instance MonadFix Last where
    mfix f   = Last (mfix (getLast . f))

-- | @since 4.8.0.0
instance MonadFix f => MonadFix (Alt f) where
    mfix f   = Alt (mfix (getAlt . f))

-- | @since 4.12.0.0
instance MonadFix f => MonadFix (Ap f) where
    mfix f   = Ap (mfix (getAp . f))

-- Instances for GHC.Generics
-- | @since 4.9.0.0
instance MonadFix Par1 where
    mfix f = Par1 (fix (unPar1 . f))

-- | @since 4.9.0.0
instance MonadFix f => MonadFix (Rec1 f) where
    mfix f = Rec1 (mfix (unRec1 . f))

-- | @since 4.9.0.0
instance MonadFix f => MonadFix (M1 i c f) where
    mfix f = M1 (mfix (unM1. f))

-- | @since 4.9.0.0
instance (MonadFix f, MonadFix g) => MonadFix (f :*: g) where
    mfix f = (mfix (fstP . f)) :*: (mfix (sndP . f))
      where
        fstP (a :*: _) = a
        sndP (_ :*: b) = b

-- Instances for Data.Ord

-- | @since 4.12.0.0
instance MonadFix Down where
    mfix f = Down (fix (getDown . f))
      where getDown (Down x) = x


{-# LANGUAGE Safe #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Monad.Instances
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  provisional
-- Portability :  portable
--
-- /This module is DEPRECATED and will be removed in the future!/
--
-- 'Functor' and 'Monad' instances for @(->) r@ and
-- 'Functor' instances for @(,) a@ and @'Either' a@.

module Control.Monad.Instances {-# DEPRECATED "This module now contains no instances and will be removed in the future" #-} -- deprecated in 7.8
    (Functor(..),Monad(..)) where


{-# LANGUAGE Trustworthy #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Monad.ST
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  experimental
-- Portability :  non-portable (requires universal quantification for runST)
--
-- This library provides support for /strict/ state threads, as
-- described in the PLDI \'94 paper by John Launchbury and Simon Peyton
-- Jones /Lazy Functional State Threads/.
--
-- References (variables) that can be used within the @ST@ monad are
-- provided by "Data.STRef", and arrays are provided by
-- [Data.Array.ST](https://hackage.haskell.org/package/array/docs/Data-Array-ST.html).

-----------------------------------------------------------------------------

module Control.Monad.ST (
        -- * The 'ST' Monad
        ST,             -- abstract, instance of Functor, Monad, Typeable.
        runST,
        fixST,

        -- * Converting 'ST' to 'IO'
        RealWorld,              -- abstract
        stToIO,
    ) where

import Control.Monad.ST.Imp


{-# LANGUAGE Safe #-}
{-# LANGUAGE TypeOperators #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Monad.Zip
-- Copyright   :  (c) Nils Schweinsberg 2011,
--                (c) George Giorgidze 2011
--                (c) University Tuebingen 2011
-- License     :  BSD-style (see the file libraries/base/LICENSE)
-- Maintainer  :  libraries@haskell.org
-- Stability   :  experimental
-- Portability :  portable
--
-- Monadic zipping (used for monad comprehensions)
--
-----------------------------------------------------------------------------

module Control.Monad.Zip where

import Control.Monad (liftM, liftM2)
import Data.Functor.Identity
import Data.Monoid
import Data.Ord ( Down(..) )
import Data.Proxy
import qualified Data.List.NonEmpty as NE
import GHC.Generics

-- | Instances should satisfy the laws:
--
-- [Naturality]
--
--     @'liftM' (f 'Control.Arrow.***' g) ('mzip' ma mb)
--         = 'mzip' ('liftM' f ma) ('liftM' g mb)@
--
-- [Information Preservation]
--
--     @'liftM' ('Prelude.const' ()) ma = 'liftM' ('Prelude.const' ()) mb@
--         implies
--     @'munzip' ('mzip' ma mb) = (ma, mb)@
--
class Monad m => MonadZip m where
    {-# MINIMAL mzip | mzipWith #-}

    mzip :: m a -> m b -> m (a,b)
    mzip = mzipWith (,)

    mzipWith :: (a -> b -> c) -> m a -> m b -> m c
    mzipWith f ma mb = liftM (uncurry f) (mzip ma mb)

    munzip :: m (a,b) -> (m a, m b)
    munzip mab = (liftM fst mab, liftM snd mab)
    -- munzip is a member of the class because sometimes
    -- you can implement it more efficiently than the
    -- above default code.  See Trac #4370 comment by giorgidze

-- | @since 4.3.1.0
instance MonadZip [] where
    mzip     = zip
    mzipWith = zipWith
    munzip   = unzip

-- | @since 4.9.0.0
instance MonadZip NE.NonEmpty where
  mzip     = NE.zip
  mzipWith = NE.zipWith
  munzip   = NE.unzip

-- | @since 4.8.0.0
instance MonadZip Identity where
    mzipWith                 = liftM2
    munzip (Identity (a, b)) = (Identity a, Identity b)

-- | @since 4.8.0.0
instance MonadZip Dual where
    -- Cannot use coerce, it's unsafe
    mzipWith = liftM2

-- | @since 4.8.0.0
instance MonadZip Sum where
    mzipWith = liftM2

-- | @since 4.8.0.0
instance MonadZip Product where
    mzipWith = liftM2

-- | @since 4.8.0.0
instance MonadZip Maybe where
    mzipWith = liftM2

-- | @since 4.8.0.0
instance MonadZip First where
    mzipWith = liftM2

-- | @since 4.8.0.0
instance MonadZip Last where
    mzipWith = liftM2

-- | @since 4.8.0.0
instance MonadZip f => MonadZip (Alt f) where
    mzipWith f (Alt ma) (Alt mb) = Alt (mzipWith f ma mb)

-- | @since 4.9.0.0
instance MonadZip Proxy where
    mzipWith _ _ _ = Proxy

-- Instances for GHC.Generics
-- | @since 4.9.0.0
instance MonadZip U1 where
    mzipWith _ _ _ = U1

-- | @since 4.9.0.0
instance MonadZip Par1 where
    mzipWith = liftM2

-- | @since 4.9.0.0
instance MonadZip f => MonadZip (Rec1 f) where
    mzipWith f (Rec1 fa) (Rec1 fb) = Rec1 (mzipWith f fa fb)

-- | @since 4.9.0.0
instance MonadZip f => MonadZip (M1 i c f) where
    mzipWith f (M1 fa) (M1 fb) = M1 (mzipWith f fa fb)

-- | @since 4.9.0.0
instance (MonadZip f, MonadZip g) => MonadZip (f :*: g) where
    mzipWith f (x1 :*: y1) (x2 :*: y2) = mzipWith f x1 x2 :*: mzipWith f y1 y2

-- instances for Data.Ord

-- | @since 4.12.0.0
instance MonadZip Down where
    mzipWith = liftM2


{-# LANGUAGE Safe #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Monad.IO.Class
-- Copyright   :  (c) Andy Gill 2001,
--                (c) Oregon Graduate Institute of Science and Technology, 2001
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  R.Paterson@city.ac.uk
-- Stability   :  experimental
-- Portability :  portable
--
-- Class of monads based on @IO@.
-----------------------------------------------------------------------------

module Control.Monad.IO.Class (
    MonadIO(..)
  ) where

-- | Monads in which 'IO' computations may be embedded.
-- Any monad built by applying a sequence of monad transformers to the
-- 'IO' monad will be an instance of this class.
--
-- Instances should satisfy the following laws, which state that 'liftIO'
-- is a transformer of monads:
--
-- * @'liftIO' . 'return' = 'return'@
--
-- * @'liftIO' (m >>= f) = 'liftIO' m >>= ('liftIO' . f)@

class (Monad m) => MonadIO m where
    -- | Lift a computation from the 'IO' monad.
    liftIO :: IO a -> m a

-- | @since 4.9.0.0
instance MonadIO IO where
    liftIO = id