From f4ce543cff19b797d54d435dc7c804acdefca9c8 Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Fri, 3 Oct 2008 16:01:29 +0000 Subject: [PATCH] Use a proper exception for IOEnvFailure, not just a UserError --- compiler/ghc.cabal.in | 3 ++- compiler/typecheck/TcRnMonad.lhs | 3 +-- compiler/typecheck/TcSplice.lhs | 15 ++++----------- compiler/utils/IOEnv.hs | 17 ++++++++++++++--- compiler/utils/Panic.lhs | 18 +----------------- 5 files changed, 22 insertions(+), 34 deletions(-) diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index bf077aa..deca837 100644 --- 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 --- 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 --- 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 --- 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 --- 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 -- 1.7.10.4