Try strictifying catcheswip/strictify-catches

* Make `catchException` and `catchAny` lazy like they probably
should be.

* Manually strictify some things surrounding `catch` in the
libraries.

7 files changed, 17 insertions, 46 deletions

diff --git a/libraries/base/Control/Concurrent.hs b/libraries/base/Control/Concurrent.hs
index ada825d0f0..63cd96bfdd 100644
--- a/libraries/base/Control/Concurrent.hs
+++ b/libraries/base/Control/Concurrent.hs
@@ -109,7 +109,7 @@ import Control.Exception.Base as Exception
 
 import GHC.Conc hiding (threadWaitRead, threadWaitWrite,
                         threadWaitReadSTM, threadWaitWriteSTM)
-import GHC.IO           ( unsafeUnmask, catchException )
+import GHC.IO           ( unsafeUnmask, catch )
 import GHC.IORef        ( newIORef, readIORef, writeIORef )
 import GHC.Base
 
@@ -381,7 +381,7 @@ runInUnboundThread action = do
       mv <- newEmptyMVar
       mask $ \restore -> do
         tid <- forkIO $ Exception.try (restore action) >>= putMVar mv
-        let wait = takeMVar mv `catchException` \(e :: SomeException) ->
+        let wait = takeMVar mv `catch` \(e :: SomeException) ->
                      Exception.throwTo tid e >> wait
         wait >>= unsafeResult
     else action
diff --git a/libraries/base/GHC/Conc/Sync.hs b/libraries/base/GHC/Conc/Sync.hs
index a70e103952..9b6e7928c7 100644
--- a/libraries/base/GHC/Conc/Sync.hs
+++ b/libraries/base/GHC/Conc/Sync.hs
@@ -280,8 +280,6 @@ forkIO :: IO () -> IO ThreadId
 forkIO action = IO $ \ s ->
    case (fork# action_plus s) of (# s1, tid #) -> (# s1, ThreadId tid #)
  where
-  -- We must use 'catch' rather than 'catchException' because the action
-  -- could be bottom. #13330
   action_plus = catch action childHandler
 
 -- | Like 'forkIO', but the child thread is passed a function that can
@@ -330,8 +328,6 @@ forkOn :: Int -> IO () -> IO ThreadId
 forkOn (I# cpu) action = IO $ \ s ->
    case (forkOn# cpu action_plus s) of (# s1, tid #) -> (# s1, ThreadId tid #)
  where
-  -- We must use 'catch' rather than 'catchException' because the action
-  -- could be bottom. #13330
   action_plus = catch action childHandler
 
 -- | Like 'forkIOWithUnmask', but the child thread is pinned to the
@@ -401,10 +397,6 @@ foreign import ccall "&enabled_capabilities" enabled_capabilities :: Ptr CInt
 
 childHandler :: SomeException -> IO ()
 childHandler err = catch (real_handler err) childHandler
-  -- We must use catch here rather than catchException. If the
-  -- raised exception throws an (imprecise) exception, then real_handler err
-  -- will do so as well. If we use catchException here, then we could miss
-  -- that exception.
 
 real_handler :: SomeException -> IO ()
 real_handler se
diff --git a/libraries/base/GHC/IO.hs b/libraries/base/GHC/IO.hs
index 8459db6b75..bcbaad6205 100644
--- a/libraries/base/GHC/IO.hs
+++ b/libraries/base/GHC/IO.hs
@@ -128,12 +128,8 @@ have to work around that in the definition of catch below).
 -}
 
 -- | Catch an exception in the 'IO' monad.
---
--- Note that this function is /strict/ in the action. That is,
--- @catchException undefined b == _|_@. See #exceptions_and_strictness#
--- for details.
 catchException :: Exception e => IO a -> (e -> IO a) -> IO a
-catchException !io handler = catch io handler
+catchException io handler = catch io handler
 
 -- | This is the simplest of the exception-catching functions.  It
 -- takes a single argument, runs it, and if an exception is raised
@@ -180,19 +176,12 @@ catch (IO io) handler = IO $ catch# io handler'
 
 
 -- | Catch any 'Exception' type in the 'IO' monad.
---
--- Note that this function is /strict/ in the action. That is,
--- @catchAny undefined b == _|_@. See #exceptions_and_strictness# for
--- details.
 catchAny :: IO a -> (forall e . Exception e => e -> IO a) -> IO a
-catchAny !(IO io) handler = IO $ catch# io handler'
+catchAny (IO io) handler = IO $ catch# io handler'
     where handler' (SomeException e) = unIO (handler e)
 
--- Using catchException here means that if `m` throws an
--- 'IOError' /as an imprecise exception/, we will not catch
--- it. No one should really be doing that anyway.
 mplusIO :: IO a -> IO a -> IO a
-mplusIO m n = m `catchException` \ (_ :: IOError) -> n
+mplusIO m n = m `catch` \ (_ :: IOError) -> n
 
 -- | A variant of 'throw' that can only be used within the 'IO' monad.
 --
@@ -282,8 +271,8 @@ getMaskingState  = IO $ \s ->
                              _  -> MaskedInterruptible #)
 
 onException :: IO a -> IO b -> IO a
-onException io what = io `catchException` \e -> do _ <- what
-                                                   throwIO (e :: SomeException)
+onException io what = io `catch` \e -> do _ <- what
+                                          throwIO (e :: SomeException)
 
 -- | Executes an IO computation with asynchronous
 -- exceptions /masked/.  That is, any thread which attempts to raise
@@ -437,12 +426,4 @@ examples:
 > test2 = GHC.IO.catchException (error "uh oh") (\(_ :: SomeException) -> putStrLn "it failed")
 
 While @test1@ will print "it failed", @test2@ will print "uh oh".
-
-When using 'catchException', exceptions thrown while evaluating the
-action-to-be-executed will not be caught; only exceptions thrown during
-execution of the action will be handled by the exception handler.
-
-Since this strictness is a small optimization and may lead to surprising
-results, all of the @catch@ and @handle@ variants offered by "Control.Exception"
-use 'catch' rather than 'catchException'.
 -}
diff --git a/libraries/base/GHC/IO/Handle/FD.hs b/libraries/base/GHC/IO/Handle/FD.hs
index e988b25c9f..ee88b3d5f1 100644
--- a/libraries/base/GHC/IO/Handle/FD.hs
+++ b/libraries/base/GHC/IO/Handle/FD.hs
@@ -138,7 +138,7 @@ addFilePathToIOError fun fp ioe
 -- be using 'openBinaryFile'.
 openFile :: FilePath -> IOMode -> IO Handle
 openFile fp im = 
-  catchException
+  catch
     (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE True)
     (\e -> ioError (addFilePathToIOError "openFile" fp e))
 
@@ -150,7 +150,7 @@ openFile fp im =
 -- @since 4.4.0.0
 openFileBlocking :: FilePath -> IOMode -> IO Handle
 openFileBlocking fp im =
-  catchException
+  catch
     (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE False)
     (\e -> ioError (addFilePathToIOError "openFile" fp e))
 
@@ -165,7 +165,7 @@ openFileBlocking fp im =
 
 openBinaryFile :: FilePath -> IOMode -> IO Handle
 openBinaryFile fp m =
-  catchException
+  catch
     (openFile' fp m True True)
     (\e -> ioError (addFilePathToIOError "openBinaryFile" fp e))
 
diff --git a/libraries/base/GHC/IO/Handle/Internals.hs b/libraries/base/GHC/IO/Handle/Internals.hs
index 48ece1dc5e..3c1e1f881d 100644
--- a/libraries/base/GHC/IO/Handle/Internals.hs
+++ b/libraries/base/GHC/IO/Handle/Internals.hs
@@ -157,13 +157,12 @@ withHandle__' fun h m act =
    h'  <- do_operation fun h act m
    checkHandleInvariants h'
    putMVar m h'
-   return ()
 
 do_operation :: String -> Handle -> (Handle__ -> IO a) -> MVar Handle__ -> IO a
 do_operation fun h act m = do
   h_ <- takeMVar m
   checkHandleInvariants h_
-  act h_ `catchException` handler h_
+  act h_ `catch` handler h_
   where
     handler h_ e = do
       putMVar m h_
@@ -748,7 +747,7 @@ hClose_help handle_ =
 
 
 trymaybe :: IO () -> IO (Maybe SomeException)
-trymaybe io = (do io; return Nothing) `catchException` \e -> return (Just e)
+trymaybe io = (do io; return Nothing) `catch` \e -> return (Just e)
 
 hClose_handle_ :: Handle__ -> IO (Handle__, Maybe SomeException)
 hClose_handle_ h_@Handle__{..} = do
diff --git a/libraries/base/GHC/IO/Handle/Text.hs b/libraries/base/GHC/IO/Handle/Text.hs
index 8d927384c8..0b74ab5413 100644
--- a/libraries/base/GHC/IO/Handle/Text.hs
+++ b/libraries/base/GHC/IO/Handle/Text.hs
@@ -45,7 +45,6 @@ import qualified GHC.IO.Device as RawIO
 import Foreign
 import Foreign.C
 
-import qualified Control.Exception as Exception
 import Data.Typeable
 import System.IO.Error
 import Data.Maybe
@@ -245,8 +244,8 @@ hGetLineBufferedLoop handle_@Handle__{..}
                      hGetLineBufferedLoop handle_ new_buf (xs:xss)
 
 maybeFillReadBuffer :: Handle__ -> CharBuffer -> IO (Maybe CharBuffer)
-maybeFillReadBuffer handle_ buf
-  = catchException
+maybeFillReadBuffer handle_ !buf
+  = catch
      (do buf' <- getSomeCharacters handle_ buf
          return (Just buf')
      )
@@ -401,7 +400,7 @@ lazyRead handle =
 lazyReadBuffered :: Handle -> Handle__ -> IO (Handle__, [Char])
 lazyReadBuffered h handle_@Handle__{..} = do
    buf <- readIORef haCharBuffer
-   Exception.catch
+   catch
         (do
             buf'@Buffer{..} <- getSomeCharacters handle_ buf
             lazy_rest <- lazyRead h
diff --git a/libraries/base/GHC/TopHandler.hs b/libraries/base/GHC/TopHandler.hs
index f1c87e5110..eed94492d6 100644
--- a/libraries/base/GHC/TopHandler.hs
+++ b/libraries/base/GHC/TopHandler.hs
@@ -154,14 +154,14 @@ runIOFastExit main = catch main topHandlerFastExit
 -- are used to export Haskell functions with non-IO types.
 --
 runNonIO :: a -> IO a
-runNonIO a = catch (a `seq` return a) topHandler
+runNonIO a = catch (evaluate a) topHandler
 
 topHandler :: SomeException -> IO a
 topHandler err = catch (real_handler safeExit err) topHandler
 
 topHandlerFastExit :: SomeException -> IO a
 topHandlerFastExit err =
-  catchException (real_handler fastExit err) topHandlerFastExit
+  catch (real_handler fastExit err) topHandlerFastExit
 
 -- Make sure we handle errors while reporting the error!
 -- (e.g. evaluating the string passed to 'error' might generate