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

3 files changed, 26 insertions, 80 deletions

diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index a7246344e8..3a297be7b1 100644
--- a/ghc/GHCi/UI.hs
+++ b/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
diff --git a/ghc/GHCi/UI/Info.hs b/ghc/GHCi/UI/Info.hs
index 9751aceb8b..869a6b4a31 100644
--- a/ghc/GHCi/UI/Info.hs
+++ b/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
diff --git a/ghc/GHCi/UI/Monad.hs b/ghc/GHCi/UI/Monad.hs
index fe8b9380de..8174c47a8f 100644
--- a/ghc/GHCi/UI/Monad.hs
+++ b/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