Use a proper exception for IOEnvFailure, not just a UserError

diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index bf077aa..deca837 100644 (file)
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -88,7 +88,8 @@ Library
     Extensions: CPP, MagicHash, UnboxedTuples, PatternGuards,
                 ForeignFunctionInterface, EmptyDataDecls,
                 TypeSynonymInstances, MultiParamTypeClasses,
-                FlexibleInstances, Rank2Types, ScopedTypeVariables
+                FlexibleInstances, Rank2Types, ScopedTypeVariables,
+                DeriveDataTypeable
 
     Include-Dirs: . parser utils
 

diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index 1d562e3..929270b 100644 (file)
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -40,7 +40,6 @@ import StaticFlags
 import FastString
 import Panic
 import Util
-import Exception
 
 import System.IO
 import Data.IORef
@@ -543,7 +542,7 @@ discardWarnings thing_inside
 
 
 \begin{code}
-try_m :: TcRn r -> TcRn (Either IOException r)
+try_m :: TcRn r -> TcRn (Either IOEnvFailure r)
 -- Does try_m, with a debug-trace on failure
 try_m thing 
   = do { mb_r <- tryM thing ;

diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index 6d33b16..b4cb316 100644 (file)
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -596,15 +596,9 @@ runMeta convert expr
            Right v -> return v
            Left se ->
                     case fromException se of
-                    Just (ErrorCall "IOEnv failure") ->
+                    Just IOEnvFailure ->
                         failM -- Error already in Tc monad
-                    _ ->
-                        case fromException se of
-                        Just ioe
-                         | isUserError ioe &&
-                           (ioeGetErrorString ioe == "IOEnv failure") ->
-                            failM -- Error already in Tc monad
-                        _ -> failWithTc (mk_msg "run" se)      -- Exception
+                    _ -> failWithTc (mk_msg "run" se)  -- Exception
         }}}
   where
     mk_msg s exn = vcat [text "Exception when trying to" <+> text s <+> text "compile-time code:",
@@ -633,11 +627,10 @@ like that.  Here's how it's processed:
 
   * The TcM monad is an instance of Quasi (see TcSplice), and it implements
     (qReport True s) by using addErr to add an error message to the bag of errors.
-    The 'fail' in TcM raises a UserError, with the uninteresting string
-       "IOEnv failure"
+    The 'fail' in TcM raises an IOEnvFailure exception
 
   * So, when running a splice, we catch all exceptions; then for 
-       - a UserError "IOEnv failure", we assume the error is already 
+       - an IOEnvFailure exception, we assume the error is already 
                in the error-bag (above)
        - other errors, we add an error to the bag
     and then fail

diff --git a/compiler/utils/IOEnv.hs b/compiler/utils/IOEnv.hs
index 9332a8b..61345ca 100644 (file)
--- a/compiler/utils/IOEnv.hs
+++ b/compiler/utils/IOEnv.hs
@@ -12,6 +12,7 @@ module IOEnv (
 
         -- Errors
         failM, failWithM,
+        IOEnvFailure(..),
 
         -- Getting at the environment
         getEnv, setEnv, updEnv,
@@ -27,6 +28,7 @@ import Exception
 import Panic
 
 import Data.IORef       ( IORef, newIORef, readIORef, writeIORef, modifyIORef )
+import Data.Typeable
 import System.IO.Unsafe ( unsafeInterleaveIO )
 import System.IO        ( fixIO )
 import MonadUtils
@@ -65,12 +67,18 @@ thenM_ :: IOEnv env a -> IOEnv env b -> IOEnv env b
 thenM_ (IOEnv m) f = IOEnv (\ env -> do { m env ; unIOEnv f env })
 
 failM :: IOEnv env a
-failM = IOEnv (\ _ -> ioError (userError "IOEnv failure"))
+failM = IOEnv (\ _ -> throwIO IOEnvFailure)
 
 failWithM :: String -> IOEnv env a
 failWithM s = IOEnv (\ _ -> ioError (userError s))
 
+data IOEnvFailure = IOEnvFailure
+    deriving Typeable
 
+instance Show IOEnvFailure where
+    show IOEnvFailure = "IOEnv failure"
+
+instance Exception IOEnvFailure
 
 ----------------------------------------------------------------------
 -- Fundmantal combinators specific to the monad
@@ -95,7 +103,7 @@ fixM f = IOEnv (\ env -> fixIO (\ r -> unIOEnv (f r) env))
 
 
 ---------------------------
-tryM :: IOEnv env r -> IOEnv env (Either IOException r)
+tryM :: IOEnv env r -> IOEnv env (Either IOEnvFailure r)
 -- Reflect UserError exceptions (only) into IOEnv monad
 -- Other exceptions are not caught; they are simply propagated as exns
 --
@@ -103,7 +111,10 @@ tryM :: IOEnv env r -> IOEnv env (Either IOException r)
 -- to UserErrors.  But, say, pattern-match failures in GHC itself should
 -- not be caught here, else they'll be reported as errors in the program
 -- begin compiled!
-tryM (IOEnv thing) = IOEnv (\ env -> tryUser (thing env))
+tryM (IOEnv thing) = IOEnv (\ env -> tryIOEnvFailure (thing env))
+
+tryIOEnvFailure :: IO a -> IO (Either IOEnvFailure a)
+tryIOEnvFailure = try
 
 -- XXX We shouldn't be catching everything, e.g. timeouts
 tryAllM :: IOEnv env r -> IOEnv env (Either SomeException r)

diff --git a/compiler/utils/Panic.lhs b/compiler/utils/Panic.lhs
index e6c385c..a49a68d 100644 (file)
--- a/compiler/utils/Panic.lhs
+++ b/compiler/utils/Panic.lhs
@@ -17,7 +17,7 @@ module Panic
 
      panic, panicFastInt, assertPanic, trace,
      
-     Exception.Exception(..), showException, try, tryMost, tryUser, throwTo,
+     Exception.Exception(..), showException, try, tryMost, throwTo,
 
      installSignalHandlers, interruptTargetThread
    ) where
@@ -40,7 +40,6 @@ import Control.Concurrent ( MVar, ThreadId, withMVar, newMVar )
 import Data.Dynamic
 import Debug.Trace     ( trace )
 import System.IO.Unsafe        ( unsafePerformIO )
-import System.IO.Error hiding ( try )
 import System.Exit
 import System.Environment
 \end{code}
@@ -171,21 +170,6 @@ tryMost action = do r <- try action
                                         -- Anything else is rethrown
                                         Nothing -> throwIO se
                         Right v -> return (Right v)
-
--- | tryUser is like try, but catches only UserErrors.
--- These are the ones that are thrown by the TcRn monad 
--- to signal an error in the program being compiled
-tryUser :: IO a -> IO (Either IOException a)
-tryUser io =
-    do ei <- try io
-       case ei of
-           Right v -> return (Right v)
-           Left se ->
-                case fromException se of
-                   Just ioe
-                    | isUserError ioe ->
-                       return (Left ioe)
-                   _ -> throw se
 \end{code}
 
 Standard signal handlers for catching ^C, which just throw an