[commit: ghc] master: Make Ppr* versions of the Sorry and PgmError exceptions too (2de63e5)

[Ian Lynagh]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/2de63e5a912f2abbda44a8125f374b19e8c3a0ff

>---------------------------------------------------------------

commit 2de63e5a912f2abbda44a8125f374b19e8c3a0ff
Author: Ian Lynagh <igloo at earth.li>
Date:   Mon Jun 11 17:41:20 2012 +0100

    Make Ppr* versions of the Sorry and PgmError exceptions too

>---------------------------------------------------------------

 compiler/main/ErrUtils.lhs    |    4 ++++
 compiler/utils/Outputable.lhs |    4 ++--
 compiler/utils/Panic.lhs      |   18 +++++++++++++-----
 3 files changed, 19 insertions(+), 7 deletions(-)

diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index d694c28..7de0232 100644
--- a/compiler/main/ErrUtils.lhs
+++ b/compiler/main/ErrUtils.lhs
@@ -338,6 +338,10 @@ prettyPrintGhcErrors :: ExceptionMonad m => m a -> m a
 prettyPrintGhcErrors = ghandle $ \e -> case e of
                                        PprPanic str doc ->
                                            pprDebugAndThen panic str doc
+                                       PprSorry str doc ->
+                                           pprDebugAndThen sorry str doc
+                                       PprProgramError str doc ->
+                                           pprDebugAndThen pgmError str doc
                                        _ ->
                                            throw e
 \end{code}
diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs
index 25fa15e..5f4b1ff 100644
--- a/compiler/utils/Outputable.lhs
+++ b/compiler/utils/Outputable.lhs
@@ -909,12 +909,12 @@ pprPanic    = panicDoc
 
 pprSorry :: String -> SDoc -> a
 -- ^ Throw an exception saying "this isn't finished yet"
-pprSorry    = pprDebugAndThen sorry
+pprSorry    = sorryDoc
 
 
 pprPgmError :: String -> SDoc -> a
 -- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors)
-pprPgmError = pprDebugAndThen pgmError
+pprPgmError = pgmErrorDoc
 
 
 pprTrace :: String -> SDoc -> a -> a
diff --git a/compiler/utils/Panic.lhs b/compiler/utils/Panic.lhs
index 019eec3..71233fb 100644
--- a/compiler/utils/Panic.lhs
+++ b/compiler/utils/Panic.lhs
@@ -14,7 +14,7 @@ module Panic (
      pgmError,
 
      panic, sorry, panicFastInt, assertPanic, trace,
-     panicDoc,
+     panicDoc, sorryDoc, pgmErrorDoc,
 
      Exception.Exception(..), showException, safeShowException, try, tryMost, throwTo,
 
@@ -87,12 +87,14 @@ data GhcException
   -- | The user tickled something that's known not to work yet,
   --   but we're not counting it as a bug.
   | Sorry        String
+  | PprSorry     String SDoc
 
   -- | An installation problem.
   | InstallationError String
 
   -- | An error in the user's code, probably.
-  | ProgramError String
+  | ProgramError    String
+  | PprProgramError String SDoc
   deriving (Typeable)
 
 instance Exception GhcException
@@ -144,6 +146,8 @@ showGhcException exception
             showString ")"
 
         CmdLineError str        -> showString str
+        PprProgramError str  _  ->
+            showGhcException (ProgramError (str ++ "\n<<details unavailable>>"))
         ProgramError str        -> showString str
         InstallationError str   -> showString str
         Signal n                -> showString "signal: " . shows n
@@ -157,6 +161,8 @@ showGhcException exception
                 ++ 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"
@@ -192,12 +198,14 @@ panic    x = unsafeDupablePerformIO $ do
 panic    x = throwGhcException (Panic x)
 #endif
 
-panicDoc :: String -> SDoc -> a
-panicDoc x doc = throwGhcException (PprPanic x doc)
-
 sorry    x = throwGhcException (Sorry x)
 pgmError x = throwGhcException (ProgramError x)
 
+panicDoc, sorryDoc, pgmErrorDoc :: String -> SDoc -> a
+panicDoc    x doc = throwGhcException (PprPanic        x doc)
+sorryDoc    x doc = throwGhcException (PprSorry        x doc)
+pgmErrorDoc x doc = throwGhcException (PprProgramError x doc)
+
 
 -- | Panic while pretending to return an unboxed int.
 --   You can't use the regular panic functions in expressions