Commit 30272412 authored by Artem Pelenitsyn's avatar Artem Pelenitsyn Committed by Marge Bot

Remove custom ExceptionMonad class (#18075) (updating haddock submodule accordingly)

parent 0bf640b1
Pipeline #18927 passed with stages
in 549 minutes and 50 seconds
......@@ -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
......
{-# 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)
......
......@@ -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)
......
{-# 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)
......
{-# 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)
......
......@@ -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
......
......@@ -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
......
......@@ -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:" <+>
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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 ->
......
{-# 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)
......@@ -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
......@@ -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@,
......
......@@ -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
~~~~~~~~~~~~~~~~
......
......@@ -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
......
......@@ -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