[Git][ghc/ghc][master] Remove custom ExceptionMonad class (#18075) (updating haddock submodule accordingly)
Marge Bot
gitlab at gitlab.haskell.org
Mon May 4 17:20:13 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
30272412 by Artem Pelenitsyn at 2020-05-04T13:19:59-04:00
Remove custom ExceptionMonad class (#18075) (updating haddock submodule accordingly)
- - - - -
30 changed files:
- compiler/GHC.hs
- compiler/GHC/Data/IOEnv.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Monad.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Driver/Types.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Runtime/Debugger.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Runtime/Interpreter.hs
- compiler/GHC/Runtime/Linker.hs
- compiler/GHC/SysTools/FileCleanup.hs
- compiler/GHC/SysTools/Tasks.hs
- compiler/GHC/Utils/Error.hs
- compiler/GHC/Utils/Exception.hs
- compiler/GHC/Utils/Panic.hs
- compiler/ghc.cabal.in
- docs/users_guide/8.12.1-notes.rst
- ghc.mk
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Info.hs
- ghc/GHCi/UI/Monad.hs
- hadrian/src/Settings/Default.hs
- testsuite/tests/ghc-api/Makefile
- testsuite/tests/ghc-api/T8628.hs
- testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs
- testsuite/tests/ghc-api/downsweep/all.T
- testsuite/tests/ghc-api/target-contents/TargetContents.hs
- testsuite/tests/ghc-api/target-contents/all.T
- utils/haddock
Changes:
=====================================
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
=====================================
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)
=====================================
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)
=====================================
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)
=====================================
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)
=====================================
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
=====================================
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
=====================================
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:" <+>
=====================================
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
=====================================
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
=====================================
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
=====================================
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
=====================================
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
=====================================
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 ->
=====================================
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)
=====================================
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
=====================================
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@,
=====================================
docs/users_guide/8.12.1-notes.rst
=====================================
@@ -148,6 +148,14 @@ Arrow notation
``hsGroupTopLevelFixitySigs`` function, which collects all top-level fixity
signatures, including those for class methods defined inside classes.
+- The ``Exception`` module was boiled down acknowledging the existence of
+ the ``exceptions`` dependency. In particular, the ``ExceptionMonad``
+ class is not a proper class anymore, but a mere synonym for ``MonadThrow``,
+ ``MonadCatch``, ``MonadMask`` (all from ``exceptions``) and ``MonadIO``.
+ All of ``g*``-functions from the module (``gtry``, ``gcatch``, etc.) are
+ erased, and their ``exceptions``-alternatives are meant to be used in the
+ GHC code instead.
+
``base`` library
~~~~~~~~~~~~~~~~
=====================================
ghc.mk
=====================================
@@ -414,7 +414,7 @@ else # CLEANING
# programs such as GHC and ghc-pkg, that we do not assume the stage0
# compiler already has installed (or up-to-date enough).
# Note that these must be given in topological order.
-PACKAGES_STAGE0 = binary transformers mtl hpc ghc-boot-th ghc-boot template-haskell text parsec Cabal/Cabal ghc-heap ghci
+PACKAGES_STAGE0 = binary transformers mtl hpc ghc-boot-th ghc-boot template-haskell text parsec Cabal/Cabal ghc-heap exceptions ghci
ifeq "$(Windows_Host)" "NO"
PACKAGES_STAGE0 += terminfo
endif
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -80,7 +80,7 @@ import GHC.Data.FastString
import GHC.Runtime.Linker
import GHC.Data.Maybe ( orElse, expectJust )
import GHC.Types.Name.Set
-import GHC.Utils.Panic hiding ( showException )
+import GHC.Utils.Panic hiding ( showException, try )
import GHC.Utils.Misc
import qualified GHC.LanguageExtensions as LangExt
import GHC.Data.Bag (unitBag)
@@ -91,6 +91,7 @@ import System.Console.Haskeline as Haskeline
import Control.Applicative hiding (empty)
import Control.DeepSeq (deepseq)
import Control.Monad as Monad
+import Control.Monad.Catch as MC
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
@@ -112,7 +113,7 @@ import Data.Time.Format ( formatTime, defaultTimeLocale )
import Data.Version ( showVersion )
import Prelude hiding ((<>))
-import GHC.Utils.Exception as Exception hiding (catch)
+import GHC.Utils.Exception as Exception hiding (catch, mask, handle)
import Foreign hiding (void)
import GHC.Stack hiding (SrcLoc(..))
@@ -984,12 +985,9 @@ runCommands gCmd = runCommands' handler Nothing gCmd >> return ()
runCommands' :: (SomeException -> GHCi Bool) -- ^ Exception handler
-> Maybe (GHCi ()) -- ^ Source error handler
-> InputT GHCi (Maybe String)
- -> InputT GHCi (Maybe Bool)
- -- We want to return () here, but have to return (Maybe Bool)
- -- because gmask is not polymorphic enough: we want to use
- -- unmask at two different types.
-runCommands' eh sourceErrorHandler gCmd = gmask $ \unmask -> do
- b <- ghandle (\e -> case fromException e of
+ -> InputT GHCi ()
+runCommands' eh sourceErrorHandler gCmd = mask $ \unmask -> do
+ b <- handle (\e -> case fromException e of
Just UserInterrupt -> return $ Just False
_ -> case fromException e of
Just ghce ->
@@ -999,7 +997,7 @@ runCommands' eh sourceErrorHandler gCmd = gmask $ \unmask -> do
liftIO (Exception.throwIO e))
(unmask $ runOneCommand eh gCmd)
case b of
- Nothing -> return Nothing
+ Nothing -> return ()
Just success -> do
unless success $ maybe (return ()) lift sourceErrorHandler
unmask $ runCommands' eh sourceErrorHandler gCmd
@@ -1039,7 +1037,7 @@ runOneCommand eh gCmd = do
st <- getGHCiState
let p = prompt st
setGHCiState st{ prompt = prompt_cont st }
- mb_cmd <- collectCommand q "" `GHC.gfinally`
+ mb_cmd <- collectCommand q "" `MC.finally`
modifyGHCiState (\st' -> st' { prompt = p })
return mb_cmd
-- we can't use removeSpaces for the sublines here, so
@@ -1819,7 +1817,7 @@ instancesCmd s = do
-- '-fdefer-type-errors' again if it has not been set before.
wrapDeferTypeErrors :: GHC.GhcMonad m => m a -> m a
wrapDeferTypeErrors load =
- gbracket
+ MC.bracket
(do
-- Force originalFlags to avoid leaking the associated HscEnv
!originalFlags <- getDynFlags
@@ -1960,11 +1958,11 @@ doLoad retain_context howmuch = do
-- Enable buffering stdout and stderr as we're compiling. Keeping these
-- handles unbuffered will just slow the compilation down, especially when
-- compiling in parallel.
- gbracket (liftIO $ do hSetBuffering stdout LineBuffering
- hSetBuffering stderr LineBuffering)
- (\_ ->
- liftIO $ do hSetBuffering stdout NoBuffering
- hSetBuffering stderr NoBuffering) $ \_ -> do
+ MC.bracket (liftIO $ do hSetBuffering stdout LineBuffering
+ hSetBuffering stderr LineBuffering)
+ (\_ ->
+ liftIO $ do hSetBuffering stdout NoBuffering
+ hSetBuffering stderr NoBuffering) $ \_ -> do
ok <- trySuccess $ GHC.load howmuch
afterLoad ok retain_context
return ok
@@ -2048,7 +2046,7 @@ keepPackageImports = filterM is_pkg_import
is_pkg_import :: GHC.GhcMonad m => InteractiveImport -> m Bool
is_pkg_import (IIModule _) = return False
is_pkg_import (IIDecl d)
- = do e <- gtry $ GHC.findModule mod_name (fmap sl_fs $ ideclPkgQual d)
+ = do e <- MC.try $ GHC.findModule mod_name (fmap sl_fs $ ideclPkgQual d)
case e :: Either SomeException Module of
Left _ -> return False
Right m -> return (not (isHomeModule m))
@@ -2556,7 +2554,7 @@ restoreContextOnFailure :: GhciMonad m => m a -> m a
restoreContextOnFailure do_this = do
st <- getGHCiState
let rc = remembered_ctx st; tc = transient_ctx st
- do_this `gonException` (modifyGHCiState $ \st' ->
+ do_this `MC.onException` (modifyGHCiState $ \st' ->
st' { remembered_ctx = rc, transient_ctx = tc })
-- -----------------------------------------------------------------------------
@@ -4160,13 +4158,13 @@ showException se =
-- may never be delivered. Thanks to Marcin for pointing out the bug.
ghciHandle :: (HasDynFlags m, ExceptionMonad m) => (SomeException -> m a) -> m a -> m a
-ghciHandle h m = gmask $ \restore -> do
+ghciHandle h m = mask $ \restore -> do
-- Force dflags to avoid leaking the associated HscEnv
!dflags <- getDynFlags
- gcatch (restore (GHC.prettyPrintGhcErrors dflags m)) $ \e -> restore (h e)
+ catch (restore (GHC.prettyPrintGhcErrors dflags m)) $ \e -> restore (h e)
ghciTry :: ExceptionMonad m => m a -> m (Either SomeException a)
-ghciTry m = fmap Right m `gcatch` \e -> return $ Left e
+ghciTry m = fmap Right m `catch` \e -> return $ Left e
tryBool :: ExceptionMonad m => m a -> m Bool
tryBool m = do
=====================================
ghc/GHCi/UI/Info.hs
=====================================
@@ -18,6 +18,7 @@ module GHCi.UI.Info
import Control.Exception
import Control.Monad
+import Control.Monad.Catch as MC
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
@@ -270,7 +271,7 @@ collectInfo ms loaded = do
foldM (go df) ms invalidated
where
go df m name = do { info <- getModInfo name; return (M.insert name info m) }
- `gcatch`
+ `MC.catch`
(\(e :: SomeException) -> do
liftIO $ putStrLn
$ showSDocForUser df alwaysQualify
=====================================
ghc/GHCi/UI/Monad.hs
=====================================
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, FlexibleInstances, DeriveFunctor #-}
+{-# LANGUAGE CPP, FlexibleInstances, DeriveFunctor, DerivingVia #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-----------------------------------------------------------------------------
@@ -65,8 +65,9 @@ import Control.Monad
import Prelude hiding ((<>))
import System.Console.Haskeline (CompletionFunc, InputT)
-import Control.Monad.Catch
+import Control.Monad.Catch as MC
import Control.Monad.Trans.Class
+import Control.Monad.Trans.Reader
import Control.Monad.IO.Class
import Data.Map.Strict (Map)
import qualified Data.IntMap.Strict as IntMap
@@ -259,6 +260,7 @@ recordBreak brkLoc = do
newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a }
deriving (Functor)
+ deriving (MonadThrow, MonadCatch, MonadMask) via (ReaderT (IORef GHCiState) Ghc)
reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a
reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s
@@ -311,61 +313,6 @@ instance GhcMonad (InputT GHCi) where
setSession = lift . setSession
getSession = lift getSession
-instance ExceptionMonad GHCi where
- gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r)
- gmask f =
- GHCi $ \s -> gmask $ \io_restore ->
- let
- g_restore (GHCi m) = GHCi $ \s' -> io_restore (m s')
- in
- unGHCi (f g_restore) s
-
-instance MonadThrow Ghc where
- throwM = liftIO . throwM
-
-instance MonadCatch Ghc where
- catch = gcatch
-
-instance MonadMask Ghc where
- mask f = Ghc $ \s ->
- mask $ \io_restore ->
- let g_restore (Ghc m) = Ghc $ \s -> io_restore (m s)
- in unGhc (f g_restore) s
- uninterruptibleMask f = Ghc $ \s ->
- uninterruptibleMask $ \io_restore ->
- let g_restore (Ghc m) = Ghc $ \s -> io_restore (m s)
- in unGhc (f g_restore) s
- generalBracket acquire release use = Ghc $ \s ->
- generalBracket
- (unGhc acquire s)
- (\resource exitCase -> unGhc (release resource exitCase) s)
- (\resource -> unGhc (use resource) s)
-
-instance MonadThrow GHCi where
- throwM = liftIO . throwM
-
-instance MonadCatch GHCi where
- catch = gcatch
-
-instance MonadMask GHCi where
- mask f = GHCi $ \s ->
- mask $ \io_restore ->
- let g_restore (GHCi m) = GHCi $ \s -> io_restore (m s)
- in unGHCi (f g_restore) s
- uninterruptibleMask f = GHCi $ \s ->
- uninterruptibleMask $ \io_restore ->
- let g_restore (GHCi m) = GHCi $ \s -> io_restore (m s)
- in unGHCi (f g_restore) s
- generalBracket acquire release use = GHCi $ \s ->
- generalBracket
- (unGHCi acquire s)
- (\resource exitCase -> unGHCi (release resource exitCase) s)
- (\resource -> unGHCi (use resource) s)
-
-instance ExceptionMonad (InputT GHCi) where
- gcatch = catch
- gmask = mask
-
isOptionSet :: GhciMonad m => GHCiOption -> m Bool
isOptionSet opt
= do st <- getGHCiState
@@ -482,7 +429,7 @@ runWithStats
=> (a -> Maybe Integer) -> m a -> m (ActionStats, Either SomeException a)
runWithStats getAllocs action = do
t0 <- liftIO getCurrentTime
- result <- gtry action
+ result <- MC.try action
let allocs = either (const Nothing) getAllocs result
t1 <- liftIO getCurrentTime
let elapsedTime = realToFrac $ t1 `diffUTCTime` t0
=====================================
hadrian/src/Settings/Default.hs
=====================================
@@ -59,6 +59,7 @@ stage0Packages = do
, compareSizes
, compiler
, deriveConstants
+ , exceptions
, genapply
, genprimopcode
, ghc
=====================================
testsuite/tests/ghc-api/Makefile
=====================================
@@ -17,7 +17,7 @@ T8639_api:
T8628:
rm -f T8628.o T8628.hi
- '$(TEST_HC)' $(TEST_HC_OPTS) --make -v0 -package ghc T8628
+ '$(TEST_HC)' $(TEST_HC_OPTS) --make -v0 -package ghc -package exceptions T8628
./T8628 "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`"
T9015:
=====================================
testsuite/tests/ghc-api/T8628.hs
=====================================
@@ -12,6 +12,7 @@ import GHC.Data.Bag (filterBag,isEmptyBag)
import System.Directory (removeFile)
import System.Environment( getArgs )
import GHC.Builtin.Names
+import Control.Monad.Catch as MC
main :: IO()
main
@@ -25,7 +26,7 @@ main
, IIDecl (simpleImportDecl (mkModuleNameFS (fsLit "System.IO")))]
runDecls "data X = Y ()"
execStmt "print True" execOptions
- gtry $ execStmt "print (Y ())" execOptions :: GhcMonad m => m (Either SomeException ExecResult)
+ MC.try $ execStmt "print (Y ())" execOptions :: GhcMonad m => m (Either SomeException ExecResult)
runDecls "data X = Y () deriving Show"
_ <- dynCompileExpr "'x'"
execStmt "print (Y ())" execOptions
=====================================
testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs
=====================================
@@ -7,10 +7,11 @@ import GHC
import GHC.Driver.Make
import GHC.Driver.Session
import GHC.Utils.Outputable
-import GHC.Utils.Exception (ExceptionMonad, ghandle)
+import GHC.Utils.Exception (ExceptionMonad)
import GHC.Data.Bag
import Control.Monad
+import Control.Monad.Catch as MC (handle)
import Control.Monad.IO.Class (liftIO)
import Control.Exception
import Data.IORef
@@ -28,8 +29,8 @@ any_failed = unsafePerformIO $ newIORef False
it :: ExceptionMonad m => [Char] -> m Bool -> m ()
it msg act =
- ghandle (\(_ex :: AssertionFailed) -> dofail) $
- ghandle (\(_ex :: ExitCode) -> dofail) $ do
+ MC.handle (\(_ex :: AssertionFailed) -> dofail) $
+ MC.handle (\(_ex :: ExitCode) -> dofail) $ do
res <- act
case res of
False -> dofail
=====================================
testsuite/tests/ghc-api/downsweep/all.T
=====================================
@@ -3,7 +3,7 @@ test('PartialDownsweep',
, ignore_stderr
],
compile_and_run,
- ['-package ghc'])
+ ['-package ghc -package exceptions'])
test('OldModLocation',
[ extra_run_opts('"' + config.libdir + '"')
=====================================
testsuite/tests/ghc-api/target-contents/TargetContents.hs
=====================================
@@ -6,6 +6,7 @@ import GHC.Driver.Session
import GHC
import Control.Monad
+import Control.Monad.Catch as MC (try)
import Control.Monad.IO.Class (liftIO)
import Data.List (intercalate)
import Data.Maybe
@@ -105,7 +106,7 @@ go label targets mods = do
liftIO $ hPutStrLn stderr $ "== " ++ label
t <- liftIO getCurrentTime
setTargets =<< catMaybes <$> mapM (mkTarget t) mods
- ex <- gtry $ load LoadAllTargets
+ ex <- MC.try $ load LoadAllTargets
case ex of
Left ex -> liftIO $ hPutStrLn stderr $ show (ex :: SourceError)
Right _ -> return ()
=====================================
testsuite/tests/ghc-api/target-contents/all.T
=====================================
@@ -1,4 +1,4 @@
test('TargetContents',
[extra_run_opts('"' + config.libdir + '"')]
, compile_and_run,
- ['-package ghc'])
+ ['-package ghc -package exceptions'])
=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit a61dbdb0a7420e15e978bce6c09de1ce99290f44
+Subproject commit c60995fe05d9cc267e892448604b8b96a705ccc7
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/30272412fa437ab8e7a8035db94a278e10513413
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/30272412fa437ab8e7a8035db94a278e10513413
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200504/297dd4fe/attachment-0001.html>
More information about the ghc-commits
mailing list