diff options
author | Artem Pelenitsyn <a.pelenitsyn@gmail.com> | 2020-04-25 20:12:23 +0200 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-05-04 13:19:59 -0400 |
commit | 30272412fa437ab8e7a8035db94a278e10513413 (patch) | |
tree | ff6f602e294dca766b42f8177928894d0f1ca90b /compiler | |
parent | 0bf640b19d7a7ad0800152752a71c1dd4e6c696d (diff) | |
download | haskell-30272412fa437ab8e7a8035db94a278e10513413.tar.gz |
Remove custom ExceptionMonad class (#18075) (updating haddock submodule accordingly)
Diffstat (limited to 'compiler')
-rw-r--r-- | compiler/GHC.hs | 10 | ||||
-rw-r--r-- | compiler/GHC/Data/IOEnv.hs | 20 | ||||
-rw-r--r-- | compiler/GHC/Driver/Make.hs | 17 | ||||
-rw-r--r-- | compiler/GHC/Driver/Monad.hs | 35 | ||||
-rw-r--r-- | compiler/GHC/Driver/Pipeline.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Driver/Types.hs | 5 | ||||
-rw-r--r-- | compiler/GHC/Iface/Recomp.hs | 6 | ||||
-rw-r--r-- | compiler/GHC/Runtime/Debugger.hs | 5 | ||||
-rw-r--r-- | compiler/GHC/Runtime/Eval.hs | 3 | ||||
-rw-r--r-- | compiler/GHC/Runtime/Interpreter.hs | 15 | ||||
-rw-r--r-- | compiler/GHC/Runtime/Linker.hs | 3 | ||||
-rw-r--r-- | compiler/GHC/SysTools/FileCleanup.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/SysTools/Tasks.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Utils/Error.hs | 3 | ||||
-rw-r--r-- | compiler/GHC/Utils/Exception.hs | 71 | ||||
-rw-r--r-- | compiler/GHC/Utils/Panic.hs | 7 | ||||
-rw-r--r-- | compiler/ghc.cabal.in | 1 |
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@, |