Zubin pushed to branch wip/annotation-fixes at Glasgow Haskell Compiler / GHC Commits: 34234229 by Zubin Duggal at 2026-10-28T11:17:05+05:30 base: Preserve exception context when rethrowing exceptions in hClose Fixes #27875. CLC proposal: https://github.com/haskell/core-libraries-committee/issues/447 - - - - - 0913d5be by Zubin Duggal at 2026-10-28T11:17:05+05:30 base: Preserve exception context when rethrowing exceptions in Windows openFile Fixes #27875. CLC proposal: https://github.com/haskell/core-libraries-committee/issues/447 - - - - - caba1270 by Zubin Duggal at 2026-10-28T11:17:05+05:30 base: Preserve exception context when rethrowing exceptions in executablePath Fixes #27875. CLC proposal: https://github.com/haskell/core-libraries-committee/issues/447 - - - - - 9 changed files: - + changelog.d/clc-447 - libraries/base/changelog.md - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Internals.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Windows.hs - libraries/ghc-internal/src/GHC/Internal/System/Environment/ExecutablePath.hsc - + testsuite/tests/exceptions/T27851d.hs - + testsuite/tests/exceptions/T27851d.stdout - + testsuite/tests/exceptions/T27851d.stdout-javascript-unknown-ghcjs - testsuite/tests/exceptions/all.T Changes: ===================================== changelog.d/clc-447 ===================================== @@ -0,0 +1,8 @@ +section: base +synopsis: Preserve exception context when rethrowing exceptions in ``hGetLine``, + ``hGetContents``, ``hGetContents'``, ``hClose``, ``executablePath``, and on + Windows in ``openFile``, ``openFileBlocking`` and ``openBinaryFile``. +issues: #27875 +mrs: !16747 +description: + See `CLC proposal 447 <https://github.com/haskell/core-libraries-committee/issues/447>`_. ===================================== libraries/base/changelog.md ===================================== @@ -14,6 +14,7 @@ * Add `Infinity`, `NegInfinity`, and `NaN` pattern synonyms to `Data.RealFloat` ([CLC proposal #394](https://github.com/haskell/core-libraries-committee/issues/394)) * Add strict variants to mutable types (IORef, Chan, MVar). ([CLC Proposal #341](https://github.com/haskell/core-libraries-committee/issues/341)) * Preserve exception context when rethrowing exceptions in `modifyIOError` and `mapException`. ([CLC proposal #446](https://github.com/haskell/core-libraries-committee/issues/446)) + * Preserve exception context when rethrowing exceptions in `hGetLine`, `hGetContents`, `hGetContents'`, `hClose`, `executablePath`, and on Windows in `openFile`, `openFileBlocking` and `openBinaryFile`. ([CLC proposal #447](https://github.com/haskell/core-libraries-committee/issues/447)) ## 4.23.0.0 *TBA* * Add `System.IO.hGetNewlineMode`. ([CLC proposal #370](https://github.com/haskell/core-libraries-committee/issues/370)) ===================================== libraries/ghc-internal/src/GHC/Internal/IO/Handle/Internals.hs ===================================== @@ -193,7 +193,7 @@ do_operation fun h act m = do throwTo t e do_operation fun h act m _otherwise -> - throwIO e + rethrowIO (ExceptionWithContext c e) -- Note [async] -- ~~~~~~~~~~~~ @@ -451,7 +451,7 @@ handleFinalizer fp m = do (handle_', mb_exc) <- hClose_help handle_ putMVar m handle_' case mb_exc of - Just exc -> throwIO exc + Just exc -> throwIO (NoBacktrace exc) Nothing -> return () {- @@ -885,8 +885,9 @@ hClose_maybethrow (Just e) h = hClose_rethrow e h hClose_rethrow :: SomeException -> Handle -> IO () hClose_rethrow e h = case fromException e of - Just ioe -> ioError (augmentIOError ioe "hClose" h) - Nothing -> throwIO e + Just ioe -> rethrowIO $ ExceptionWithContext (someExceptionContext e) $ + augmentIOError ioe "hClose" h + Nothing -> throwIO (NoBacktrace e) hClose' :: Handle -> MVar Handle__ -> IO (Maybe SomeException) hClose' h m = withHandle' "hClose" h m $ hClose_help ===================================== libraries/ghc-internal/src/GHC/Internal/IO/Handle/Windows.hs ===================================== @@ -28,6 +28,7 @@ import GHC.Internal.Base (String, fmap, otherwise, return, ($)) import qualified GHC.Internal.Base as Rebindable import qualified GHC.Internal.Data.Typeable.Internal as Rebindable import GHC.Internal.MVar +import GHC.Internal.Exception.Type (ExceptionWithContext(..)) import GHC.Internal.IO import GHC.Internal.IO.BufferedIO hiding (flushWriteBuffer) import GHC.Internal.IO.Encoding @@ -114,6 +115,11 @@ addFilePathToIOError :: String -> FilePath -> IOException -> IOException addFilePathToIOError fun fp ioe = ioe{ ioe_location = fun, ioe_filename = Just fp } +catchAndAnnotate :: FilePath -> String -> IO a -> IO a +catchAndAnnotate fp s a = + catchExceptionNoPropagate a $ \(ExceptionWithContext c e) -> + rethrowIO (ExceptionWithContext c (addFilePathToIOError s fp e)) + -- | Computation 'openFile' @file mode@ allocates and returns a new, open -- handle to manage the file @file@. It manages input if @mode@ -- is 'ReadMode', output if @mode@ is 'WriteMode' or 'AppendMode', @@ -142,9 +148,8 @@ addFilePathToIOError fun fp ioe -- be using 'openBinaryFile'. openFile :: FilePath -> IOMode -> IO Handle openFile fp im = - catchException - (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE True) - (\e -> ioError (addFilePathToIOError "openFile" fp e)) + catchAndAnnotate fp "openFile" $ + openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE True -- | Like 'openFile', but opens the file in ordinary blocking mode. -- This can be useful for opening a FIFO for writing: if we open in @@ -154,9 +159,8 @@ openFile fp im = -- @since base-4.4.0.0 openFileBlocking :: FilePath -> IOMode -> IO Handle openFileBlocking fp im = - catchException - (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE False) - (\e -> ioError (addFilePathToIOError "openFileBlocking" fp e)) + catchAndAnnotate fp "openFileBlocking" $ + openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE False -- | Like 'openFile', but open the file in binary mode. -- On Windows, reading a file in text mode (which is the default) @@ -169,9 +173,8 @@ openFileBlocking fp im = openBinaryFile :: FilePath -> IOMode -> IO Handle openBinaryFile fp m = - catchException - (openFile' fp m True True) - (\e -> ioError (addFilePathToIOError "openBinaryFile" fp e)) + catchAndAnnotate fp "openBinaryFile" $ + openFile' fp m True True openFile' :: String -> IOMode -> Bool -> Bool -> IO Handle openFile' filepath iomode binary non_blocking = do ===================================== libraries/ghc-internal/src/GHC/Internal/System/Environment/ExecutablePath.hsc ===================================== @@ -44,7 +44,7 @@ executablePath = Nothing import GHC.Internal.Maybe (Maybe(..)) import GHC.Internal.IO (FilePath) #if defined(darwin_HOST_OS) -import GHC.Internal.Control.Exception (catch, throw) +import GHC.Internal.Control.Exception (catchJust) import GHC.Internal.Err (errorWithoutStackTrace) import GHC.Internal.Real import GHC.Internal.Word @@ -66,7 +66,7 @@ import GHC.Internal.Foreign.Marshal.Array import GHC.Internal.Real import GHC.Internal.System.Posix.Internals #elif defined(solaris2_HOST_OS) -import GHC.Internal.Control.Exception (catch, throw) +import GHC.Internal.Control.Exception (catchJust) import GHC.Internal.Data.Functor import GHC.Internal.Foreign.C.Types import GHC.Internal.Foreign.C.Error @@ -75,7 +75,7 @@ import GHC.Internal.Foreign.Marshal.Array import GHC.Internal.System.IO.Error (isDoesNotExistError) import GHC.Internal.System.Posix.Internals #elif defined(freebsd_HOST_OS) || defined(netbsd_HOST_OS) -import GHC.Internal.Control.Exception (catch, throw) +import GHC.Internal.Control.Exception (catchJust) import GHC.Internal.Data.Functor import GHC.Internal.Foreign.C.Types import GHC.Internal.Foreign.C.Error @@ -203,10 +203,10 @@ realpath path = getExecutablePath = _NSGetExecutablePath >>= realpath -- realpath(3) fails with ENOENT file does not exist (e.g. was deleted) -executablePath = Just (fmap Just getExecutablePath `catch` f) +executablePath = Just (catchJust f (fmap Just getExecutablePath) (\_ -> pure Nothing)) where - f e | isDoesNotExistError e = pure Nothing - | otherwise = throw e + f e | isDoesNotExistError e = Just () + | otherwise = Nothing -------------------------------------------------------------------------------- -- Linux / Solaris / Hurd @@ -242,12 +242,12 @@ executablePath = Just (check <$> getExecutablePath) where # elif defined(solaris2_HOST_OS) getExecutablePath = readSymbolicLink "/proc/self/path/a.out" -executablePath = Just ((Just <$> getExecutablePath) `catch` f) +executablePath = Just (catchJust f (Just <$> getExecutablePath) (\_ -> pure Nothing)) where -- readlink(2) fails with ENOENT when the executable has been deleted, -- even though the symlink itself still exists according to readdir(3). - f e | isDoesNotExistError e = pure Nothing - | otherwise = throw e + f e | isDoesNotExistError e = Just () + | otherwise = Nothing #endif @@ -297,15 +297,15 @@ getExecutablePath = do ] # endif -executablePath = Just (fmap Just getExecutablePath `catch` f) +executablePath = Just (catchJust f (fmap Just getExecutablePath) (\_ -> pure Nothing)) where -- The sysctl fails with errno ENOENT when executable has been deleted; -- see https://gitlab.haskell.org/ghc/ghc/-/issues/12377#note_321346. - f e | isDoesNotExistError e = pure Nothing + f e | isDoesNotExistError e = Just () -- As far as I know, ENOENT is the only kind of failure that should be -- expected and handled. Re-throw other errors. - | otherwise = throw e + | otherwise = Nothing -------------------------------------------------------------------------------- ===================================== testsuite/tests/exceptions/T27851d.hs ===================================== @@ -0,0 +1,11 @@ +import Control.Exception +import System.IO + +main :: IO () +main = do + h <- openFile "/dev/full" WriteMode + hPutStr h "x" + r <- try (hClose h) + case r of + Left e -> putStrLn (displayExceptionWithInfo e) + Right () -> putStrLn "no exception" ===================================== testsuite/tests/exceptions/T27851d.stdout ===================================== @@ -0,0 +1,7 @@ +ghc-internal:GHC.Internal.IO.Exception.IOException: + +/dev/full: hClose: resource exhausted (No space left on device) + +HasCallStack backtrace: + ioError, called at libraries/ghc-internal/src/GHC/Internal/Foreign/C/Error.hs:293:5 in ghc-internal:GHC.Internal.Foreign.C.Error + ===================================== testsuite/tests/exceptions/T27851d.stdout-javascript-unknown-ghcjs ===================================== @@ -0,0 +1,7 @@ +ghc-internal:GHC.Internal.IO.Exception.IOException: + +/dev/full: hClose: resource exhausted (unknown error) + +HasCallStack backtrace: + ioError, called at libraries/ghc-internal/src/GHC/Internal/Foreign/C/Error.hs:293:5 in ghc-internal:GHC.Internal.Foreign.C.Error + ===================================== testsuite/tests/exceptions/all.T ===================================== @@ -4,3 +4,4 @@ test('T26759a', exit_code(1), compile_and_run, ['']) test('T27851', exit_code(1), compile_and_run, ['']) test('T27851b', exit_code(1), compile_and_run, ['']) test('T27851c', normal, compile_and_run, ['']) +test('T27851d', unless(opsys('linux'), skip), compile_and_run, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/91b2524a70c9ac10eaf3092e82231d6... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/91b2524a70c9ac10eaf3092e82231d6... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help