Commit 81466110 authored by Ian Lynagh's avatar Ian Lynagh

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.
parent e61fe59d
......@@ -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
......
......@@ -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"
......
......@@ -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"]
......
......@@ -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
......
......@@ -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
......
......@@ -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"
......
......@@ -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)
......@@ -292,6 +295,7 @@ import Prelude hiding (init)
defaultErrorHandler :: DynFlags -> IO a -> IO a
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
......@@ -300,23 +304,44 @@ defaultErrorHandler dflags inner =
fatalErrorMsg dflags (text (show exception))
AsyncException StackOverflow ->
fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
_other ->
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<size> 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)
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)
......
......@@ -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
......
......@@ -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
......
......@@ -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])
......
......@@ -40,6 +40,7 @@ import StaticFlags
import FastString
import Panic
import Util
import Exception
import System.IO
import Data.IORef
......@@ -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 ;
......
......@@ -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:",
......
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
......@@ -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))
---------------------------
......
......@@ -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