From 81466110ff8104ca60e20d617bab83f6f78f0ec2 Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Thu, 31 Jul 2008 17:33:54 +0000 Subject: [PATCH] Follow changes in the base library TopHandler now uses the new extensible exceptions module, so we need to interact with it using the new types. --- compiler/ghci/GhciMonad.hs | 8 ++-- compiler/ghci/InteractiveUI.hs | 28 +++++++++---- compiler/ghci/Linker.lhs | 2 +- compiler/main/DriverMkDepend.hs | 7 ++-- compiler/main/DriverPipeline.hs | 2 +- compiler/main/ErrUtils.lhs | 24 ++++++++++- compiler/main/GHC.hs | 81 +++++++++++++++++++++++------------ compiler/main/HeaderInfo.hs | 2 +- compiler/main/InteractiveEval.hs | 22 ++++++++-- compiler/main/Packages.lhs | 6 ++- compiler/typecheck/TcRnMonad.lhs | 7 +++- compiler/typecheck/TcSplice.lhs | 12 ++++++ compiler/utils/Exception.hs | 37 ++++++++++++---- compiler/utils/IOEnv.hs | 12 ++++-- compiler/utils/Panic.lhs | 86 +++++++++++++++++++++++++++++++++++--- compiler/utils/Util.lhs | 19 --------- 16 files changed, 267 insertions(+), 88 deletions(-) diff --git a/compiler/ghci/GhciMonad.hs b/compiler/ghci/GhciMonad.hs index 387d17e..f7c5c01 100644 --- a/compiler/ghci/GhciMonad.hs +++ b/compiler/ghci/GhciMonad.hs @@ -28,13 +28,11 @@ import StaticFlags import Data.Maybe import Numeric -import Exception import Data.Array import Data.Char import Data.Int ( Int64 ) import Data.IORef import Data.List -import Data.Typeable import System.CPUTime import System.Directory import System.Environment @@ -140,9 +138,9 @@ instance Monad GHCi where instance Functor GHCi where fmap f m = m >>= return . f -ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a -ghciHandleDyn h (GHCi m) = GHCi $ \s -> - Exception.catchDyn (m s) (\e -> unGHCi (h e) s) +ghciHandleGhcException :: (GhcException -> GHCi a) -> GHCi a -> GHCi a +ghciHandleGhcException h (GHCi m) = GHCi $ \s -> + handleGhcException (\e -> unGHCi (h e) s) (m s) getGHCiState :: GHCi GHCiState getGHCiState = GHCi $ \r -> readIORef r diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index 7adb064..592a13a 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -468,7 +468,7 @@ runGHCi paths maybe_exprs = do interactiveLoop :: Bool -> Bool -> GHCi () interactiveLoop is_tty show_prompt = -- Ignore ^C exceptions caught here - ghciHandleDyn (\e -> case e of + ghciHandleGhcException (\e -> case e of Interrupted -> do #if defined(mingw32_HOST_OS) io (putStrLn "") @@ -504,7 +504,7 @@ checkPerms _ = return True #else checkPerms name = - Util.handle (\_ -> return False) $ do + handleIO (\_ -> return False) $ do st <- getFileStatus name me <- getRealUserID if fileOwner st /= me then do @@ -650,7 +650,7 @@ queryQueue = do runCommands :: GHCi (Maybe String) -> GHCi () runCommands = runCommands' handler -runCommands' :: (Exception -> GHCi Bool) -- Exception handler +runCommands' :: (SomeException -> GHCi Bool) -- Exception handler -> GHCi (Maybe String) -> GHCi () runCommands' eh getCmd = do mb_cmd <- noSpace queryQueue @@ -1822,14 +1822,15 @@ completeHomeModuleOrFile=completeNone -- raising another exception. We therefore don't put the recursive -- handler arond the flushing operation, so if stderr is closed -- GHCi will just die gracefully rather than going into an infinite loop. -handler :: Exception -> GHCi Bool +handler :: SomeException -> GHCi Bool handler exception = do flushInterpBuffers io installSignalHandlers ghciHandle handler (showException exception >> return False) -showException :: Exception -> GHCi () +showException :: SomeException -> GHCi () +#if __GLASGOW_HASKELL__ < 609 showException (DynException dyn) = case fromDynamic dyn of Nothing -> io (putStrLn ("*** Exception: (unknown)")) @@ -1840,6 +1841,17 @@ showException (DynException dyn) = showException other_exception = io (putStrLn ("*** Exception: " ++ show other_exception)) +#else +showException (SomeException e) = + io $ case cast e of + Just Interrupted -> putStrLn "Interrupted." + -- omit the location for CmdLineError: + Just (CmdLineError s) -> putStrLn s + -- ditto: + Just ph@(PhaseFailed {}) -> putStrLn (showGhcException ph "") + Just other_ghc_ex -> print other_ghc_ex + Nothing -> putStrLn ("*** Exception: " ++ show e) +#endif ----------------------------------------------------------------------------- -- recursive exception handlers @@ -1848,7 +1860,7 @@ showException other_exception -- in an exception loop (eg. let a = error a in a) the ^C exception -- may never be delivered. Thanks to Marcin for pointing out the bug. -ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a +ghciHandle :: (SomeException -> GHCi a) -> GHCi a -> GHCi a ghciHandle h (GHCi m) = GHCi $ \s -> Exception.catch (m s) (\e -> unGHCi (ghciUnblock (h e)) s) @@ -1856,7 +1868,7 @@ ghciHandle h (GHCi m) = GHCi $ \s -> ghciUnblock :: GHCi a -> GHCi a ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s) -ghciTry :: GHCi a -> GHCi (Either Exception a) +ghciTry :: GHCi a -> GHCi (Either SomeException a) ghciTry (GHCi m) = GHCi $ \s -> Exception.try (m s) -- ---------------------------------------------------------------------------- @@ -2174,7 +2186,7 @@ findBreakByCoord mb_file (line, col) arr do_bold :: Bool do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"] where mTerm = System.Environment.getEnv "TERM" - `Exception.catch` \_ -> return "TERM not set" + `catchIO` \_ -> return "TERM not set" start_bold :: String start_bold = "\ESC[1m" diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index f41a7ba..9fd39ef 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -1131,7 +1131,7 @@ mkSOName root -- name. They are searched for in different paths than normal libraries. loadFramework :: [FilePath] -> FilePath -> IO (Maybe String) loadFramework extraPaths rootname - = do { either_dir <- Exception.try getHomeDirectory + = do { either_dir <- tryIO getHomeDirectory ; let homeFrameworkPath = case either_dir of Left _ -> [] Right dir -> [dir ++ "/Library/Frameworks"] diff --git a/compiler/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs index 307e43f..481cd0c 100644 --- a/compiler/main/DriverMkDepend.hs +++ b/compiler/main/DriverMkDepend.hs @@ -31,6 +31,7 @@ import SrcLoc import Data.List import FastString +import Exception import ErrUtils ( debugTraceMsg, putMsg ) import System.Exit ( ExitCode(..), exitWith ) @@ -126,9 +127,9 @@ beginMkDependHS dflags = do then return () else chuck - catchJust ioErrors slurp + catchIO slurp (\e -> if isEOFError e then return () else ioError e) - catchJust ioErrors chuck + catchIO chuck (\e -> if isEOFError e then return () else ioError e) return (Just makefile_hdl) @@ -295,7 +296,7 @@ endMkDependHS dflags hPutStrLn tmp_hdl l slurp - catchJust ioErrors slurp + catchIO slurp (\e -> if isEOFError e then return () else ioError e) hClose hdl diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 6721b91..d6b5e0e 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -1120,7 +1120,7 @@ runPhase_MoveBinary dflags input_fn dep_packages pvm_executable_base = "=" ++ input_fn pvm_executable = pvm_root ++ "/bin/" ++ pvm_arch ++ "/" ++ pvm_executable_base -- nuke old binary; maybe use configur'ed names for cp and rm? - Panic.try (removeFile pvm_executable) + tryIO (removeFile pvm_executable) -- move the newly created binary into PVM land copy dflags "copying PVM executable" input_fn pvm_executable -- generate a wrapper script for running a parallel prg under PVM diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs index d6cb5d0..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,6 +82,27 @@ 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" diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 50261d8..ef8d98d 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -274,11 +274,14 @@ import qualified Data.List as List import Control.Monad import System.Exit ( exitWith, ExitCode(..) ) import System.Time ( ClockTime, getClockTime ) -import Exception hiding (handle) +import Exception import Data.IORef import System.FilePath import System.IO import System.IO.Error ( try, isDoesNotExistError ) +#if __GLASGOW_HASKELL__ >= 609 +import Data.Typeable (cast) +#endif import Prelude hiding (init) @@ -290,33 +293,55 @@ import Prelude hiding (init) -- the top level of your program. The default handlers output the error -- message(s) to stderr and exit cleanly. defaultErrorHandler :: DynFlags -> IO a -> IO a -defaultErrorHandler dflags inner = +defaultErrorHandler dflags inner = -- top-level exception handler: any unrecognised exception is a compiler bug. +#if __GLASGOW_HASKELL__ < 609 handle (\exception -> do - hFlush stdout - case exception of - -- an IO exception probably isn't our fault, so don't panic - IOException _ -> - fatalErrorMsg dflags (text (show exception)) - AsyncException StackOverflow -> - fatalErrorMsg dflags (text "stack overflow: use +RTS -K to increase it") - _other -> - fatalErrorMsg dflags (text (show (Panic (show exception)))) - exitWith (ExitFailure 1) + hFlush stdout + case exception of + -- an IO exception probably isn't our fault, so don't panic + IOException _ -> + fatalErrorMsg dflags (text (show exception)) + AsyncException StackOverflow -> + fatalErrorMsg dflags (text "stack overflow: use +RTS -K to increase it") + ExitException _ -> throw exception + _ -> + fatalErrorMsg dflags (text (show (Panic (show exception)))) + exitWith (ExitFailure 1) + ) $ +#else + handle (\(SomeException exception) -> do + hFlush stdout + case cast exception of + -- an IO exception probably isn't our fault, so don't panic + Just (ioe :: IOException) -> + fatalErrorMsg dflags (text (show ioe)) + _ -> case cast exception of + Just StackOverflow -> + fatalErrorMsg dflags (text "stack overflow: use +RTS -K to increase it") + _ -> case cast exception of + Just (ex :: ExitCode) -> throw ex + _ -> + fatalErrorMsg dflags + (text (show (Panic (show exception)))) + exitWith (ExitFailure 1) ) $ +#endif -- program errors: messages with locations attached. Sometimes it is -- convenient to just throw these as exceptions. - handleDyn (\dyn -> do printBagOfErrors dflags (unitBag dyn) - exitWith (ExitFailure 1)) $ + handleErrMsg + (\em -> do printBagOfErrors dflags (unitBag em) + exitWith (ExitFailure 1)) $ -- error messages propagated as exceptions - handleDyn (\dyn -> do + handleGhcException + (\ge -> do hFlush stdout - case dyn of + case ge of PhaseFailed _ code -> exitWith code Interrupted -> exitWith (ExitFailure 1) - _ -> do fatalErrorMsg dflags (text (show (dyn :: GhcException))) + _ -> do fatalErrorMsg dflags (text (show ge)) exitWith (ExitFailure 1) ) $ inner @@ -328,13 +353,13 @@ defaultErrorHandler dflags inner = defaultCleanupHandler :: DynFlags -> IO a -> IO a defaultCleanupHandler dflags inner = -- make sure we clean up after ourselves - later (do cleanTempFiles dflags + inner `onException` + (do cleanTempFiles dflags cleanTempDirs dflags ) -- exceptions will be blocked while we clean the temporary files, -- so there shouldn't be any difficulty if we receive further -- signals. - inner -- | Starts a new session. A session consists of a set of loaded @@ -465,7 +490,8 @@ guessTarget file Nothing if exists then return (Target (TargetFile lhs_file Nothing) Nothing) else do - throwDyn (ProgramError (showSDoc $ + throwGhcException + (ProgramError (showSDoc $ text "target" <+> quotes (text file) <+> text "is not a module name or a source file")) where @@ -1661,7 +1687,8 @@ downsweep :: HscEnv -- in which case there can be repeats downsweep hsc_env old_summaries excl_mods allow_dup_roots = -- catch error messages and return them - handleDyn (\err_msg -> printBagOfErrors (hsc_dflags hsc_env) (unitBag err_msg) >> return Nothing) $ do + handleErrMsg + (\err_msg -> printBagOfErrors (hsc_dflags hsc_env) (unitBag err_msg) >> return Nothing) $ do rootSummaries <- mapM getRootSummary roots let root_map = mkRootMap rootSummaries checkDuplicates root_map @@ -1678,7 +1705,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots = do exists <- doesFileExist file if exists then summariseFile hsc_env old_summaries file mb_phase maybe_buf - else throwDyn $ mkPlainErrMsg noSrcSpan $ + else throwErrMsg $ mkPlainErrMsg noSrcSpan $ text "can't find file:" <+> text file getRootSummary (Target (TargetModule modl) maybe_buf) = do maybe_summary <- summariseModule hsc_env old_summary_map False @@ -1928,7 +1955,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn when (mod_name /= wanted_mod) $ - throwDyn $ mkPlainErrMsg mod_loc $ + throwErrMsg $ mkPlainErrMsg mod_loc $ text "File name does not match module name:" $$ text "Saw:" <+> quotes (ppr mod_name) $$ text "Expected:" <+> quotes (ppr wanted_mod) @@ -1995,21 +2022,21 @@ preprocessFile hsc_env src_fn mb_phase (Just (buf, _time)) noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab -- ToDo: we don't have a proper line number for this error noModError dflags loc wanted_mod err - = throwDyn $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err + = throwErrMsg $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err noHsFileErr :: SrcSpan -> String -> a noHsFileErr loc path - = throwDyn $ mkPlainErrMsg loc $ text "Can't find" <+> text path + = throwErrMsg $ mkPlainErrMsg loc $ text "Can't find" <+> text path packageModErr :: ModuleName -> a packageModErr mod - = throwDyn $ mkPlainErrMsg noSrcSpan $ + = throwErrMsg $ mkPlainErrMsg noSrcSpan $ text "module" <+> quotes (ppr mod) <+> text "is a package module" multiRootsErr :: [ModSummary] -> IO () multiRootsErr [] = panic "multiRootsErr" multiRootsErr summs@(summ1:_) - = throwDyn $ mkPlainErrMsg noSrcSpan $ + = throwErrMsg $ mkPlainErrMsg noSrcSpan $ text "module" <+> quotes (ppr mod) <+> text "is defined in multiple files:" <+> sep (map text files) diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs index dc061ba..d0e30e0 100644 --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -70,7 +70,7 @@ getImports dflags buf filename source_filename = do return (source_imps, ordinary_imps, mod) parseError :: SrcSpan -> Message -> a -parseError span err = throwDyn $ mkPlainErrMsg span err +parseError span err = throwErrMsg $ mkPlainErrMsg span err isSourceIdecl :: ImportDecl name -> Bool isSourceIdecl (ImportDecl _ s _ _ _) = s diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index f15c5f4..4fc295b 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -90,13 +90,13 @@ import Foreign.StablePtr data RunResult = RunOk [Name] -- ^ names bound by this evaluation | RunFailed -- ^ statement failed compilation - | RunException Exception -- ^ statement raised an exception + | RunException SomeException -- ^ statement raised an exception | RunBreak ThreadId [Name] (Maybe BreakInfo) data Status = Break Bool HValue BreakInfo ThreadId -- ^ the computation hit a breakpoint (Bool <=> was an exception) - | Complete (Either Exception [HValue]) + | Complete (Either SomeException [HValue]) -- ^ the computation completed with either an exception or a value data Resume @@ -338,6 +338,7 @@ sandboxIO dflags statusMVar thing = -- not "Interrupted", we unset the exception flag before throwing. -- rethrow :: DynFlags -> IO a -> IO a +#if __GLASGOW_HASKELL__ < 609 rethrow dflags io = Exception.catch io $ \e -> do -- NB. not catchDyn case e of -- If -fbreak-on-error, we break unconditionally, @@ -355,7 +356,22 @@ rethrow dflags io = Exception.catch io $ \e -> do -- NB. not catchDyn _ -> poke exceptionFlag 0 Exception.throwIO e - +#else +rethrow dflags io = Exception.catch io $ \se@(SomeException e) -> do + -- If -fbreak-on-error, we break unconditionally, + -- but with care of not breaking twice + if dopt Opt_BreakOnError dflags && + not (dopt Opt_BreakOnException dflags) + then poke exceptionFlag 1 + else case cast e of + -- If it is an "Interrupted" exception, we allow + -- a possible break by way of -fbreak-on-exception + Just Interrupted -> return () + -- In any other case, we don't want to break + _ -> poke exceptionFlag 0 + + Exception.throwIO se +#endif withInterruptsSentTo :: ThreadId -> IO r -> IO r withInterruptsSentTo thread get_result = do diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index 1bafe6c..44ad7d1 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -55,6 +55,7 @@ import Distribution.Text import Distribution.Version import FastString import ErrUtils ( debugTraceMsg, putMsg, Message ) +import Exception import System.Directory import System.FilePath @@ -172,7 +173,7 @@ initPackages dflags = do readPackageConfigs :: DynFlags -> IO PackageConfigMap readPackageConfigs dflags = do - e_pkg_path <- try (getEnv "GHC_PACKAGE_PATH") + e_pkg_path <- tryIO (getEnv "GHC_PACKAGE_PATH") system_pkgconfs <- getSystemPackageConfigs dflags let pkgconfs = case e_pkg_path of @@ -215,7 +216,7 @@ getSystemPackageConfigs dflags = do -- unless the -no-user-package-conf flag was given. -- We only do this when getAppUserDataDirectory is available -- (GHC >= 6.3). - user_pkgconf <- handle (\_ -> return []) $ do + user_pkgconf <- do appdir <- getAppUserDataDirectory "ghc" let pkgconf = appdir @@ -225,6 +226,7 @@ getSystemPackageConfigs dflags = do if (flg && dopt Opt_ReadUserPackageConf dflags) then return [pkgconf] else return [] + `catchIO` (\_ -> return []) return (user_pkgconf ++ system_pkgconfs ++ [system_pkgconf]) diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index d1f2968..c861511 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -40,7 +40,8 @@ import StaticFlags import FastString import Panic import Util - +import Exception + import System.IO import Data.IORef import Control.Monad @@ -536,7 +537,11 @@ discardWarnings thing_inside \begin{code} +#if __GLASGOW_HASKELL__ < 609 try_m :: TcRn r -> TcRn (Either Exception r) +#else +try_m :: TcRn r -> TcRn (Either ErrorCall r) +#endif -- 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 f65dc29..d63b4a0 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -63,13 +63,17 @@ import Maybe import BasicTypes import Panic import FastString +import Data.Typeable (cast) +import Exception import qualified Language.Haskell.TH as TH -- THSyntax gives access to internal functions and data types import qualified Language.Haskell.TH.Syntax as TH import GHC.Exts ( unsafeCoerce#, Int#, Int(..) ) +#if __GLASGOW_HASKELL__ < 609 import qualified Exception ( userErrors ) +#endif \end{code} Note [Template Haskell levels] @@ -593,10 +597,18 @@ runMeta convert expr ; case either_tval of Right v -> return v +#if __GLASGOW_HASKELL__ < 609 Left exn | Just s <- Exception.userErrors exn , s == "IOEnv failure" -> failM -- Error already in Tc monad | otherwise -> failWithTc (mk_msg "run" exn) -- Exception +#else + Left (SomeException exn) -> do + case cast exn of + Just (ErrorCall "IOEnv failure") -> + failM -- Error already in Tc monad + _ -> failWithTc (mk_msg "run" exn) -- Exception +#endif }}} where mk_msg s exn = vcat [text "Exception when trying to" <+> text s <+> text "compile-time code:", diff --git a/compiler/utils/Exception.hs b/compiler/utils/Exception.hs index 11172b5..a316c56 100644 --- a/compiler/utils/Exception.hs +++ b/compiler/utils/Exception.hs @@ -1,19 +1,42 @@ module Exception ( + module Control.Exception, + module Exception + ) + where + +import Prelude hiding (catch) +import Control.Exception + +#if __GLASGOW_HASKELL__ < 609 +type SomeException = Exception + +onException :: IO a -> IO () -> IO a +onException io what = io `catch` \e -> do what + throw e +#endif + +catchIO :: IO a -> (IOException -> IO a) -> IO a #if __GLASGOW_HASKELL__ >= 609 - module Control.OldException +catchIO = catch #else - module Control.Exception +catchIO io handler = io `catch` handler' + where handler' (IOException ioe) = handler ioe + handler' e = throw e #endif - ) - where -import Prelude () +handleIO :: (IOException -> IO a) -> IO a -> IO a +handleIO = flip catchIO +tryIO :: IO a -> IO (Either IOException a) #if __GLASGOW_HASKELL__ >= 609 -import Control.OldException +tryIO = try #else -import Control.Exception +tryIO io = do ei <- try io + case ei of + Right v -> return (Right v) + Left (IOException ioe) -> return (Left ioe) + Left e -> throwIO e #endif diff --git a/compiler/utils/IOEnv.hs b/compiler/utils/IOEnv.hs index ca2bdfc..0cad752 100644 --- a/compiler/utils/IOEnv.hs +++ b/compiler/utils/IOEnv.hs @@ -23,7 +23,8 @@ module IOEnv ( IORef, newMutVar, readMutVar, writeMutVar, updMutVar ) where -import Panic ( try, tryUser, tryMost, Exception(..) ) +import Exception +import Panic import Data.IORef ( IORef, newIORef, readIORef, writeIORef, modifyIORef ) import System.IO.Unsafe ( unsafeInterleaveIO ) @@ -94,7 +95,11 @@ fixM f = IOEnv (\ env -> fixIO (\ r -> unIOEnv (f r) env)) --------------------------- +#if __GLASGOW_HASKELL__ < 609 tryM :: IOEnv env r -> IOEnv env (Either Exception r) +#else +tryM :: IOEnv env r -> IOEnv env (Either ErrorCall r) +#endif -- Reflect UserError exceptions (only) into IOEnv monad -- Other exceptions are not caught; they are simply propagated as exns -- @@ -104,13 +109,14 @@ tryM :: IOEnv env r -> IOEnv env (Either Exception r) -- begin compiled! tryM (IOEnv thing) = IOEnv (\ env -> tryUser (thing env)) -tryAllM :: IOEnv env r -> IOEnv env (Either Exception r) +-- XXX We shouldn't be catching everything, e.g. timeouts +tryAllM :: IOEnv env r -> IOEnv env (Either SomeException r) -- Catch *all* exceptions -- This is used when running a Template-Haskell splice, when -- even a pattern-match failure is a programmer error tryAllM (IOEnv thing) = IOEnv (\ env -> try (thing env)) -tryMostM :: IOEnv env r -> IOEnv env (Either Exception r) +tryMostM :: IOEnv env r -> IOEnv env (Either SomeException r) tryMostM (IOEnv thing) = IOEnv (\ env -> tryMost (thing env)) --------------------------- diff --git a/compiler/utils/Panic.lhs b/compiler/utils/Panic.lhs index 71c484e..f2e6312 100644 --- a/compiler/utils/Panic.lhs +++ b/compiler/utils/Panic.lhs @@ -11,13 +11,14 @@ some unnecessary loops in the module dependency graph. \begin{code} module Panic ( - GhcException(..), showGhcException, ghcError, progName, + GhcException(..), showGhcException, throwGhcException, handleGhcException, + ghcError, progName, pgmError, panic, panicFastInt, assertPanic, trace, Exception.Exception(..), showException, try, tryJust, tryMost, tryUser, - catchJust, ioErrors, throwTo, + catchJust, throwTo, installSignalHandlers, interruptTargetThread ) where @@ -40,7 +41,7 @@ import Control.Concurrent ( MVar, ThreadId, withMVar, newMVar ) import Data.Dynamic import Debug.Trace ( trace ) import System.IO.Unsafe ( unsafePerformIO ) -import System.IO.Error ( isUserError ) +import System.IO.Error hiding ( try ) import System.Exit import System.Environment \end{code} @@ -49,7 +50,11 @@ GHC's own exception type. \begin{code} ghcError :: GhcException -> a +#if __GLASGOW_HASKELL__ >= 609 +ghcError e = Exception.throw e +#else ghcError e = Exception.throwDyn e +#endif -- error messages all take the form -- @@ -71,18 +76,27 @@ data GhcException | ProgramError String -- error in the user's code, probably deriving Eq +#if __GLASGOW_HASKELL__ >= 609 +instance Exception GhcException +#endif + progName :: String progName = unsafePerformIO (getProgName) {-# NOINLINE progName #-} short_usage :: String short_usage = "Usage: For basic information, try the `--help' option." - + +#if __GLASGOW_HASKELL__ < 609 showException :: Exception.Exception -> String -- Show expected dynamic exceptions specially showException (Exception.DynException d) | Just e <- fromDynamic d = show (e::GhcException) showException other_exn = show other_exn +#else +showException :: Exception e => e -> String +showException = show +#endif instance Show GhcException where showsPrec _ e@(ProgramError _) = showGhcException e @@ -115,6 +129,20 @@ showGhcException (Panic s) ++ s ++ "\n\n" ++ "Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug\n") +throwGhcException :: GhcException -> a +#if __GLASGOW_HASKELL__ < 609 +throwGhcException = Exception.throwDyn +#else +throwGhcException = Exception.throw +#endif + +handleGhcException :: (GhcException -> IO a) -> IO a -> IO a +#if __GLASGOW_HASKELL__ < 609 +handleGhcException = flip Exception.catchDyn +#else +handleGhcException = Exception.handle +#endif + ghcExceptionTc :: TyCon ghcExceptionTc = mkTyCon "GhcException" {-# NOINLINE ghcExceptionTc #-} @@ -126,8 +154,8 @@ Panics and asserts. \begin{code} panic, pgmError :: String -> a -panic x = Exception.throwDyn (Panic x) -pgmError x = Exception.throwDyn (ProgramError x) +panic x = throwGhcException (Panic x) +pgmError x = throwGhcException (ProgramError x) -- #-versions because panic can't return an unboxed int, and that's -- what TAG_ is with GHC at the moment. Ugh. (Simon) @@ -147,6 +175,7 @@ assertPanic file line = -- exceptions. Used when we want soft failures when reading interface -- files, for example. +#if __GLASGOW_HASKELL__ < 609 tryMost :: IO a -> IO (Either Exception.Exception a) tryMost action = do r <- try action; filter r where @@ -158,15 +187,56 @@ tryMost action = do r <- try action; filter r _other -> return (Left e) filter other = return other +#else +-- XXX I'm not entirely sure if this is catching what we really want to catch +tryMost :: IO a -> IO (Either SomeException a) +tryMost action = do r <- try action + case r of + Left se@(SomeException e) -> + case cast e of + -- Some GhcException's we rethrow, + Just Interrupted -> throwIO se + Just (Panic _) -> throwIO se + -- others we return + Just _ -> return (Left se) + Nothing -> + case cast e of + -- All IOExceptions are returned + Just (_ :: IOException) -> + return (Left se) + -- Anything else is rethrown + Nothing -> throwIO se + Right v -> return (Right v) +#endif -- | 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 +#if __GLASGOW_HASKELL__ < 609 tryUser :: IO a -> IO (Either Exception.Exception a) tryUser action = tryJust tc_errors action where tc_errors e@(Exception.IOException ioe) | isUserError ioe = Just e tc_errors _other = Nothing +#else +tryUser :: IO a -> IO (Either ErrorCall a) +tryUser io = + do ei <- try io + case ei of + Right v -> return (Right v) + Left se@(SomeException ex) -> + case cast ex of + -- Look for good old fashioned ErrorCall's + Just errorCall -> return (Left errorCall) + Nothing -> + case cast ex of + -- And also for user errors in IO errors. + -- Sigh. + Just ioe + | isUserError ioe -> + return (Left (ErrorCall (ioeGetErrorString ioe))) + _ -> throw se +#endif \end{code} Standard signal handlers for catching ^C, which just throw an @@ -178,7 +248,11 @@ installSignalHandlers. installSignalHandlers :: IO () installSignalHandlers = do let +#if __GLASGOW_HASKELL__ < 609 interrupt_exn = Exception.DynException (toDyn Interrupted) +#else + interrupt_exn = (toException Interrupted) +#endif interrupt = do withMVar interruptTargetThread $ \targets -> diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs index fcb8bd9..5d84721 100644 --- a/compiler/utils/Util.lhs +++ b/compiler/utils/Util.lhs @@ -65,8 +65,6 @@ module Util ( doesDirNameExist, modificationTimeIfExists, - later, handleDyn, handle, - -- Filename utils Suffix, splitLongestPrefix, @@ -79,9 +77,6 @@ module Util ( import Panic -import Exception ( Exception(..), finally, catchDyn, throw ) -import qualified Exception -import Data.Dynamic ( Typeable ) import Data.IORef ( IORef, newIORef ) import System.IO.Unsafe ( unsafePerformIO ) import Data.IORef ( readIORef, writeIORef ) @@ -823,20 +818,6 @@ doesDirNameExist fpath = case takeDirectory fpath of "" -> return True -- XXX Hack _ -> doesDirectoryExist (takeDirectory fpath) --- ----------------------------------------------------------------------------- --- Exception utils - -later :: IO b -> IO a -> IO a -later = flip finally - -handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a -handleDyn = flip catchDyn - -handle :: (Exception -> IO a) -> IO a -> IO a -handle h f = f `Exception.catch` \e -> case e of - ExitException _ -> throw e - _ -> h e - -- -------------------------------------------------------------- -- check existence & modification time at the same time -- 1.7.10.4