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