summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
authorArtem Pelenitsyn <a.pelenitsyn@gmail.com>2020-04-25 20:12:23 +0200
committerMarge Bot <ben+marge-bot@smart-cactus.org>2020-05-04 13:19:59 -0400
commit30272412fa437ab8e7a8035db94a278e10513413 (patch)
treeff6f602e294dca766b42f8177928894d0f1ca90b /compiler
parent0bf640b19d7a7ad0800152752a71c1dd4e6c696d (diff)
downloadhaskell-30272412fa437ab8e7a8035db94a278e10513413.tar.gz
Remove custom ExceptionMonad class (#18075) (updating haddock submodule accordingly)
Diffstat (limited to 'compiler')
-rw-r--r--compiler/GHC.hs10
-rw-r--r--compiler/GHC/Data/IOEnv.hs20
-rw-r--r--compiler/GHC/Driver/Make.hs17
-rw-r--r--compiler/GHC/Driver/Monad.hs35
-rw-r--r--compiler/GHC/Driver/Pipeline.hs4
-rw-r--r--compiler/GHC/Driver/Types.hs5
-rw-r--r--compiler/GHC/Iface/Recomp.hs6
-rw-r--r--compiler/GHC/Runtime/Debugger.hs5
-rw-r--r--compiler/GHC/Runtime/Eval.hs3
-rw-r--r--compiler/GHC/Runtime/Interpreter.hs15
-rw-r--r--compiler/GHC/Runtime/Linker.hs3
-rw-r--r--compiler/GHC/SysTools/FileCleanup.hs2
-rw-r--r--compiler/GHC/SysTools/Tasks.hs2
-rw-r--r--compiler/GHC/Utils/Error.hs3
-rw-r--r--compiler/GHC/Utils/Exception.hs71
-rw-r--r--compiler/GHC/Utils/Panic.hs7
-rw-r--r--compiler/ghc.cabal.in1
17 files changed, 71 insertions, 138 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs
index cd1227d418..19c5b59901 100644
--- a/compiler/GHC.hs
+++ b/compiler/GHC.hs
@@ -22,7 +22,6 @@ module GHC (
-- * GHC Monad
Ghc, GhcT, GhcMonad(..), HscEnv,
runGhc, runGhcT, initGhcMonad,
- gcatch, gbracket, gfinally,
printException,
handleSourceError,
needsTemplateHaskellOrQQ,
@@ -378,6 +377,7 @@ import Data.IORef
import System.FilePath
import Control.Concurrent
import Control.Applicative ((<|>))
+import Control.Monad.Catch as MC
import GHC.Data.Maybe
import System.IO.Error ( isDoesNotExistError )
@@ -400,7 +400,7 @@ defaultErrorHandler :: (ExceptionMonad m)
=> FatalMessager -> FlushOut -> m a -> m a
defaultErrorHandler fm (FlushOut flushOut) inner =
-- top-level exception handler: any unrecognised exception is a compiler bug.
- ghandle (\exception -> liftIO $ do
+ MC.handle (\exception -> liftIO $ do
flushOut
case fromException exception of
-- an IO exception probably isn't our fault, so don't panic
@@ -437,7 +437,7 @@ defaultErrorHandler fm (FlushOut flushOut) inner =
{-# DEPRECATED defaultCleanupHandler "Cleanup is now done by runGhc/runGhcT" #-}
defaultCleanupHandler :: (ExceptionMonad m) => DynFlags -> m a -> m a
defaultCleanupHandler _ m = m
- where _warning_suppression = m `gonException` undefined
+ where _warning_suppression = m `MC.onException` undefined
-- %************************************************************************
@@ -483,7 +483,7 @@ runGhcT mb_top_dir ghct = do
withCleanupSession ghct
withCleanupSession :: GhcMonad m => m a -> m a
-withCleanupSession ghc = ghc `gfinally` cleanup
+withCleanupSession ghc = ghc `MC.finally` cleanup
where
cleanup = do
hsc_env <- getSession
@@ -1698,7 +1698,7 @@ interpretPackageEnv dflags = do
getEnvVar :: MaybeT IO String
getEnvVar = do
- mvar <- liftMaybeT $ try $ getEnv "GHC_ENVIRONMENT"
+ mvar <- liftMaybeT $ MC.try $ getEnv "GHC_ENVIRONMENT"
case mvar of
Right var -> return var
Left err -> if isDoesNotExistError err then mzero
diff --git a/compiler/GHC/Data/IOEnv.hs b/compiler/GHC/Data/IOEnv.hs
index 86f16b229b..5478af0eee 100644
--- a/compiler/GHC/Data/IOEnv.hs
+++ b/compiler/GHC/Data/IOEnv.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DerivingVia #-}
--
-- (c) The University of Glasgow 2002-2006
--
@@ -43,6 +44,8 @@ import Data.IORef ( IORef, newIORef, readIORef, writeIORef, modifyIORef,
import System.IO.Unsafe ( unsafeInterleaveIO )
import System.IO ( fixIO )
import Control.Monad
+import Control.Monad.Trans.Reader
+import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)
import GHC.Utils.Monad
import Control.Applicative (Alternative(..))
@@ -51,7 +54,9 @@ import Control.Applicative (Alternative(..))
----------------------------------------------------------------------
-newtype IOEnv env a = IOEnv (env -> IO a) deriving (Functor)
+newtype IOEnv env a = IOEnv (env -> IO a)
+ deriving (Functor)
+ deriving (MonadThrow, MonadCatch, MonadMask, MonadIO) via (ReaderT env IO)
unIOEnv :: IOEnv env a -> (env -> IO a)
unIOEnv (IOEnv m) = m
@@ -91,16 +96,6 @@ instance Show IOEnvFailure where
instance Exception IOEnvFailure
-instance ExceptionMonad (IOEnv a) where
- gcatch act handle =
- IOEnv $ \s -> unIOEnv act s `gcatch` \e -> unIOEnv (handle e) s
- gmask f =
- IOEnv $ \s -> gmask $ \io_restore ->
- let
- g_restore (IOEnv m) = IOEnv $ \s -> io_restore (m s)
- in
- unIOEnv (f g_restore) s
-
instance ContainsDynFlags env => HasDynFlags (IOEnv env) where
getDynFlags = do env <- getEnv
return $! extractDynFlags env
@@ -176,9 +171,6 @@ instance MonadPlus (IOEnv env)
-- Accessing input/output
----------------------------------------------------------------------
-instance MonadIO (IOEnv env) where
- liftIO io = IOEnv (\ _ -> io)
-
newMutVar :: a -> IOEnv env (IORef a)
newMutVar val = liftIO (newIORef val)
diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index b76874eeab..43c988c4c2 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -53,7 +53,7 @@ import GHC.Driver.Main
import GHC.Data.Bag ( unitBag, listToBag, unionManyBags, isEmptyBag )
import GHC.Types.Basic
import GHC.Data.Graph.Directed
-import GHC.Utils.Exception ( tryIO, gbracket, gfinally )
+import GHC.Utils.Exception ( tryIO )
import GHC.Data.FastString
import GHC.Data.Maybe ( expectJust )
import GHC.Types.Name
@@ -85,6 +85,7 @@ import Control.Concurrent.QSem
import Control.Exception
import Control.Monad
import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE )
+import qualified Control.Monad.Catch as MC
import Data.IORef
import Data.List
import qualified Data.List as List
@@ -994,10 +995,10 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do
-- Reset the number of capabilities once the upsweep ends.
let resetNumCapabilities orig_n = liftIO $ setNumCapabilities orig_n
- gbracket updNumCapabilities resetNumCapabilities $ \_ -> do
+ MC.bracket updNumCapabilities resetNumCapabilities $ \_ -> do
-- Sync the global session with the latest HscEnv once the upsweep ends.
- let finallySyncSession io = io `gfinally` do
+ let finallySyncSession io = io `MC.finally` do
hsc_env <- liftIO $ readMVar hsc_env_var
setSession hsc_env
@@ -1061,7 +1062,7 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do
-- Unmask asynchronous exceptions and perform the thread-local
-- work to compile the module (see parUpsweep_one).
- m_res <- try $ unmask $ prettyPrintGhcErrors lcl_dflags $
+ m_res <- MC.try $ unmask $ prettyPrintGhcErrors lcl_dflags $
parUpsweep_one mod home_mod_map comp_graph_loops
lcl_dflags mHscMessage cleanup
par_sem hsc_env_var old_hpt_var
@@ -1097,12 +1098,12 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do
-- Kill all the workers, masking interrupts (since killThread is
-- interruptible). XXX: This is not ideal.
- ; killWorkers = uninterruptibleMask_ . mapM_ killThread }
+ ; killWorkers = MC.uninterruptibleMask_ . mapM_ killThread }
-- Spawn the workers, making sure to kill them later. Collect the results
-- of each compile.
- results <- liftIO $ bracket spawnWorkers killWorkers $ \_ ->
+ results <- liftIO $ MC.bracket spawnWorkers killWorkers $ \_ ->
-- Loop over each module in the compilation graph in order, printing
-- each message from its log_queue.
forM comp_graph $ \(mod,mvar,log_queue) -> do
@@ -1278,7 +1279,7 @@ parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags mHscMessage cleanup
let logger err = printBagOfErrors lcl_dflags (srcErrorMessages err)
-- Limit the number of parallel compiles.
- let withSem sem = bracket_ (waitQSem sem) (signalQSem sem)
+ let withSem sem = MC.bracket_ (waitQSem sem) (signalQSem sem)
mb_mod_info <- withSem par_sem $
handleSourceError (\err -> do logger err; return Nothing) $ do
-- Have the ModSummary and HscEnv point to our local log_action
@@ -2671,7 +2672,7 @@ withDeferredDiagnostics f = do
setLogAction action = modifySession $ \hsc_env ->
hsc_env{ hsc_dflags = (hsc_dflags hsc_env){ log_action = action } }
- gbracket
+ MC.bracket
(setLogAction deferDiagnostics)
(\_ -> setLogAction (log_action dflags) >> printDeferredDiagnostics)
(\_ -> f)
diff --git a/compiler/GHC/Driver/Monad.hs b/compiler/GHC/Driver/Monad.hs
index d0c950baf5..72dc3b9800 100644
--- a/compiler/GHC/Driver/Monad.hs
+++ b/compiler/GHC/Driver/Monad.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, DeriveFunctor, RankNTypes #-}
+{-# LANGUAGE CPP, DeriveFunctor, DerivingVia, RankNTypes #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}
-- -----------------------------------------------------------------------------
--
@@ -32,6 +32,8 @@ import GHC.Utils.Exception
import GHC.Utils.Error
import Control.Monad
+import Control.Monad.Catch as MC
+import Control.Monad.Trans.Reader
import Data.IORef
-- -----------------------------------------------------------------------------
@@ -50,7 +52,7 @@ import Data.IORef
-- If you do not use 'Ghc' or 'GhcT', make sure to call 'GHC.initGhcMonad'
-- before any call to the GHC API functions can occur.
--
-class (Functor m, MonadIO m, ExceptionMonad m, HasDynFlags m) => GhcMonad m where
+class (Functor m, ExceptionMonad m, HasDynFlags m) => GhcMonad m where
getSession :: m HscEnv
setSession :: HscEnv -> m ()
@@ -71,7 +73,7 @@ modifySession f = do h <- getSession
withSavedSession :: GhcMonad m => m a -> m a
withSavedSession m = do
saved_session <- getSession
- m `gfinally` setSession saved_session
+ m `MC.finally` setSession saved_session
-- | Call an action with a temporarily modified Session.
withTempSession :: GhcMonad m => (HscEnv -> HscEnv) -> m a -> m a
@@ -90,7 +92,9 @@ logWarnings warns = do
-- | A minimal implementation of a 'GhcMonad'. If you need a custom monad,
-- e.g., to maintain additional state consider wrapping this monad or using
-- 'GhcT'.
-newtype Ghc a = Ghc { unGhc :: Session -> IO a } deriving (Functor)
+newtype Ghc a = Ghc { unGhc :: Session -> IO a }
+ deriving (Functor)
+ deriving (MonadThrow, MonadCatch, MonadMask) via (ReaderT Session IO)
-- | The Session is a handle to the complete state of a compilation
-- session. A compilation session consists of a set of modules
@@ -111,16 +115,6 @@ instance MonadIO Ghc where
instance MonadFix Ghc where
mfix f = Ghc $ \s -> mfix (\x -> unGhc (f x) s)
-instance ExceptionMonad Ghc where
- gcatch act handle =
- Ghc $ \s -> unGhc act s `gcatch` \e -> unGhc (handle e) s
- gmask f =
- Ghc $ \s -> gmask $ \io_restore ->
- let
- g_restore (Ghc m) = Ghc $ \s -> io_restore (m s)
- in
- unGhc (f g_restore) s
-
instance HasDynFlags Ghc where
getDynFlags = getSessionDynFlags
@@ -155,7 +149,8 @@ reifyGhc act = Ghc $ act
--
-- Note that the wrapped monad must support IO and handling of exceptions.
newtype GhcT m a = GhcT { unGhcT :: Session -> m a }
- deriving (Functor)
+ deriving (Functor)
+ deriving (MonadThrow, MonadCatch, MonadMask) via (ReaderT Session m)
liftGhcT :: m a -> GhcT m a
liftGhcT m = GhcT $ \_ -> m
@@ -170,16 +165,6 @@ instance Monad m => Monad (GhcT m) where
instance MonadIO m => MonadIO (GhcT m) where
liftIO ioA = GhcT $ \_ -> liftIO ioA
-instance ExceptionMonad m => ExceptionMonad (GhcT m) where
- gcatch act handle =
- GhcT $ \s -> unGhcT act s `gcatch` \e -> unGhcT (handle e) s
- gmask f =
- GhcT $ \s -> gmask $ \io_restore ->
- let
- g_restore (GhcT m) = GhcT $ \s -> io_restore (m s)
- in
- unGhcT (f g_restore) s
-
instance MonadIO m => HasDynFlags (GhcT m) where
getDynFlags = GhcT $ \(Session r) -> liftM hsc_dflags (liftIO $ readIORef r)
diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index 5d9583fdb9..9732dd9e4d 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP, NamedFieldPuns, NondecreasingIndentation, BangPatterns, MultiWayIf #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
@@ -77,6 +78,7 @@ import System.Directory
import System.FilePath
import System.IO
import Control.Monad
+import qualified Control.Monad.Catch as MC (handle)
import Data.List ( isInfixOf, intercalate )
import Data.Maybe
import Data.Version
@@ -101,7 +103,7 @@ preprocess :: HscEnv
-> IO (Either ErrorMessages (DynFlags, FilePath))
preprocess hsc_env input_fn mb_input_buf mb_phase =
handleSourceError (\err -> return (Left (srcErrorMessages err))) $
- ghandle handler $
+ MC.handle handler $
fmap Right $ do
MASSERT2(isJust mb_phase || isHaskellSrcFilename input_fn, text input_fn)
(dflags, fp, mb_iface) <- runPipeline anyHsc hsc_env (input_fn, mb_input_buf, fmap RealPhase mb_phase)
diff --git a/compiler/GHC/Driver/Types.hs b/compiler/GHC/Driver/Types.hs
index 12424a48c5..c93dc7649f 100644
--- a/compiler/GHC/Driver/Types.hs
+++ b/compiler/GHC/Driver/Types.hs
@@ -231,6 +231,7 @@ import System.FilePath
import Control.DeepSeq
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Class
+import Control.Monad.Catch as MC (MonadCatch, catch)
-- -----------------------------------------------------------------------------
-- Compilation state
@@ -352,12 +353,12 @@ instance Exception SourceError
-- | Perform the given action and call the exception handler if the action
-- throws a 'SourceError'. See 'SourceError' for more information.
-handleSourceError :: (ExceptionMonad m) =>
+handleSourceError :: (MonadCatch m) =>
(SourceError -> m a) -- ^ exception handler
-> m a -- ^ action to perform
-> m a
handleSourceError handler act =
- gcatch act (\(e :: SourceError) -> handler e)
+ MC.catch act (\(e :: SourceError) -> handler e)
-- | An error thrown if the GHC API is used in an incorrect fashion.
newtype GhcApiError = GhcApiError String
diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs
index fea2fe666d..68103fc1f4 100644
--- a/compiler/GHC/Iface/Recomp.hs
+++ b/compiler/GHC/Iface/Recomp.hs
@@ -615,14 +615,14 @@ checkModUsage this_pkg UsageHomeModule{
checkModUsage _this_pkg UsageFile{ usg_file_path = file,
usg_file_hash = old_hash } =
liftIO $
- handleIO handle $ do
+ handleIO handler $ do
new_hash <- getFileHash file
if (old_hash /= new_hash)
then return recomp
else return UpToDate
where
- recomp = RecompBecause (file ++ " changed")
- handle =
+ recomp = RecompBecause (file ++ " changed")
+ handler =
#if defined(DEBUG)
\e -> pprTrace "UsageFile" (text (show e)) $ return recomp
#else
diff --git a/compiler/GHC/Runtime/Debugger.hs b/compiler/GHC/Runtime/Debugger.hs
index 7ea450067e..93869b35dd 100644
--- a/compiler/GHC/Runtime/Debugger.hs
+++ b/compiler/GHC/Runtime/Debugger.hs
@@ -40,6 +40,7 @@ import GHC.Driver.Session
import GHC.Utils.Exception
import Control.Monad
+import Control.Monad.Catch as MC
import Data.List ( (\\) )
import Data.Maybe
import Data.IORef
@@ -192,7 +193,7 @@ showTerm term = do
return $ Just $ cparen (prec >= myprec && needsParens txt)
(text txt)
else return Nothing
- `gfinally` do
+ `MC.finally` do
setSession hsc_env
GHC.setSessionDynFlags dflags
cPprShowable prec NewtypeWrap{ty=new_ty,wrapped_term=t} =
@@ -228,7 +229,7 @@ pprTypeAndContents id = do
let depthBound = 100
-- If the value is an exception, make sure we catch it and
-- show the exception, rather than propagating the exception out.
- e_term <- gtry $ GHC.obtainTermFromId depthBound False id
+ e_term <- MC.try $ GHC.obtainTermFromId depthBound False id
docs_term <- case e_term of
Right term -> showTerm term
Left exn -> return (text "*** Exception:" <+>
diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs
index edf8163a43..9656078736 100644
--- a/compiler/GHC/Runtime/Eval.hs
+++ b/compiler/GHC/Runtime/Eval.hs
@@ -108,6 +108,7 @@ import Data.Map (Map)
import qualified Data.Map as Map
import GHC.Data.StringBuffer (stringToStringBuffer)
import Control.Monad
+import Control.Monad.Catch as MC
import Data.Array
import GHC.Utils.Exception
import Unsafe.Coerce ( unsafeCoerce )
@@ -291,7 +292,7 @@ withVirtualCWD m = do
setSession hsc_env{ hsc_IC = old_IC{ ic_cwd = Just virt_dir } }
liftIO $ setCurrentDirectory orig_dir
- gbracket set_cwd reset_cwd $ \_ -> m
+ MC.bracket set_cwd reset_cwd $ \_ -> m
parseImportDecl :: GhcMonad m => String -> m (ImportDecl GhcPs)
parseImportDecl expr = withSession $ \hsc_env -> liftIO $ hscImport hsc_env expr
diff --git a/compiler/GHC/Runtime/Interpreter.hs b/compiler/GHC/Runtime/Interpreter.hs
index 1495c5c82e..b261a2b690 100644
--- a/compiler/GHC/Runtime/Interpreter.hs
+++ b/compiler/GHC/Runtime/Interpreter.hs
@@ -65,7 +65,7 @@ import GHC.Driver.Types
import GHC.Types.Unique.FM
import GHC.Utils.Panic
import GHC.Driver.Session
-import GHC.Utils.Exception
+import GHC.Utils.Exception as Ex
import GHC.Types.Basic
import GHC.Data.FastString
import GHC.Utils.Misc
@@ -85,6 +85,7 @@ import GHC.Driver.Ways
import Control.Concurrent
import Control.Monad
import Control.Monad.IO.Class
+import Control.Monad.Catch as MC (mask, onException)
import Data.Binary
import Data.Binary.Put
import Data.ByteString (ByteString)
@@ -211,17 +212,17 @@ hscInterp hsc_env = case hsc_interp hsc_env of
-- | Grab a lock on the 'IServ' and do something with it.
-- Overloaded because this is used from TcM as well as IO.
withIServ
- :: (MonadIO m, ExceptionMonad m)
+ :: (ExceptionMonad m)
=> IServConfig -> IServ -> (IServInstance -> m (IServInstance, a)) -> m a
withIServ conf (IServ mIServState) action = do
- gmask $ \restore -> do
+ MC.mask $ \restore -> do
state <- liftIO $ takeMVar mIServState
iserv <- case state of
-- start the external iserv process if we haven't done so yet
IServPending ->
liftIO (spawnIServ conf)
- `gonException` (liftIO $ putMVar mIServState state)
+ `MC.onException` (liftIO $ putMVar mIServState state)
IServRunning inst -> return inst
@@ -234,7 +235,7 @@ withIServ conf (IServ mIServState) action = do
iservCall iserv (FreeHValueRefs (iservPendingFrees iserv))
-- run the inner action
restore $ action iserv')
- `gonException` (liftIO $ putMVar mIServState (IServRunning iserv'))
+ `MC.onException` (liftIO $ putMVar mIServState (IServRunning iserv'))
liftIO $ putMVar mIServState (IServRunning iserv'')
return a
@@ -584,7 +585,7 @@ stopInterp hsc_env = case hsc_interp hsc_env of
Just InternalInterp -> pure ()
#endif
Just (ExternalInterp _ (IServ mstate)) ->
- gmask $ \_restore -> modifyMVar_ mstate $ \state -> do
+ MC.mask $ \_restore -> modifyMVar_ mstate $ \state -> do
case state of
IServPending -> pure state -- already stopped
IServRunning i -> do
@@ -614,7 +615,7 @@ runWithPipes createProc prog opts = do
wh <- mkHandle wfd2
return (ph, rh, wh)
where mkHandle :: CInt -> IO Handle
- mkHandle fd = (fdToHandle fd) `onException` (c__close fd)
+ mkHandle fd = (fdToHandle fd) `Ex.onException` (c__close fd)
#else
runWithPipes createProc prog opts = do
diff --git a/compiler/GHC/Runtime/Linker.hs b/compiler/GHC/Runtime/Linker.hs
index 2ac1fc12d2..9ae8270558 100644
--- a/compiler/GHC/Runtime/Linker.hs
+++ b/compiler/GHC/Runtime/Linker.hs
@@ -72,6 +72,7 @@ import Data.IORef
import Data.List (intercalate, isPrefixOf, isSuffixOf, nub, partition)
import Data.Maybe
import Control.Concurrent.MVar
+import qualified Control.Monad.Catch as MC
import System.FilePath
import System.Directory
@@ -216,7 +217,7 @@ linkDependencies hsc_env pls span needed_mods = do
withExtendedLinkEnv :: (ExceptionMonad m) =>
DynLinker -> [(Name,ForeignHValue)] -> m a -> m a
withExtendedLinkEnv dl new_env action
- = gbracket (liftIO $ extendLinkEnv dl new_env)
+ = MC.bracket (liftIO $ extendLinkEnv dl new_env)
(\_ -> reset_old_env)
(\_ -> action)
where
diff --git a/compiler/GHC/SysTools/FileCleanup.hs b/compiler/GHC/SysTools/FileCleanup.hs
index f72480d65f..b695a72a28 100644
--- a/compiler/GHC/SysTools/FileCleanup.hs
+++ b/compiler/GHC/SysTools/FileCleanup.hs
@@ -299,7 +299,7 @@ withTempDirectory targetDir template =
(ignoringIOErrors . removeDirectoryRecursive)
ignoringIOErrors :: IO () -> IO ()
-ignoringIOErrors ioe = ioe `catch` (\e -> const (return ()) (e :: IOError))
+ignoringIOErrors ioe = ioe `catchIO` const (return ())
createTempDirectory :: FilePath -> String -> IO FilePath
diff --git a/compiler/GHC/SysTools/Tasks.hs b/compiler/GHC/SysTools/Tasks.hs
index ee2f664571..be5549d577 100644
--- a/compiler/GHC/SysTools/Tasks.hs
+++ b/compiler/GHC/SysTools/Tasks.hs
@@ -186,7 +186,7 @@ runClang dflags args = traceToolCommand dflags "clang" $ do
args1 = map Option (getOpts dflags opt_a)
args2 = args0 ++ args1 ++ args
mb_env <- getGccEnv args2
- Exception.catch (do
+ catch (do
runSomethingFiltered dflags id "Clang (Assembler)" clang args2 Nothing mb_env
)
(\(err :: SomeException) -> do
diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs
index 96f1e11f3a..eb775aa4a3 100644
--- a/compiler/GHC/Utils/Error.hs
+++ b/compiler/GHC/Utils/Error.hs
@@ -89,6 +89,7 @@ import Data.Time
import Debug.Trace
import Control.Monad
import Control.Monad.IO.Class
+import Control.Monad.Catch as MC (handle)
import System.IO
import System.IO.Error ( catchIOError )
import GHC.Conc ( getAllocationCounter )
@@ -800,7 +801,7 @@ logOutput dflags msg
prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a
prettyPrintGhcErrors dflags
- = ghandle $ \e -> case e of
+ = MC.handle $ \e -> case e of
PprPanic str doc ->
pprDebugAndThen dflags panic (text str) doc
PprSorry str doc ->
diff --git a/compiler/GHC/Utils/Exception.hs b/compiler/GHC/Utils/Exception.hs
index e84221cdbe..49fa19bd47 100644
--- a/compiler/GHC/Utils/Exception.hs
+++ b/compiler/GHC/Utils/Exception.hs
@@ -1,4 +1,6 @@
{-# OPTIONS_GHC -fno-warn-deprecations #-}
+{-# LANGUAGE ConstraintKinds #-}
+
module GHC.Utils.Exception
(
module Control.Exception,
@@ -9,75 +11,18 @@ module GHC.Utils.Exception
import GHC.Prelude
import Control.Exception
+import Control.Exception as CE
import Control.Monad.IO.Class
+import Control.Monad.Catch
+-- Monomorphised versions of exception-handling utilities
catchIO :: IO a -> (IOException -> IO a) -> IO a
-catchIO = Control.Exception.catch
+catchIO = CE.catch
handleIO :: (IOException -> IO a) -> IO a -> IO a
handleIO = flip catchIO
tryIO :: IO a -> IO (Either IOException a)
-tryIO = try
-
--- | A monad that can catch exceptions. A minimal definition
--- requires a definition of 'gcatch'.
---
--- Implementations on top of 'IO' should implement 'gmask' to
--- eventually call the primitive 'Control.Exception.mask'.
--- These are used for
--- implementations that support asynchronous exceptions. The default
--- implementations of 'gbracket' and 'gfinally' use 'gmask'
--- thus rarely require overriding.
---
-class MonadIO m => ExceptionMonad m where
-
- -- | Generalised version of 'Control.Exception.catch', allowing an arbitrary
- -- exception handling monad instead of just 'IO'.
- gcatch :: Exception e => m a -> (e -> m a) -> m a
-
- -- | Generalised version of 'Control.Exception.mask_', allowing an arbitrary
- -- exception handling monad instead of just 'IO'.
- gmask :: ((m a -> m a) -> m b) -> m b
-
- -- | Generalised version of 'Control.Exception.bracket', allowing an arbitrary
- -- exception handling monad instead of just 'IO'.
- gbracket :: m a -> (a -> m b) -> (a -> m c) -> m c
-
- -- | Generalised version of 'Control.Exception.finally', allowing an arbitrary
- -- exception handling monad instead of just 'IO'.
- gfinally :: m a -> m b -> m a
-
- gbracket before after thing =
- gmask $ \restore -> do
- a <- before
- r <- restore (thing a) `gonException` after a
- _ <- after a
- return r
-
- a `gfinally` sequel =
- gmask $ \restore -> do
- r <- restore a `gonException` sequel
- _ <- sequel
- return r
-
-instance ExceptionMonad IO where
- gcatch = Control.Exception.catch
- gmask f = mask (\x -> f x)
-
-gtry :: (ExceptionMonad m, Exception e) => m a -> m (Either e a)
-gtry act = gcatch (act >>= \a -> return (Right a))
- (\e -> return (Left e))
-
--- | Generalised version of 'Control.Exception.handle', allowing an arbitrary
--- exception handling monad instead of just 'IO'.
-ghandle :: (ExceptionMonad m, Exception e) => (e -> m a) -> m a -> m a
-ghandle = flip gcatch
-
--- | Always executes the first argument. If this throws an exception the
--- second argument is executed and the exception is raised again.
-gonException :: (ExceptionMonad m) => m a -> m b -> m a
-gonException ioA cleanup = ioA `gcatch` \e ->
- do _ <- cleanup
- liftIO $ throwIO (e :: SomeException)
+tryIO = CE.try
+type ExceptionMonad m = (MonadCatch m, MonadThrow m, MonadMask m, MonadIO m)
diff --git a/compiler/GHC/Utils/Panic.hs b/compiler/GHC/Utils/Panic.hs
index 48695e25d4..9d960644b6 100644
--- a/compiler/GHC/Utils/Panic.hs
+++ b/compiler/GHC/Utils/Panic.hs
@@ -36,6 +36,7 @@ import GHC.Utils.Panic.Plain
import GHC.Utils.Exception as Exception
import Control.Monad.IO.Class
+import qualified Control.Monad.Catch as MC
import Control.Concurrent
import Data.Typeable ( cast )
import Debug.Trace ( trace )
@@ -155,7 +156,7 @@ throwGhcExceptionIO :: GhcException -> IO a
throwGhcExceptionIO = Exception.throwIO
handleGhcException :: ExceptionMonad m => (GhcException -> m a) -> m a -> m a
-handleGhcException = ghandle
+handleGhcException = MC.handle
panicDoc, sorryDoc, pgmErrorDoc :: String -> SDoc -> a
panicDoc x doc = throwGhcException (PprPanic x doc)
@@ -197,7 +198,7 @@ signalHandlersRefCount = unsafePerformIO $ newMVar (0,Nothing)
-- | Temporarily install standard signal handlers for catching ^C, which just
-- throw an exception in the current thread.
-withSignalHandlers :: (ExceptionMonad m, MonadIO m) => m a -> m a
+withSignalHandlers :: ExceptionMonad m => m a -> m a
withSignalHandlers act = do
main_thread <- liftIO myThreadId
wtid <- liftIO (mkWeakThreadId main_thread)
@@ -256,4 +257,4 @@ withSignalHandlers act = do
(c,oldHandlers) -> return (c-1,oldHandlers)
mayInstallHandlers
- act `gfinally` mayUninstallHandlers
+ act `MC.finally` mayUninstallHandlers
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index be85522ad4..166163f57b 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -72,6 +72,7 @@ Library
template-haskell == 2.17.*,
hpc == 0.6.*,
transformers == 0.5.*,
+ exceptions == 0.10.*,
ghc-boot == @ProjectVersionMunged@,
ghc-boot-th == @ProjectVersionMunged@,
ghc-heap == @ProjectVersionMunged@,