module GHC.Utils.Panic.Plain
( PlainGhcException(..)
, showPlainGhcException
, panic, sorry, pgmError
, cmdLineError, cmdLineErrorIO
, assertPanic
, assert, assertM, massert
) where
import GHC.Settings.Config
import GHC.Utils.Constants
import GHC.Utils.Exception as Exception
import GHC.Stack
import GHC.Prelude
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 = showPlainGhcException e
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))
assertPanic' :: HasCallStack => a
assertPanic' =
let doc = unlines $ fmap (" "++) $ lines (prettyCallStack callStack)
in
Exception.throw (Exception.AssertionFailed
("ASSERT failed!\n"
++ withFrozenCallStack doc))
assert :: HasCallStack => Bool -> a -> a
assert cond a =
if debugIsOn && not cond
then withFrozenCallStack assertPanic'
else a
massert :: (HasCallStack, Applicative m) => Bool -> m ()
massert cond = withFrozenCallStack (assert cond (pure ()))
assertM :: (HasCallStack, Monad m) => m Bool -> m ()
assertM mcond = withFrozenCallStack (mcond >>= massert)