X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2Fmain%2FErrUtils.lhs;h=d4e8e8fc73e83614074228eef8bf024169a3974b;hb=81466110ff8104ca60e20d617bab83f6f78f0ec2;hp=fdabacf5712c22ab0b289c1c70a0dda871b31546;hpb=0f5e104c36b1dc3d8deeec5fef3d65e7b3a1b5ad;p=ghc-hetmet.git

diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index fdabacf..d4e8e8f 100644
--- a/compiler/main/ErrUtils.lhs
+++ b/compiler/main/ErrUtils.lhs
@@ -8,7 +8,7 @@ module ErrUtils (
 	Message, mkLocMessage, printError,
 	Severity(..),
 
-	ErrMsg, WarnMsg,
+	ErrMsg, WarnMsg, throwErrMsg, handleErrMsg,
 	errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo,
 	Messages, errorsFound, emptyMessages,
 	mkErrMsg, mkWarnMsg, mkPlainErrMsg, mkLongErrMsg,
@@ -44,6 +44,7 @@ import System.Exit	( ExitCode(..), exitWith )
 import Data.Dynamic
 import Data.List
 import System.IO
+import Exception
 
 -- -----------------------------------------------------------------------------
 -- Basic error messages: just render a message with a source location.
@@ -81,16 +82,33 @@ data ErrMsg = ErrMsg {
 	-- NB  Pretty.Doc not SDoc: we deal with the printing style (in ptic 
 	-- whether to qualify an External Name) at the error occurrence
 
+#if __GLASGOW_HASKELL__ >= 609
+instance Exception ErrMsg
+#endif
+
+instance Show ErrMsg where
+    show em = showSDoc (errMsgShortDoc em)
+
+throwErrMsg :: ErrMsg -> a
+#if __GLASGOW_HASKELL__ < 609
+throwErrMsg = throwDyn
+#else
+throwErrMsg = throw
+#endif
+
+handleErrMsg :: (ErrMsg -> IO a) -> IO a -> IO a
+#if __GLASGOW_HASKELL__ < 609
+handleErrMsg = flip catchDyn
+#else
+handleErrMsg = handle
+#endif
+
 -- So we can throw these things as exceptions
 errMsgTc :: TyCon
 errMsgTc = mkTyCon "ErrMsg"
 {-# NOINLINE errMsgTc #-}
 instance Typeable ErrMsg where
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603
-  typeOf _ = mkAppTy errMsgTc []
-#else
   typeOf _ = mkTyConApp errMsgTc []
-#endif
 
 type WarnMsg = ErrMsg