1 files changed, 138 insertions, 0 deletions
diff --git a/compiler/GHC/Utils/Panic/Plain.hs b/compiler/GHC/Utils/Panic/Plain.hs
new file mode 100644
index 0000000000..37e0574d4b
--- /dev/null
+++ b/compiler/GHC/Utils/Panic/Plain.hs
@@ -0,0 +1,138 @@
+{-# LANGUAGE CPP, ScopedTypeVariables, LambdaCase #-}
+
+-- | Defines a simple exception type and utilities to throw it. The
+-- 'PlainGhcException' type is a subset of the 'Panic.GhcException'
+-- type.  It omits the exception constructors that involve
+-- pretty-printing via 'Outputable.SDoc'.
+--
+-- There are two reasons for this:
+--
+-- 1. To avoid import cycles / use of boot files. "Outputable" has
+-- many transitive dependencies. To throw exceptions from these
+-- modules, the functions here can be used without introducing import
+-- cycles.
+--
+-- 2. To reduce the number of modules that need to be compiled to
+-- object code when loading GHC into GHCi. See #13101
+module GHC.Utils.Panic.Plain
+  ( PlainGhcException(..)
+  , showPlainGhcException
+
+  , panic, sorry, pgmError
+  , cmdLineError, cmdLineErrorIO
+  , assertPanic
+
+  , progName
+  ) where
+
+#include "HsVersions.h"
+
+import Config
+import GHC.Utils.Exception as Exception
+import GHC.Stack
+import GHC.Prelude
+import System.Environment
+import System.IO.Unsafe
+
+-- | This type is very similar to 'Panic.GhcException', but it omits
+-- the constructors that involve pretty-printing via
+-- 'Outputable.SDoc'.  Due to the implementation of 'fromException'
+-- for 'Panic.GhcException', this type can be caught as a
+-- 'Panic.GhcException'.
+--
+-- Note that this should only be used for throwing exceptions, not for
+-- catching, as 'Panic.GhcException' will not be converted to this
+-- type when catching.
+data PlainGhcException
+  -- | Some other fatal signal (SIGHUP,SIGTERM)
+  = PlainSignal Int
+
+  -- | Prints the short usage msg after the error
+  | PlainUsageError        String
+
+  -- | A problem with the command line arguments, but don't print usage.
+  | PlainCmdLineError      String
+
+  -- | The 'impossible' happened.
+  | PlainPanic             String
+
+  -- | The user tickled something that's known not to work yet,
+  --   but we're not counting it as a bug.
+  | PlainSorry             String
+
+  -- | An installation problem.
+  | PlainInstallationError String
+
+  -- | An error in the user's code, probably.
+  | 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
+
+-- | The name of this GHC.
+progName :: String
+progName = unsafePerformIO (getProgName)
+{-# NOINLINE progName #-}
+
+-- | Short usage information to display when we are given the wrong cmd line arguments.
+short_usage :: String
+short_usage = "Usage: For basic information, try the `--help' option."
+
+-- | Append a description of the given exception to this string.
+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
+
+-- | Panics and asserts.
+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))
+
+-- | Throw a failed assertion exception for a given filename and line number.
+assertPanic :: String -> Int -> a
+assertPanic file line =
+  Exception.throw (Exception.AssertionFailed
+           ("ASSERT failed! file " ++ file ++ ", line " ++ show line))