{-# LANGUAGE CPP, ScopedTypeVariables, LambdaCase #-}
module GHC.Utils.Panic.Plain
( PlainGhcException(..)
, showPlainGhcException
, panic, sorry, pgmError
, cmdLineError, cmdLineErrorIO
, assertPanic
, progName
) where
#include "HsVersions.h"
import GHC.Settings.Config
import GHC.Utils.Exception as Exception
import GHC.Stack
import GHC.Prelude
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 :: Int -> PlainGhcException -> ShowS
showsPrec Int
_ e :: PlainGhcException
e@(PlainProgramError String
_) = PlainGhcException -> ShowS
showPlainGhcException PlainGhcException
e
showsPrec Int
_ e :: PlainGhcException
e@(PlainCmdLineError String
_) = String -> ShowS
showString String
"<command line>: " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PlainGhcException -> ShowS
showPlainGhcException PlainGhcException
e
showsPrec Int
_ PlainGhcException
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
. PlainGhcException -> ShowS
showPlainGhcException PlainGhcException
e
progName :: String
progName :: String
progName = IO String -> String
forall a. IO a -> a
unsafePerformIO (IO String
getProgName)
{-# NOINLINE progName #-}
short_usage :: String
short_usage :: String
short_usage = String
"Usage: For basic information, try the `--help' option."
showPlainGhcException :: PlainGhcException -> ShowS
showPlainGhcException :: PlainGhcException -> ShowS
showPlainGhcException =
\case
PlainSignal Int
n -> String -> ShowS
showString String
"signal: " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
n
PlainUsageError String
str -> String -> ShowS
showString String
str ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'\n' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
short_usage
PlainCmdLineError String
str -> String -> ShowS
showString String
str
PlainPanic String
s -> ShowS -> ShowS
panicMsg (String -> ShowS
showString String
s)
PlainSorry String
s -> ShowS -> ShowS
sorryMsg (String -> ShowS
showString String
s)
PlainInstallationError String
str -> String -> ShowS
showString String
str
PlainProgramError String
str -> String -> ShowS
showString String
str
where
sorryMsg :: ShowS -> ShowS
sorryMsg :: ShowS -> ShowS
sorryMsg ShowS
s =
String -> ShowS
showString String
"sorry! (unimplemented feature or known bug)\n"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (String
" (GHC version " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
cProjectVersion String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":\n\t")
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
s ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"\n"
panicMsg :: ShowS -> ShowS
panicMsg :: ShowS -> ShowS
panicMsg ShowS
s =
String -> ShowS
showString String
"panic! (the 'impossible' happened)\n"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (String
" (GHC version " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
cProjectVersion String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":\n\t")
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
s ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"\n\n"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug\n"
throwPlainGhcException :: PlainGhcException -> a
throwPlainGhcException :: forall a. PlainGhcException -> a
throwPlainGhcException = PlainGhcException -> a
forall a e. Exception e => e -> a
Exception.throw
panic, sorry, pgmError :: String -> a
panic :: forall a. String -> a
panic String
x = IO a -> a
forall a. IO a -> a
unsafeDupablePerformIO (IO a -> a) -> IO a -> a
forall a b. (a -> b) -> a -> b
$ do
[String]
stack <- Ptr CostCentreStack -> IO [String]
ccsToStrings (Ptr CostCentreStack -> IO [String])
-> IO (Ptr CostCentreStack) -> IO [String]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO (Ptr CostCentreStack)
forall dummy. dummy -> IO (Ptr CostCentreStack)
getCurrentCCS String
x
if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
stack
then PlainGhcException -> IO a
forall a. PlainGhcException -> a
throwPlainGhcException (String -> PlainGhcException
PlainPanic String
x)
else PlainGhcException -> IO a
forall a. PlainGhcException -> a
throwPlainGhcException (String -> PlainGhcException
PlainPanic (String
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'\n' Char -> ShowS
forall a. a -> [a] -> [a]
: [String] -> String
renderStack [String]
stack))
sorry :: forall a. String -> a
sorry String
x = PlainGhcException -> a
forall a. PlainGhcException -> a
throwPlainGhcException (String -> PlainGhcException
PlainSorry String
x)
pgmError :: forall a. String -> a
pgmError String
x = PlainGhcException -> a
forall a. PlainGhcException -> a
throwPlainGhcException (String -> PlainGhcException
PlainProgramError String
x)
cmdLineError :: String -> a
cmdLineError :: forall a. String -> a
cmdLineError = IO a -> a
forall a. IO a -> a
unsafeDupablePerformIO (IO a -> a) -> (String -> IO a) -> String -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO a
forall a. String -> IO a
cmdLineErrorIO
cmdLineErrorIO :: String -> IO a
cmdLineErrorIO :: forall a. String -> IO a
cmdLineErrorIO String
x = do
[String]
stack <- Ptr CostCentreStack -> IO [String]
ccsToStrings (Ptr CostCentreStack -> IO [String])
-> IO (Ptr CostCentreStack) -> IO [String]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO (Ptr CostCentreStack)
forall dummy. dummy -> IO (Ptr CostCentreStack)
getCurrentCCS String
x
if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
stack
then PlainGhcException -> IO a
forall a. PlainGhcException -> a
throwPlainGhcException (String -> PlainGhcException
PlainCmdLineError String
x)
else PlainGhcException -> IO a
forall a. PlainGhcException -> a
throwPlainGhcException (String -> PlainGhcException
PlainCmdLineError (String
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'\n' Char -> ShowS
forall a. a -> [a] -> [a]
: [String] -> String
renderStack [String]
stack))
assertPanic :: String -> Int -> a
assertPanic :: forall a. String -> Int -> a
assertPanic String
file Int
line =
AssertionFailed -> a
forall a e. Exception e => e -> a
Exception.throw (String -> AssertionFailed
Exception.AssertionFailed
(String
"ASSERT failed! file " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
file String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", line " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
line))