module PlainPanic
( PlainGhcException(..)
, showPlainGhcException
, panic, sorry, pgmError
, cmdLineError, cmdLineErrorIO
, assertPanic
, progName
) where
#include "HsVersions.h"
import Config
import Exception
import GHC.Stack
import GhcPrelude
import System.Environment
import System.IO.Unsafe
data PlainGhcException
= PlainSignal Int
| PlainUsageError String
| PlainCmdLineError String
| PlainPanic String
| PlainSorry String
| PlainInstallationError String
| PlainProgramError String
instance Exception PlainGhcException
instance Show PlainGhcException where
showsPrec _ e@(PlainProgramError _) = showPlainGhcException e
showsPrec _ e@(PlainCmdLineError _) = showString "<command line>: " . showPlainGhcException e
showsPrec _ e = showString progName . showString ": " . showPlainGhcException e
progName :: String
progName = unsafePerformIO (getProgName)
short_usage :: String
short_usage = "Usage: For basic information, try the `--help' option."
showPlainGhcException :: PlainGhcException -> ShowS
showPlainGhcException =
\case
PlainSignal n -> showString "signal: " . shows n
PlainUsageError str -> showString str . showChar '\n' . showString short_usage
PlainCmdLineError str -> showString str
PlainPanic s -> panicMsg (showString s)
PlainSorry s -> sorryMsg (showString s)
PlainInstallationError str -> showString str
PlainProgramError str -> showString str
where
sorryMsg :: ShowS -> ShowS
sorryMsg s =
showString "sorry! (unimplemented feature or known bug)\n"
. showString (" (GHC version " ++ cProjectVersion ++ ":\n\t")
. s . showString "\n"
panicMsg :: ShowS -> ShowS
panicMsg s =
showString "panic! (the 'impossible' happened)\n"
. showString (" (GHC version " ++ cProjectVersion ++ ":\n\t")
. s . showString "\n\n"
. showString "Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug\n"
throwPlainGhcException :: PlainGhcException -> a
throwPlainGhcException = Exception.throw
panic, sorry, pgmError :: String -> a
panic x = unsafeDupablePerformIO $ do
stack <- ccsToStrings =<< getCurrentCCS x
if null stack
then throwPlainGhcException (PlainPanic x)
else throwPlainGhcException (PlainPanic (x ++ '\n' : renderStack stack))
sorry x = throwPlainGhcException (PlainSorry x)
pgmError x = throwPlainGhcException (PlainProgramError x)
cmdLineError :: String -> a
cmdLineError = unsafeDupablePerformIO . cmdLineErrorIO
cmdLineErrorIO :: String -> IO a
cmdLineErrorIO x = do
stack <- ccsToStrings =<< getCurrentCCS x
if null stack
then throwPlainGhcException (PlainCmdLineError x)
else throwPlainGhcException (PlainCmdLineError (x ++ '\n' : renderStack stack))
assertPanic :: String -> Int -> a
assertPanic file line =
Exception.throw (Exception.AssertionFailed
("ASSERT failed! file " ++ file ++ ", line " ++ show line))