content: {-
  (c) The University of Glasgow 2006
  (c) The GRASP Project, Glasgow University, 1992-2000
  
  -}
  
  {-# LANGUAGE CPP #-}
  {-# LANGUAGE ScopedTypeVariables, LambdaCase #-}
  
  #include <ghcautoconf.h>
  
  -- | 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
     ( -- * GHC exception type
       GhcException(..)
     , showGhcException
     , showGhcExceptionUnsafe
     , throwGhcException
     , throwGhcExceptionIO
     , handleGhcException
  
       -- * Command error throwing patterns
     , pprPanic
     , panicDoc
     , sorryDoc
     , pgmErrorDoc
  
       -- ** Assertions
     , assertPprPanic
     , assertPpr
     , assertPprMaybe
     , assertPprM
     , massertPpr
  
       -- * Call stacks
     , callStackDoc
     , prettyCallStackDoc
  
       -- * Exception utilities
     , Exception.Exception(..)
     , showException
     , safeShowException
     , try
     , tryMost
     , throwTo
     , withSignalHandlers
     , module GHC.Utils.Panic.Plain
     )
  where
  
  import GHC.Prelude.Basic
  import GHC.Stack
  
  import GHC.Utils.Outputable
  import GHC.Utils.Panic.Plain
  import GHC.Utils.Constants
  
  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 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 e)
      | Just ge <- cast e = Just ge
      | Just pge <- cast e = Just $
          case pge of
            PlainSignal n -> Signal n
            PlainUsageError str -> UsageError str
            PlainCmdLineError str -> CmdLineError str
            PlainPanic str -> Panic str
            PlainSorry str -> Sorry str
            PlainInstallationError str -> InstallationError str
            PlainProgramError str -> ProgramError str
      | otherwise = Nothing
  
    -- Explicitly omit ExceptionContext since we generally don't
    -- want backtraces and other context in GHC's user errors.
    displayException exc = showGhcExceptionUnsafe exc ""
  
  instance Show GhcException where
    showsPrec _ e = showGhcExceptionUnsafe e
  
  -- | Show an exception as a string.
  showException :: Exception e => e -> String
  showException = 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 = do
      -- ensure the whole error message is evaluated inside try
      r <- try (return $! forceList (showException e))
      case r of
          Right msg -> return msg
          Left e' -> safeShowException (e' :: SomeException)
      where
          forceList [] = []
          forceList xs@(x : xt) = x `seq` forceList xt `seq` 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 = showGhcException defaultSDocContext
  
  -- | Append a description of the given exception to this string.
  showGhcException :: SDocContext -> GhcException -> ShowS
  showGhcException ctx = showPlainGhcException . \case
    Signal n -> PlainSignal n
    UsageError str -> PlainUsageError str
    CmdLineError str -> PlainCmdLineError str
    Panic str -> PlainPanic str
    Sorry str -> PlainSorry str
    InstallationError str -> PlainInstallationError str
    ProgramError str -> PlainProgramError str
  
    PprPanic str sdoc -> PlainPanic $
        concat [str, "\n\n", renderWithContext ctx sdoc]
    PprSorry str sdoc -> PlainProgramError $
        concat [str, "\n\n", renderWithContext ctx sdoc]
    PprProgramError str sdoc -> PlainProgramError $
        concat [str, "\n\n", renderWithContext ctx sdoc]
  
  throwGhcException :: HasCallStack => GhcException -> a
  throwGhcException = Exception.throw
  
  throwGhcExceptionIO :: GhcException -> IO a
  throwGhcExceptionIO = Exception.throwIO
  
  handleGhcException :: ExceptionMonad m => (GhcException -> m a) -> m a -> m a
  handleGhcException = MC.handle
  
  -- | Throw an exception saying "bug in GHC" with a callstack
  pprPanic :: HasCallStack => String -> SDoc -> a
  pprPanic s doc = withFrozenCallStack $ panicDoc s (doc $$ callStackDoc)
  
  -- | Throw an exception saying "bug in GHC"
  panicDoc :: HasCallStack => String -> SDoc -> a
  panicDoc x doc = withFrozenCallStack $ throwGhcException (PprPanic x doc)
  
  -- | Throw an exception saying "this isn't finished yet"
  sorryDoc :: String -> SDoc -> a
  sorryDoc x doc = throwGhcException (PprSorry x doc)
  
  -- | Throw an exception saying "bug in pgm being compiled" (used for unusual program errors)
  pgmErrorDoc :: String -> SDoc -> a
  pgmErrorDoc x doc = throwGhcException (PprProgramError x 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 action = do r <- try action
                      case r of
                          Left se ->
                              case fromException se of
                                  -- Some GhcException's we rethrow,
                                  Just (Signal _)  -> throwIO se
                                  Just (Panic _)   -> throwIO se
                                  -- others we return
                                  Just _           -> return (Left se)
                                  Nothing ->
                                      case fromException se of
                                          -- All IOExceptions are returned
                                          Just (_ :: IOException) ->
                                              return (Left se)
                                          -- Anything else is rethrown
                                          Nothing -> throwIO se
                          Right v -> return (Right 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 = unsafePerformIO $ newMVar (0,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
  #if !defined(HAVE_SIGNAL_H)
  -- No signal functionality exist on the host platform (e.g. on
  -- wasm32-wasi), so don't attempt to set up signal handlers
  withSignalHandlers = id
  #else
  withSignalHandlers act = do
    main_thread <- liftIO myThreadId
    wtid <- liftIO (mkWeakThreadId main_thread)
  
    let
        interrupt = do
          r <- deRefWeak wtid
          case r of
            Nothing -> return ()
            Just t  -> throwTo t UserInterrupt
  
  #if !defined(mingw32_HOST_OS)
    let installHandlers = do
          let installHandler' a b = installHandler a b Nothing
          hdlQUIT <- installHandler' sigQUIT  (Catch interrupt)
          hdlINT  <- installHandler' sigINT   (Catch 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 n = throwTo main_thread (Signal (fromIntegral n))
          hdlHUP  <- installHandler' sigHUP   (Catch (fatal_signal sigHUP))
          hdlTERM <- installHandler' sigTERM  (Catch (fatal_signal sigTERM))
          return (hdlQUIT,hdlINT,hdlHUP,hdlTERM)
  
    let uninstallHandlers (hdlQUIT,hdlINT,hdlHUP,hdlTERM) = do
          _ <- installHandler sigQUIT  hdlQUIT Nothing
          _ <- installHandler sigINT   hdlINT  Nothing
          _ <- installHandler sigHUP   hdlHUP  Nothing
          _ <- installHandler sigTERM  hdlTERM Nothing
          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 = liftIO $ modifyMVar_ signalHandlersRefCount $ \case
          (0,Nothing)     -> do
            hdls <- installHandlers
            return (1,Just hdls)
          (c,oldHandlers) -> return (c+1,oldHandlers)
  
    -- uninstall handlers if necessary
    let mayUninstallHandlers = liftIO $ modifyMVar_ signalHandlersRefCount $ \case
          (1,Just hdls)   -> do
            _ <- uninstallHandlers hdls
            return (0,Nothing)
          (c,oldHandlers) -> return (c-1,oldHandlers)
  
    mayInstallHandlers
    act `MC.finally` mayUninstallHandlers
  #endif
  
  callStackDoc :: HasCallStack => SDoc
  callStackDoc = prettyCallStackDoc callStack
  
  prettyCallStackDoc :: CallStack -> SDoc
  prettyCallStackDoc cs =
      hang (text "Call stack:")
         4 (vcat $ map text $ lines (prettyCallStack cs))
  
  -- | Panic with an assertion failure, recording the given file and
  -- line number. Should typically be accessed with the ASSERT family of macros
  assertPprPanic :: HasCallStack => SDoc -> a
  assertPprPanic msg = withFrozenCallStack (pprPanic "ASSERT failed!" msg)
  
  
  assertPpr :: HasCallStack => Bool -> SDoc -> a -> a
  {-# INLINE assertPpr #-}
  assertPpr cond msg a =
    if debugIsOn && not cond
      then withFrozenCallStack (assertPprPanic msg)
      else a
  
  assertPprMaybe :: HasCallStack => Maybe SDoc -> a -> a
  {-# INLINE assertPprMaybe #-}
  assertPprMaybe mb_msg a
    | debugIsOn, Just msg <- mb_msg = withFrozenCallStack (assertPprPanic msg)
    | otherwise                     = a
  
  massertPpr :: (HasCallStack, Applicative m) => Bool -> SDoc -> m ()
  {-# INLINE massertPpr #-}
  massertPpr cond msg = withFrozenCallStack (assertPpr cond msg (pure ()))
  
  assertPprM :: (HasCallStack, Monad m) => m Bool -> SDoc -> m ()
  {-# INLINE assertPprM #-}
  assertPprM mcond msg = withFrozenCallStack (mcond >>= \cond -> massertPpr cond msg)
  