1{-# LANGUAGE CPP, ScopedTypeVariables, LambdaCase #-} 2 3-- | Defines a simple exception type and utilities to throw it. The 4-- 'PlainGhcException' type is a subset of the 'Panic.GhcException' 5-- type. It omits the exception constructors that involve 6-- pretty-printing via 'Outputable.SDoc'. 7-- 8-- There are two reasons for this: 9-- 10-- 1. To avoid import cycles / use of boot files. "Outputable" has 11-- many transitive dependencies. To throw exceptions from these 12-- modules, the functions here can be used without introducing import 13-- cycles. 14-- 15-- 2. To reduce the number of modules that need to be compiled to 16-- object code when loading GHC into GHCi. See #13101 17module PlainPanic 18 ( PlainGhcException(..) 19 , showPlainGhcException 20 21 , panic, sorry, pgmError 22 , cmdLineError, cmdLineErrorIO 23 , assertPanic 24 25 , progName 26 ) where 27 28#include "HsVersions.h" 29 30import Config 31import Exception 32import GHC.Stack 33import GhcPrelude 34import System.Environment 35import System.IO.Unsafe 36 37-- | This type is very similar to 'Panic.GhcException', but it omits 38-- the constructors that involve pretty-printing via 39-- 'Outputable.SDoc'. Due to the implementation of 'fromException' 40-- for 'Panic.GhcException', this type can be caught as a 41-- 'Panic.GhcException'. 42-- 43-- Note that this should only be used for throwing exceptions, not for 44-- catching, as 'Panic.GhcException' will not be converted to this 45-- type when catching. 46data PlainGhcException 47 -- | Some other fatal signal (SIGHUP,SIGTERM) 48 = PlainSignal Int 49 50 -- | Prints the short usage msg after the error 51 | PlainUsageError String 52 53 -- | A problem with the command line arguments, but don't print usage. 54 | PlainCmdLineError String 55 56 -- | The 'impossible' happened. 57 | PlainPanic String 58 59 -- | The user tickled something that's known not to work yet, 60 -- but we're not counting it as a bug. 61 | PlainSorry String 62 63 -- | An installation problem. 64 | PlainInstallationError String 65 66 -- | An error in the user's code, probably. 67 | PlainProgramError String 68 69instance Exception PlainGhcException 70 71instance Show PlainGhcException where 72 showsPrec _ e@(PlainProgramError _) = showPlainGhcException e 73 showsPrec _ e@(PlainCmdLineError _) = showString "<command line>: " . showPlainGhcException e 74 showsPrec _ e = showString progName . showString ": " . showPlainGhcException e 75 76-- | The name of this GHC. 77progName :: String 78progName = unsafePerformIO (getProgName) 79{-# NOINLINE progName #-} 80 81-- | Short usage information to display when we are given the wrong cmd line arguments. 82short_usage :: String 83short_usage = "Usage: For basic information, try the `--help' option." 84 85-- | Append a description of the given exception to this string. 86showPlainGhcException :: PlainGhcException -> ShowS 87showPlainGhcException = 88 \case 89 PlainSignal n -> showString "signal: " . shows n 90 PlainUsageError str -> showString str . showChar '\n' . showString short_usage 91 PlainCmdLineError str -> showString str 92 PlainPanic s -> panicMsg (showString s) 93 PlainSorry s -> sorryMsg (showString s) 94 PlainInstallationError str -> showString str 95 PlainProgramError str -> showString str 96 where 97 sorryMsg :: ShowS -> ShowS 98 sorryMsg s = 99 showString "sorry! (unimplemented feature or known bug)\n" 100 . showString (" (GHC version " ++ cProjectVersion ++ ":\n\t") 101 . s . showString "\n" 102 103 panicMsg :: ShowS -> ShowS 104 panicMsg s = 105 showString "panic! (the 'impossible' happened)\n" 106 . showString (" (GHC version " ++ cProjectVersion ++ ":\n\t") 107 . s . showString "\n\n" 108 . showString "Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug\n" 109 110throwPlainGhcException :: PlainGhcException -> a 111throwPlainGhcException = Exception.throw 112 113-- | Panics and asserts. 114panic, sorry, pgmError :: String -> a 115panic x = unsafeDupablePerformIO $ do 116 stack <- ccsToStrings =<< getCurrentCCS x 117 if null stack 118 then throwPlainGhcException (PlainPanic x) 119 else throwPlainGhcException (PlainPanic (x ++ '\n' : renderStack stack)) 120 121sorry x = throwPlainGhcException (PlainSorry x) 122pgmError x = throwPlainGhcException (PlainProgramError x) 123 124cmdLineError :: String -> a 125cmdLineError = unsafeDupablePerformIO . cmdLineErrorIO 126 127cmdLineErrorIO :: String -> IO a 128cmdLineErrorIO x = do 129 stack <- ccsToStrings =<< getCurrentCCS x 130 if null stack 131 then throwPlainGhcException (PlainCmdLineError x) 132 else throwPlainGhcException (PlainCmdLineError (x ++ '\n' : renderStack stack)) 133 134-- | Throw a failed assertion exception for a given filename and line number. 135assertPanic :: String -> Int -> a 136assertPanic file line = 137 Exception.throw (Exception.AssertionFailed 138 ("ASSERT failed! file " ++ file ++ ", line " ++ show line)) 139