    {-
    (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
       , showGhcExceptionUnsafe
       , throwGhcException
       , throwGhcExceptionIO
       , handleGhcException

       , GHC.Utils.Panic.Plain.progName
       , pgmError
       , panic
       , pprPanic
       , assertPanic
       , assertPprPanic
       , sorry
       , trace
       , panicDoc
       , sorryDoc
       , pgmErrorDoc
       , cmdLineError
       , cmdLineErrorIO
       , callStackDoc

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

    import GHC.Prelude
    import GHC.Stack

    import GHC.Utils.Outputable
    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 <- forall a b. (Typeable a, Typeable b) => a -> Maybe b
    cast e
    e = forall a. a -> Maybe a
    Just GhcException
    ge
        | Just PlainGhcException
    pge <- forall a b. (Typeable a, Typeable b) => a -> Maybe b
    cast e
    e = forall a. a -> Maybe a
    Just 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 = forall a. Maybe a
    Nothing

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

    -- | Show an exception as a string.
    showException :: Exception e => e -> String
    showException :: forall e. Exception e => e -> String
    showException = 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 <- forall e a. Exception e => IO a -> IO (Either e a)
    try (forall (m :: * -> *) a. Monad m => a -> m a
    return forall a b. (a -> b) -> a -> b
    $! forall {a}. [a] -> [a]
    forceList (forall e. Exception e => e -> String
    showException e
    e))
        case Either SomeException String
    r of
            Right String
    msg -> forall (m :: * -> *) a. Monad m => a -> m a
    return String
    msg
            Left SomeException
    e' -> 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 seq :: forall a b. a -> b -> b
    `seq` [a] -> [a]
    forceList [a]
    xt seq :: forall a b. a -> b -> b
    `seq` [a]
    xs

    -- | Append a description of the given exception to this string.
    --
    -- Note that this uses 'defaultSDocContext', which doesn't use the options
    -- set by the user via DynFlags.
    showGhcExceptionUnsafe :: GhcException -> ShowS
    showGhcExceptionUnsafe :: GhcException -> ShowS
    showGhcExceptionUnsafe = SDocContext -> GhcException -> ShowS
    showGhcException SDocContext
    defaultSDocContext

    -- | Append a description of the given exception to this string.
    showGhcException :: SDocContext -> GhcException -> ShowS
    showGhcException :: SDocContext -> GhcException -> ShowS
    showGhcException SDocContext
    ctx = PlainGhcException -> ShowS
    showPlainGhcException 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 forall a b. (a -> b) -> a -> b
    $
          forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat [String
    str, String
    "\n\n", SDocContext -> SDoc -> String
    renderWithContext SDocContext
    ctx SDoc
    sdoc]
      PprSorry String
    str SDoc
    sdoc -> String -> PlainGhcException
    PlainProgramError forall a b. (a -> b) -> a -> b
    $
          forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat [String
    str, String
    "\n\n", SDocContext -> SDoc -> String
    renderWithContext SDocContext
    ctx SDoc
    sdoc]
      PprProgramError String
    str SDoc
    sdoc -> String -> PlainGhcException
    PlainProgramError forall a b. (a -> b) -> a -> b
    $
          forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat [String
    str, String
    "\n\n", SDocContext -> SDoc -> String
    renderWithContext SDocContext
    ctx SDoc
    sdoc]

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

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

    -- | Throw an exception saying "bug in GHC" with a callstack
    pprPanic :: HasCallStack => String -> SDoc -> a
    pprPanic :: forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    s SDoc
    doc = forall a. String -> SDoc -> a
    panicDoc String
    s (SDoc
    doc SDoc -> SDoc -> SDoc
    $$ HasCallStack => SDoc
    callStackDoc)

    -- | Throw an exception saying "bug in GHC"
    panicDoc :: String -> SDoc -> a
    panicDoc :: forall a. String -> SDoc -> a
    panicDoc String
    x SDoc
    doc = forall a. GhcException -> a
    throwGhcException (String -> SDoc -> GhcException
    PprPanic String
    x SDoc
    doc)

    -- | Throw an exception saying "this isn't finished yet"
    sorryDoc :: String -> SDoc -> a
    sorryDoc :: forall a. String -> SDoc -> a
    sorryDoc String
    x SDoc
    doc = forall a. GhcException -> a
    throwGhcException (String -> SDoc -> GhcException
    PprSorry String
    x SDoc
    doc)

    -- | Throw an exception saying "bug in pgm being compiled" (used for unusual program errors)
    pgmErrorDoc :: String -> SDoc -> a
    pgmErrorDoc :: forall a. String -> SDoc -> a
    pgmErrorDoc String
    x SDoc
    doc = 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 <- 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 forall e. Exception e => SomeException -> Maybe e
    fromException SomeException
    se of
                                    -- Some GhcException's we rethrow,
                                    Just (Signal Int
    _)  -> forall e a. Exception e => e -> IO a
    throwIO SomeException
    se
                                    Just (Panic String
    _)   -> forall e a. Exception e => e -> IO a
    throwIO SomeException
    se
                                    -- others we return
                                    Just GhcException
    _           -> forall (m :: * -> *) a. Monad m => a -> m a
    return (forall a b. a -> Either a b
    Left SomeException
    se)
                                    Maybe GhcException
    Nothing ->
                                        case forall e. Exception e => SomeException -> Maybe e
    fromException SomeException
    se of
                                            -- All IOExceptions are returned
                                            Just (IOException
    _ :: IOException) ->
                                                forall (m :: * -> *) a. Monad m => a -> m a
    return (forall a b. a -> Either a b
    Left SomeException
    se)
                                            -- Anything else is rethrown
                                            Maybe IOException
    Nothing -> forall e a. Exception e => e -> IO a
    throwIO SomeException
    se
                            Right a
    v -> forall (m :: * -> *) a. Monad m => a -> m a
    return (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 = forall a. IO a -> a
    unsafePerformIO forall a b. (a -> b) -> a -> b
    $ forall a. a -> IO (MVar a)
    newMVar (Word
    0,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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO IO ThreadId
    myThreadId
      Weak ThreadId
    wtid <- 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 <- forall v. Weak v -> IO (Maybe v)
    deRefWeak Weak ThreadId
    wtid
            case Maybe ThreadId
    r of
              Maybe ThreadId
    Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
    return ()
              Just ThreadId
    t  -> 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 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 :: CInt -> IO ()
    fatal_signal CInt
    n = forall e. Exception e => ThreadId -> e -> IO ()
    throwTo ThreadId
    main_thread (Int -> GhcException
    Signal (forall a b. (Integral a, Num b) => a -> b
    fromIntegral CInt
    n))
            Handler
    hdlHUP  <- CInt -> Handler -> IO Handler
    installHandler' CInt
    sigHUP   (IO () -> Handler
    Catch (CInt -> IO ()
    fatal_signal CInt
    sigHUP))
            Handler
    hdlTERM <- CInt -> Handler -> IO Handler
    installHandler' CInt
    sigTERM  (IO () -> Handler
    Catch (CInt -> IO ()
    fatal_signal CInt
    sigTERM))
            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 forall a. Maybe a
    Nothing
            Handler
    _ <- CInt -> Handler -> Maybe SignalSet -> IO Handler
    installHandler CInt
    sigINT   Handler
    hdlINT  forall a. Maybe a
    Nothing
            Handler
    _ <- CInt -> Handler -> Maybe SignalSet -> IO Handler
    installHandler CInt
    sigHUP   Handler
    hdlHUP  forall a. Maybe a
    Nothing
            Handler
    _ <- CInt -> Handler -> Maybe SignalSet -> IO Handler
    installHandler CInt
    sigTERM  Handler
    hdlTERM forall a. Maybe a
    Nothing
            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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO forall a b. (a -> b) -> a -> b
    $ forall a. MVar a -> (a -> IO a) -> IO ()
    modifyMVar_ MVar (Word, Maybe (Handler, Handler, Handler, Handler))
    signalHandlersRefCount 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
              forall (m :: * -> *) a. Monad m => a -> m a
    return (Word
    1,forall a. a -> Maybe a
    Just (Handler, Handler, Handler, Handler)
    hdls)
            (Word
    c,Maybe (Handler, Handler, Handler, Handler)
    oldHandlers) -> forall (m :: * -> *) a. Monad m => a -> m a
    return (Word
    cforall a. Num a => a -> a -> a
    +Word
    1,Maybe (Handler, Handler, Handler, Handler)
    oldHandlers)

      -- uninstall handlers if necessary
      let mayUninstallHandlers :: m ()
    mayUninstallHandlers = forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO forall a b. (a -> b) -> a -> b
    $ forall a. MVar a -> (a -> IO a) -> IO ()
    modifyMVar_ MVar (Word, Maybe (Handler, Handler, Handler, Handler))
    signalHandlersRefCount 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
              forall (m :: * -> *) a. Monad m => a -> m a
    return (Word
    0,forall a. Maybe a
    Nothing)
            (Word
    c,Maybe (Handler, Handler, Handler, Handler)
    oldHandlers) -> forall (m :: * -> *) a. Monad m => a -> m a
    return (Word
    cforall a. Num a => a -> a -> a
    -Word
    1,Maybe (Handler, Handler, Handler, Handler)
    oldHandlers)

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

    callStackDoc :: HasCallStack => SDoc
    callStackDoc :: HasCallStack => SDoc
    callStackDoc =
        SDoc -> Int -> SDoc -> SDoc
    hang (String -> SDoc
    text String
    "Call stack:")
           Int
    4 ([SDoc] -> SDoc
    vcat forall a b. (a -> b) -> a -> b
    $ forall a b. (a -> b) -> [a] -> [b]
    map String -> SDoc
    text forall a b. (a -> b) -> a -> b
    $ String -> [String]
    lines (CallStack -> String
    prettyCallStack HasCallStack => CallStack
    callStack))

    -- | Panic with an assertion failure, recording the given file and
    -- line number. Should typically be accessed with the ASSERT family of macros
    assertPprPanic :: HasCallStack => String -> Int -> SDoc -> a
    assertPprPanic :: forall a. HasCallStack => String -> Int -> SDoc -> a
    assertPprPanic String
    _file Int
    _line SDoc
    msg
      = forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "ASSERT failed!" SDoc
    msg