diff options
| -rw-r--r-- | compiler/utils/Outputable.hs-boot | 2 | ||||
| -rw-r--r-- | compiler/utils/Panic.hs | 52 |
2 files changed, 34 insertions, 20 deletions
diff --git a/compiler/utils/Outputable.hs-boot b/compiler/utils/Outputable.hs-boot index 1c15a6982a..e5e88953cc 100644 --- a/compiler/utils/Outputable.hs-boot +++ b/compiler/utils/Outputable.hs-boot @@ -1,3 +1,5 @@ module Outputable where data SDoc + +showSDocUnsafe :: SDoc -> String diff --git a/compiler/utils/Panic.hs b/compiler/utils/Panic.hs index f1ccb7b5a5..b19c770718 100644 --- a/compiler/utils/Panic.hs +++ b/compiler/utils/Panic.hs @@ -27,7 +27,7 @@ module Panic ( ) where #include "HsVersions.h" -import {-# SOURCE #-} Outputable (SDoc) +import {-# SOURCE #-} Outputable (SDoc, showSDocUnsafe) import Config import Exception @@ -125,35 +125,47 @@ safeShowException e = do forceList xs@(x : xt) = x `seq` forceList xt `seq` xs -- | Append a description of the given exception to this string. -showGhcException :: GhcException -> String -> String +-- +-- Note that this uses 'DynFlags.unsafeGlobalDynFlags', which may have some +-- uninitialized fields if invoked before 'GHC.initGhcMonad' has been called. +-- If the error message to be printed includes a pretty-printer document +-- which forces one of these fields this call may bottom. +showGhcException :: GhcException -> ShowS showGhcException exception = case exception of UsageError str -> showString str . showChar '\n' . showString short_usage CmdLineError str -> showString str - PprProgramError str _ -> - showGhcException (ProgramError (str ++ "\n<<details unavailable>>")) + PprProgramError str sdoc -> + showString str . showString "\n\n" . + showString (showSDocUnsafe sdoc) ProgramError str -> showString str InstallationError str -> showString str Signal n -> showString "signal: " . shows n - PprPanic s _ -> - showGhcException (Panic (s ++ "\n<<details unavailable>>")) - Panic s - -> showString $ - "panic! (the 'impossible' happened)\n" - ++ " (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t" - ++ s ++ "\n\n" - ++ "Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug\n" - - PprSorry s _ -> - showGhcException (Sorry (s ++ "\n<<details unavailable>>")) - Sorry s - -> showString $ - "sorry! (unimplemented feature or known bug)\n" - ++ " (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t" - ++ s ++ "\n" + PprPanic s sdoc -> + panicMsg $ showString s . showString "\n\n" + . showString (showSDocUnsafe sdoc) + Panic s -> panicMsg (showString s) + + PprSorry s sdoc -> + sorryMsg $ showString s . showString "\n\n" + . showString (showSDocUnsafe sdoc) + Sorry s -> sorryMsg (showString s) + where + sorryMsg :: ShowS -> ShowS + sorryMsg s = + showString "sorry! (unimplemented feature or known bug)\n" + . showString (" (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t") + . s . showString "\n" + + panicMsg :: ShowS -> ShowS + panicMsg s = + showString "panic! (the 'impossible' happened)\n" + . showString (" (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t") + . s . showString "\n\n" + . showString "Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug\n" throwGhcException :: GhcException -> a |