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
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
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 "")
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
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
-- 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)"))
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
-- 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)
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)
-- ----------------------------------------------------------------------------
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"
-- 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"]
import Data.List
import FastString
+import Exception
import ErrUtils ( debugTraceMsg, putMsg )
import System.Exit ( ExitCode(..), exitWith )
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)
hPutStrLn tmp_hdl l
slurp
- catchJust ioErrors slurp
+ catchIO slurp
(\e -> if isEOFError e then return () else ioError e)
hClose hdl
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
Message, mkLocMessage, printError,
Severity(..),
- ErrMsg, WarnMsg,
+ ErrMsg, WarnMsg, throwErrMsg, handleErrMsg,
errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo,
Messages, errorsFound, emptyMessages,
mkErrMsg, mkWarnMsg, mkPlainErrMsg, mkLongErrMsg,
import Data.Dynamic
import Data.List
import System.IO
+import Exception
-- -----------------------------------------------------------------------------
-- Basic error messages: just render a message with a source location.
-- 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"
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)
-- 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<size> 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<size> 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<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)
- 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
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
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
-- 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
= 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
(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)
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)
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
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
-- 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,
_ -> 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
import Distribution.Version
import FastString
import ErrUtils ( debugTraceMsg, putMsg, Message )
+import Exception
import System.Directory
import System.FilePath
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
-- 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
if (flg && dopt Opt_ReadUserPackageConf dflags)
then return [pkgconf]
else return []
+ `catchIO` (\_ -> return [])
return (user_pkgconf ++ system_pkgconfs ++ [system_pkgconf])
import FastString
import Panic
import Util
-
+import Exception
+
import System.IO
import Data.IORef
import Control.Monad
\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 ;
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]
; 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
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 )
---------------------------
+#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
--
-- 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))
---------------------------
\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
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}
\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
--
| 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
++ 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 #-}
\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)
-- 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
_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
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 ->
doesDirNameExist,
modificationTimeIfExists,
- later, handleDyn, handle,
-
-- Filename utils
Suffix,
splitLongestPrefix,
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 )
"" -> 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
projects / ghc-hetmet.git / commitdiff