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

-}

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

-- | 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.
module GHC.Utils.Panic (
     GhcException(..), showGhcException,
     throwGhcException, throwGhcExceptionIO,
     handleGhcException,
     GHC.Utils.Panic.Plain.progName,
     pgmError,

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

     cmdLineError, cmdLineErrorIO,

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

     withSignalHandlers,
) where

import GHC.Prelude

import {-# SOURCE #-} GHC.Utils.Outputable (SDoc, showSDocUnsafe)
import GHC.Utils.Panic.Plain

import GHC.Utils.Exception as Exception

import Control.Monad.IO.Class
import qualified Control.Monad.Catch as MC
import Control.Concurrent
import Data.Typeable      ( cast )
import Debug.Trace        ( trace )
import System.IO.Unsafe

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

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

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 where
  fromException :: SomeException -> Maybe GhcException
fromException (SomeException e
e)
    | Just GhcException
ge <- e -> Maybe GhcException
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
e = GhcException -> Maybe GhcException
forall a. a -> Maybe a
Just GhcException
ge
    | Just PlainGhcException
pge <- e -> Maybe PlainGhcException
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
e = GhcException -> Maybe GhcException
forall a. a -> Maybe a
Just (GhcException -> Maybe GhcException)
-> GhcException -> Maybe GhcException
forall a b. (a -> b) -> a -> b
$
        case PlainGhcException
pge of
          PlainSignal Int
n -> Int -> GhcException
Signal Int
n
          PlainUsageError String
str -> String -> GhcException
UsageError String
str
          PlainCmdLineError String
str -> String -> GhcException
CmdLineError String
str
          PlainPanic String
str -> String -> GhcException
Panic String
str
          PlainSorry String
str -> String -> GhcException
Sorry String
str
          PlainInstallationError String
str -> String -> GhcException
InstallationError String
str
          PlainProgramError String
str -> String -> GhcException
ProgramError String
str
    | Bool
otherwise = Maybe GhcException
forall a. Maybe a
Nothing

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

-- | Show an exception as a string.
showException :: Exception e => e -> String
showException :: forall e. Exception e => 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 :: forall e. Exception e => e -> IO String
safeShowException 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 String
msg -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
msg
        Left 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@(a
x : [a]
xt) = a
x a -> [a] -> [a]
`seq` [a] -> [a]
forceList [a]
xt [a] -> [a] -> [a]
`seq` [a]
xs

-- | Append a description of the given exception to this string.
--
-- Note that this uses 'GHC.Driver.Session.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 = PlainGhcException -> ShowS
showPlainGhcException (PlainGhcException -> ShowS)
-> (GhcException -> PlainGhcException) -> GhcException -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
  Signal Int
n -> Int -> PlainGhcException
PlainSignal Int
n
  UsageError String
str -> String -> PlainGhcException
PlainUsageError String
str
  CmdLineError String
str -> String -> PlainGhcException
PlainCmdLineError String
str
  Panic String
str -> String -> PlainGhcException
PlainPanic String
str
  Sorry String
str -> String -> PlainGhcException
PlainSorry String
str
  InstallationError String
str -> String -> PlainGhcException
PlainInstallationError String
str
  ProgramError String
str -> String -> PlainGhcException
PlainProgramError String
str

  PprPanic String
str SDoc
sdoc -> String -> PlainGhcException
PlainPanic (String -> PlainGhcException) -> String -> PlainGhcException
forall a b. (a -> b) -> a -> b
$
      [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
str, String
"\n\n", SDoc -> String
showSDocUnsafe SDoc
sdoc]
  PprSorry String
str SDoc
sdoc -> String -> PlainGhcException
PlainProgramError (String -> PlainGhcException) -> String -> PlainGhcException
forall a b. (a -> b) -> a -> b
$
      [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
str, String
"\n\n", SDoc -> String
showSDocUnsafe SDoc
sdoc]
  PprProgramError String
str SDoc
sdoc -> String -> PlainGhcException
PlainProgramError (String -> PlainGhcException) -> String -> PlainGhcException
forall a b. (a -> b) -> a -> b
$
      [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
str, String
"\n\n", SDoc -> String
showSDocUnsafe SDoc
sdoc]

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

throwGhcExceptionIO :: GhcException -> IO a
throwGhcExceptionIO :: forall a. 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 :: forall (m :: * -> *) a.
ExceptionMonad m =>
(GhcException -> m a) -> m a -> m a
handleGhcException = (GhcException -> m a) -> m a -> m a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
MC.handle

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

-- | 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 :: forall a. IO a -> IO (Either SomeException a)
tryMost 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 SomeException
se ->
                            case SomeException -> Maybe GhcException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se of
                                -- Some GhcException's we rethrow,
                                Just (Signal Int
_)  -> SomeException -> IO (Either SomeException a)
forall e a. Exception e => e -> IO a
throwIO SomeException
se
                                Just (Panic String
_)   -> SomeException -> IO (Either SomeException a)
forall e a. Exception e => e -> IO a
throwIO SomeException
se
                                -- others we return
                                Just GhcException
_           -> 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)
                                Maybe GhcException
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
                                        Maybe IOException
Nothing -> SomeException -> IO (Either SomeException a)
forall e a. Exception e => e -> IO a
throwIO SomeException
se
                        Right 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 (Word
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 => m a -> m a
withSignalHandlers :: forall (m :: * -> *) a. ExceptionMonad m => m a -> m a
withSignalHandlers 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
          Maybe ThreadId
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Just 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' :: CInt -> Handler -> IO Handler
installHandler' CInt
a Handler
b = CInt -> Handler -> Maybe SignalSet -> IO Handler
installHandler CInt
a Handler
b Maybe SignalSet
forall a. Maybe a
Nothing
        Handler
hdlQUIT <- CInt -> Handler -> IO Handler
installHandler' CInt
sigQUIT  (IO () -> Handler
Catch IO ()
interrupt)
        Handler
hdlINT  <- CInt -> Handler -> IO Handler
installHandler' CInt
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 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  <- CInt -> Handler -> IO Handler
installHandler' CInt
sigHUP   (IO () -> Handler
Catch (CInt -> IO ()
forall {a}. Integral a => a -> IO ()
fatal_signal CInt
sigHUP))
        Handler
hdlTERM <- CInt -> Handler -> IO Handler
installHandler' CInt
sigTERM  (IO () -> Handler
Catch (CInt -> IO ()
forall {a}. Integral a => a -> IO ()
fatal_signal CInt
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 (Handler
hdlQUIT,Handler
hdlINT,Handler
hdlHUP,Handler
hdlTERM) = do
        Handler
_ <- CInt -> Handler -> Maybe SignalSet -> IO Handler
installHandler CInt
sigQUIT  Handler
hdlQUIT Maybe SignalSet
forall a. Maybe a
Nothing
        Handler
_ <- CInt -> Handler -> Maybe SignalSet -> IO Handler
installHandler CInt
sigINT   Handler
hdlINT  Maybe SignalSet
forall a. Maybe a
Nothing
        Handler
_ <- CInt -> Handler -> Maybe SignalSet -> IO Handler
installHandler CInt
sigHUP   Handler
hdlHUP  Maybe SignalSet
forall a. Maybe a
Nothing
        Handler
_ <- CInt -> Handler -> Maybe SignalSet -> IO Handler
installHandler CInt
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
        (Word
0,Maybe (Handler, Handler, Handler, Handler)
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 (Word
1,(Handler, Handler, Handler, Handler)
-> Maybe (Handler, Handler, Handler, Handler)
forall a. a -> Maybe a
Just (Handler, Handler, Handler, Handler)
hdls)
        (Word
c,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
+Word
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
        (Word
1,Just (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 (Word
0,Maybe (Handler, Handler, Handler, Handler)
forall a. Maybe a
Nothing)
        (Word
c,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
-Word
1,Maybe (Handler, Handler, Handler, Handler)
oldHandlers)

  m ()
mayInstallHandlers
  m a
act m a -> m () -> m a
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`MC.finally` m ()
mayUninstallHandlers