{-
(c) The University of Glasgow 2006
(c) The GRASP Project, Glasgow University, 1992-2000

Defines basic functions for printing error messages.

It's hard to put these functions anywhere else without causing
some unnecessary loops in the module dependency graph.
-}

{-# LANGUAGE CPP, ScopedTypeVariables, LambdaCase #-}

module Panic (
     GhcException(..), showGhcException,
     throwGhcException, throwGhcExceptionIO,
     handleGhcException,
     progName,
     pgmError,

     panic, sorry, assertPanic, trace,
     panicDoc, sorryDoc, pgmErrorDoc,

     cmdLineError, cmdLineErrorIO,

     Exception.Exception(..), showException, safeShowException,
     try, tryMost, throwTo,

     withSignalHandlers,
) where
#include "HsVersions.h"

import GhcPrelude

import {-# SOURCE #-} Outputable (SDoc, showSDocUnsafe)

import Config
import Exception

import Control.Monad.IO.Class
import Control.Concurrent
import Debug.Trace        ( trace )
import System.IO.Unsafe
import System.Environment

#if !defined(mingw32_HOST_OS)
import System.Posix.Signals as S
#endif

#if defined(mingw32_HOST_OS)
import GHC.ConsoleHandler as S
#endif

import GHC.Stack
import System.Mem.Weak  ( deRefWeak )

-- | GHC's own exception type
--   error messages all take the form:
--
--  @
--      <location>: <error>
--  @
--
--   If the location is on the command line, or in GHC itself, then
--   <location>="ghc".  All of the error types below correspond to
--   a <location> of "ghc", except for ProgramError (where the string is
--  assumed to contain a location already, so we don't print one).

data GhcException
  -- | Some other fatal signal (SIGHUP,SIGTERM)
  = Signal Int

  -- | Prints the short usage msg after the error
  | UsageError   String

  -- | A problem with the command line arguments, but don't print usage.
  | CmdLineError String

  -- | The 'impossible' happened.
  | Panic        String
  | PprPanic     String SDoc

  -- | The user tickled something that's known not to work yet,
  --   but we're not counting it as a bug.
  | Sorry        String
  | PprSorry     String SDoc

  -- | An installation problem.
  | InstallationError String

  -- | An error in the user's code, probably.
  | ProgramError    String
  | PprProgramError String SDoc

instance Exception GhcException

instance Show GhcException where
  showsPrec :: Int -> GhcException -> ShowS
showsPrec _ e :: GhcException
e@(ProgramError _) = GhcException -> ShowS
showGhcException GhcException
e
  showsPrec _ e :: GhcException
e@(CmdLineError _) = String -> ShowS
showString "<command line>: " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GhcException -> ShowS
showGhcException GhcException
e
  showsPrec _ e :: GhcException
e = String -> ShowS
showString String
progName ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString ": " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GhcException -> ShowS
showGhcException GhcException
e


-- | The name of this GHC.
progName :: String
progName :: String
progName = IO String -> String
forall a. IO a -> a
unsafePerformIO (IO String
getProgName)
{-# NOINLINE progName #-}


-- | Short usage information to display when we are given the wrong cmd line arguments.
short_usage :: String
short_usage :: String
short_usage = "Usage: For basic information, try the `--help' option."


-- | Show an exception as a string.
showException :: Exception e => e -> String
showException :: e -> String
showException = e -> String
forall a. Show a => a -> String
show

-- | Show an exception which can possibly throw other exceptions.
-- Used when displaying exception thrown within TH code.
safeShowException :: Exception e => e -> IO String
safeShowException :: e -> IO String
safeShowException e :: e
e = do
    -- ensure the whole error message is evaluated inside try
    Either SomeException String
r <- IO String -> IO (Either SomeException String)
forall e a. Exception e => IO a -> IO (Either e a)
try (String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$! ShowS
forall a. [a] -> [a]
forceList (e -> String
forall e. Exception e => e -> String
showException e
e))
    case Either SomeException String
r of
        Right msg :: String
msg -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
msg
        Left e' :: SomeException
e' -> SomeException -> IO String
forall e. Exception e => e -> IO String
safeShowException (SomeException
e' :: SomeException)
    where
        forceList :: [a] -> [a]
forceList [] = []
        forceList xs :: [a]
xs@(x :: a
x : xt :: [a]
xt) = a
x a -> [a] -> [a]
forall a b. a -> b -> b
`seq` [a] -> [a]
forceList [a]
xt [a] -> [a] -> [a]
forall a b. a -> b -> b
`seq` [a]
xs

-- | Append a description of the given exception to this string.
--
-- Note that this uses 'DynFlags.unsafeGlobalDynFlags', which may have some
-- uninitialized fields if invoked before 'GHC.initGhcMonad' has been called.
-- If the error message to be printed includes a pretty-printer document
-- which forces one of these fields this call may bottom.
showGhcException :: GhcException -> ShowS
showGhcException :: GhcException -> ShowS
showGhcException exception :: GhcException
exception
 = case GhcException
exception of
        UsageError str :: String
str
         -> String -> ShowS
showString String
str ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar '\n' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
short_usage

        CmdLineError str :: String
str        -> String -> ShowS
showString String
str
        PprProgramError str :: String
str  sdoc :: SDoc
sdoc  ->
            String -> ShowS
showString String
str ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString "\n\n" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
            String -> ShowS
showString (SDoc -> String
showSDocUnsafe SDoc
sdoc)
        ProgramError str :: String
str        -> String -> ShowS
showString String
str
        InstallationError str :: String
str   -> String -> ShowS
showString String
str
        Signal n :: Int
n                -> String -> ShowS
showString "signal: " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
n

        PprPanic  s :: String
s sdoc :: SDoc
sdoc ->
            ShowS -> ShowS
panicMsg (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
s ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString "\n\n"
                     ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (SDoc -> String
showSDocUnsafe SDoc
sdoc)
        Panic s :: String
s -> ShowS -> ShowS
panicMsg (String -> ShowS
showString String
s)

        PprSorry  s :: String
s sdoc :: SDoc
sdoc ->
            ShowS -> ShowS
sorryMsg (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
s ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString "\n\n"
                     ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (SDoc -> String
showSDocUnsafe SDoc
sdoc)
        Sorry s :: String
s -> ShowS -> ShowS
sorryMsg (String -> ShowS
showString String
s)
  where
    sorryMsg :: ShowS -> ShowS
    sorryMsg :: ShowS -> ShowS
sorryMsg s :: ShowS
s =
        String -> ShowS
showString "sorry! (unimplemented feature or known bug)\n"
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString ("  (GHC version " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
cProjectVersion String -> ShowS
forall a. [a] -> [a] -> [a]
++ " for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TargetPlatform_NAME ++ "):\n\t")
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
s ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString "\n"

    panicMsg :: ShowS -> ShowS
    panicMsg :: ShowS -> ShowS
panicMsg s :: ShowS
s =
        String -> ShowS
showString "panic! (the 'impossible' happened)\n"
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString ("  (GHC version " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
cProjectVersion String -> ShowS
forall a. [a] -> [a] -> [a]
++ " for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TargetPlatform_NAME ++ "):\n\t")
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
s ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString "\n\n"
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString "Please report this as a GHC bug:  https://www.haskell.org/ghc/reportabug\n"


throwGhcException :: GhcException -> a
throwGhcException :: GhcException -> a
throwGhcException = GhcException -> a
forall a e. Exception e => e -> a
Exception.throw

throwGhcExceptionIO :: GhcException -> IO a
throwGhcExceptionIO :: GhcException -> IO a
throwGhcExceptionIO = GhcException -> IO a
forall e a. Exception e => e -> IO a
Exception.throwIO

handleGhcException :: ExceptionMonad m => (GhcException -> m a) -> m a -> m a
handleGhcException :: (GhcException -> m a) -> m a -> m a
handleGhcException = (GhcException -> m a) -> m a -> m a
forall (m :: * -> *) e a.
(ExceptionMonad m, Exception e) =>
(e -> m a) -> m a -> m a
ghandle


-- | Panics and asserts.
panic, sorry, pgmError :: String -> a
panic :: String -> a
panic    x :: String
x = IO a -> a
forall a. IO a -> a
unsafeDupablePerformIO (IO a -> a) -> IO a -> a
forall a b. (a -> b) -> a -> b
$ do
   [String]
stack <- Ptr CostCentreStack -> IO [String]
ccsToStrings (Ptr CostCentreStack -> IO [String])
-> IO (Ptr CostCentreStack) -> IO [String]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO (Ptr CostCentreStack)
forall dummy. dummy -> IO (Ptr CostCentreStack)
getCurrentCCS String
x
   if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
stack
      then GhcException -> IO a
forall a. GhcException -> a
throwGhcException (String -> GhcException
Panic String
x)
      else GhcException -> IO a
forall a. GhcException -> a
throwGhcException (String -> GhcException
Panic (String
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ '\n' Char -> ShowS
forall a. a -> [a] -> [a]
: [String] -> String
renderStack [String]
stack))

sorry :: String -> a
sorry    x :: String
x = GhcException -> a
forall a. GhcException -> a
throwGhcException (String -> GhcException
Sorry String
x)
pgmError :: String -> a
pgmError x :: String
x = GhcException -> a
forall a. GhcException -> a
throwGhcException (String -> GhcException
ProgramError String
x)

panicDoc, sorryDoc, pgmErrorDoc :: String -> SDoc -> a
panicDoc :: String -> SDoc -> a
panicDoc    x :: String
x doc :: SDoc
doc = GhcException -> a
forall a. GhcException -> a
throwGhcException (String -> SDoc -> GhcException
PprPanic        String
x SDoc
doc)
sorryDoc :: String -> SDoc -> a
sorryDoc    x :: String
x doc :: SDoc
doc = GhcException -> a
forall a. GhcException -> a
throwGhcException (String -> SDoc -> GhcException
PprSorry        String
x SDoc
doc)
pgmErrorDoc :: String -> SDoc -> a
pgmErrorDoc x :: String
x doc :: SDoc
doc = GhcException -> a
forall a. GhcException -> a
throwGhcException (String -> SDoc -> GhcException
PprProgramError String
x SDoc
doc)

cmdLineError :: String -> a
cmdLineError :: String -> a
cmdLineError = IO a -> a
forall a. IO a -> a
unsafeDupablePerformIO (IO a -> a) -> (String -> IO a) -> String -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO a
forall a. String -> IO a
cmdLineErrorIO

cmdLineErrorIO :: String -> IO a
cmdLineErrorIO :: String -> IO a
cmdLineErrorIO x :: String
x = do
  [String]
stack <- Ptr CostCentreStack -> IO [String]
ccsToStrings (Ptr CostCentreStack -> IO [String])
-> IO (Ptr CostCentreStack) -> IO [String]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO (Ptr CostCentreStack)
forall dummy. dummy -> IO (Ptr CostCentreStack)
getCurrentCCS String
x
  if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
stack
    then GhcException -> IO a
forall a. GhcException -> a
throwGhcException (String -> GhcException
CmdLineError String
x)
    else GhcException -> IO a
forall a. GhcException -> a
throwGhcException (String -> GhcException
CmdLineError (String
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ '\n' Char -> ShowS
forall a. a -> [a] -> [a]
: [String] -> String
renderStack [String]
stack))



-- | Throw a failed assertion exception for a given filename and line number.
assertPanic :: String -> Int -> a
assertPanic :: String -> Int -> a
assertPanic file :: String
file line :: Int
line =
  AssertionFailed -> a
forall a e. Exception e => e -> a
Exception.throw (String -> AssertionFailed
Exception.AssertionFailed
           ("ASSERT failed! file " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
file String -> ShowS
forall a. [a] -> [a] -> [a]
++ ", line " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
line))


-- | Like try, but pass through UserInterrupt and Panic exceptions.
--   Used when we want soft failures when reading interface files, for example.
--   TODO: I'm not entirely sure if this is catching what we really want to catch
tryMost :: IO a -> IO (Either SomeException a)
tryMost :: IO a -> IO (Either SomeException a)
tryMost action :: IO a
action = do Either SomeException a
r <- IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
try IO a
action
                    case Either SomeException a
r of
                        Left se :: SomeException
se ->
                            case SomeException -> Maybe GhcException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se of
                                -- Some GhcException's we rethrow,
                                Just (Signal _)  -> SomeException -> IO (Either SomeException a)
forall e a. Exception e => e -> IO a
throwIO SomeException
se
                                Just (Panic _)   -> SomeException -> IO (Either SomeException a)
forall e a. Exception e => e -> IO a
throwIO SomeException
se
                                -- others we return
                                Just _           -> Either SomeException a -> IO (Either SomeException a)
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeException -> Either SomeException a
forall a b. a -> Either a b
Left SomeException
se)
                                Nothing ->
                                    case SomeException -> Maybe IOException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se of
                                        -- All IOExceptions are returned
                                        Just (IOException
_ :: IOException) ->
                                            Either SomeException a -> IO (Either SomeException a)
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeException -> Either SomeException a
forall a b. a -> Either a b
Left SomeException
se)
                                        -- Anything else is rethrown
                                        Nothing -> SomeException -> IO (Either SomeException a)
forall e a. Exception e => e -> IO a
throwIO SomeException
se
                        Right v :: a
v -> Either SomeException a -> IO (Either SomeException a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Either SomeException a
forall a b. b -> Either a b
Right a
v)

-- | We use reference counting for signal handlers
{-# NOINLINE signalHandlersRefCount #-}
#if !defined(mingw32_HOST_OS)
signalHandlersRefCount :: MVar (Word, Maybe (S.Handler,S.Handler
                                            ,S.Handler,S.Handler))
#else
signalHandlersRefCount :: MVar (Word, Maybe S.Handler)
#endif
signalHandlersRefCount :: MVar (Word, Maybe (Handler, Handler, Handler, Handler))
signalHandlersRefCount = IO (MVar (Word, Maybe (Handler, Handler, Handler, Handler)))
-> MVar (Word, Maybe (Handler, Handler, Handler, Handler))
forall a. IO a -> a
unsafePerformIO (IO (MVar (Word, Maybe (Handler, Handler, Handler, Handler)))
 -> MVar (Word, Maybe (Handler, Handler, Handler, Handler)))
-> IO (MVar (Word, Maybe (Handler, Handler, Handler, Handler)))
-> MVar (Word, Maybe (Handler, Handler, Handler, Handler))
forall a b. (a -> b) -> a -> b
$ (Word, Maybe (Handler, Handler, Handler, Handler))
-> IO (MVar (Word, Maybe (Handler, Handler, Handler, Handler)))
forall a. a -> IO (MVar a)
newMVar (0,Maybe (Handler, Handler, Handler, Handler)
forall a. Maybe a
Nothing)


-- | Temporarily install standard signal handlers for catching ^C, which just
-- throw an exception in the current thread.
withSignalHandlers :: (ExceptionMonad m, MonadIO m) => m a -> m a
withSignalHandlers :: m a -> m a
withSignalHandlers act :: m a
act = do
  ThreadId
main_thread <- IO ThreadId -> m ThreadId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ThreadId
myThreadId
  Weak ThreadId
wtid <- IO (Weak ThreadId) -> m (Weak ThreadId)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ThreadId -> IO (Weak ThreadId)
mkWeakThreadId ThreadId
main_thread)

  let
      interrupt :: IO ()
interrupt = do
        Maybe ThreadId
r <- Weak ThreadId -> IO (Maybe ThreadId)
forall v. Weak v -> IO (Maybe v)
deRefWeak Weak ThreadId
wtid
        case Maybe ThreadId
r of
          Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Just t :: ThreadId
t  -> ThreadId -> AsyncException -> IO ()
forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
t AsyncException
UserInterrupt

#if !defined(mingw32_HOST_OS)
  let installHandlers :: IO (Handler, Handler, Handler, Handler)
installHandlers = do
        let installHandler' :: Signal -> Handler -> IO Handler
installHandler' a :: Signal
a b :: Handler
b = Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
a Handler
b Maybe SignalSet
forall a. Maybe a
Nothing
        Handler
hdlQUIT <- Signal -> Handler -> IO Handler
installHandler' Signal
sigQUIT  (IO () -> Handler
Catch IO ()
interrupt)
        Handler
hdlINT  <- Signal -> Handler -> IO Handler
installHandler' Signal
sigINT   (IO () -> Handler
Catch IO ()
interrupt)
        -- see #3656; in the future we should install these automatically for
        -- all Haskell programs in the same way that we install a ^C handler.
        let fatal_signal :: a -> IO ()
fatal_signal n :: a
n = ThreadId -> GhcException -> IO ()
forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
main_thread (Int -> GhcException
Signal (a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n))
        Handler
hdlHUP  <- Signal -> Handler -> IO Handler
installHandler' Signal
sigHUP   (IO () -> Handler
Catch (Signal -> IO ()
forall a. Integral a => a -> IO ()
fatal_signal Signal
sigHUP))
        Handler
hdlTERM <- Signal -> Handler -> IO Handler
installHandler' Signal
sigTERM  (IO () -> Handler
Catch (Signal -> IO ()
forall a. Integral a => a -> IO ()
fatal_signal Signal
sigTERM))
        (Handler, Handler, Handler, Handler)
-> IO (Handler, Handler, Handler, Handler)
forall (m :: * -> *) a. Monad m => a -> m a
return (Handler
hdlQUIT,Handler
hdlINT,Handler
hdlHUP,Handler
hdlTERM)

  let uninstallHandlers :: (Handler, Handler, Handler, Handler) -> IO ()
uninstallHandlers (hdlQUIT :: Handler
hdlQUIT,hdlINT :: Handler
hdlINT,hdlHUP :: Handler
hdlHUP,hdlTERM :: Handler
hdlTERM) = do
        Handler
_ <- Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
sigQUIT  Handler
hdlQUIT Maybe SignalSet
forall a. Maybe a
Nothing
        Handler
_ <- Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
sigINT   Handler
hdlINT  Maybe SignalSet
forall a. Maybe a
Nothing
        Handler
_ <- Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
sigHUP   Handler
hdlHUP  Maybe SignalSet
forall a. Maybe a
Nothing
        Handler
_ <- Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
sigTERM  Handler
hdlTERM Maybe SignalSet
forall a. Maybe a
Nothing
        () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#else
  -- GHC 6.3+ has support for console events on Windows
  -- NOTE: running GHCi under a bash shell for some reason requires
  -- you to press Ctrl-Break rather than Ctrl-C to provoke
  -- an interrupt.  Ctrl-C is getting blocked somewhere, I don't know
  -- why --SDM 17/12/2004
  let sig_handler ControlC = interrupt
      sig_handler Break    = interrupt
      sig_handler _        = return ()

  let installHandlers   = installHandler (Catch sig_handler)
  let uninstallHandlers = installHandler -- directly install the old handler
#endif

  -- install signal handlers if necessary
  let mayInstallHandlers :: m ()
mayInstallHandlers = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ MVar (Word, Maybe (Handler, Handler, Handler, Handler))
-> ((Word, Maybe (Handler, Handler, Handler, Handler))
    -> IO (Word, Maybe (Handler, Handler, Handler, Handler)))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Word, Maybe (Handler, Handler, Handler, Handler))
signalHandlersRefCount (((Word, Maybe (Handler, Handler, Handler, Handler))
  -> IO (Word, Maybe (Handler, Handler, Handler, Handler)))
 -> IO ())
-> ((Word, Maybe (Handler, Handler, Handler, Handler))
    -> IO (Word, Maybe (Handler, Handler, Handler, Handler)))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \case
        (0,Nothing)     -> do
          (Handler, Handler, Handler, Handler)
hdls <- IO (Handler, Handler, Handler, Handler)
installHandlers
          (Word, Maybe (Handler, Handler, Handler, Handler))
-> IO (Word, Maybe (Handler, Handler, Handler, Handler))
forall (m :: * -> *) a. Monad m => a -> m a
return (1,(Handler, Handler, Handler, Handler)
-> Maybe (Handler, Handler, Handler, Handler)
forall a. a -> Maybe a
Just (Handler, Handler, Handler, Handler)
hdls)
        (c :: Word
c,oldHandlers :: Maybe (Handler, Handler, Handler, Handler)
oldHandlers) -> (Word, Maybe (Handler, Handler, Handler, Handler))
-> IO (Word, Maybe (Handler, Handler, Handler, Handler))
forall (m :: * -> *) a. Monad m => a -> m a
return (Word
cWord -> Word -> Word
forall a. Num a => a -> a -> a
+1,Maybe (Handler, Handler, Handler, Handler)
oldHandlers)

  -- uninstall handlers if necessary
  let mayUninstallHandlers :: m ()
mayUninstallHandlers = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ MVar (Word, Maybe (Handler, Handler, Handler, Handler))
-> ((Word, Maybe (Handler, Handler, Handler, Handler))
    -> IO (Word, Maybe (Handler, Handler, Handler, Handler)))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Word, Maybe (Handler, Handler, Handler, Handler))
signalHandlersRefCount (((Word, Maybe (Handler, Handler, Handler, Handler))
  -> IO (Word, Maybe (Handler, Handler, Handler, Handler)))
 -> IO ())
-> ((Word, Maybe (Handler, Handler, Handler, Handler))
    -> IO (Word, Maybe (Handler, Handler, Handler, Handler)))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \case
        (1,Just hdls :: (Handler, Handler, Handler, Handler)
hdls)   -> do
          ()
_ <- (Handler, Handler, Handler, Handler) -> IO ()
uninstallHandlers (Handler, Handler, Handler, Handler)
hdls
          (Word, Maybe (Handler, Handler, Handler, Handler))
-> IO (Word, Maybe (Handler, Handler, Handler, Handler))
forall (m :: * -> *) a. Monad m => a -> m a
return (0,Maybe (Handler, Handler, Handler, Handler)
forall a. Maybe a
Nothing)
        (c :: Word
c,oldHandlers :: Maybe (Handler, Handler, Handler, Handler)
oldHandlers) -> (Word, Maybe (Handler, Handler, Handler, Handler))
-> IO (Word, Maybe (Handler, Handler, Handler, Handler))
forall (m :: * -> *) a. Monad m => a -> m a
return (Word
cWord -> Word -> Word
forall a. Num a => a -> a -> a
-1,Maybe (Handler, Handler, Handler, Handler)
oldHandlers)

  m ()
mayInstallHandlers
  m a
act m a -> m () -> m a
forall (m :: * -> *) a b. ExceptionMonad m => m a -> m b -> m a
`gfinally` m ()
mayUninstallHandlers