[Git][ghc/ghc][wip/exception-context] 3 commits: hi

[Ben Gamari (@bgamari)]

Ben Gamari pushed to branch wip/exception-context at Glasgow Haskell Compiler / GHC


Commits:
63735007 by Ben Gamari at 2023-05-08T17:17:16-04:00
hi

- - - - -
ec0a50b7 by Ben Gamari at 2023-05-08T19:18:53-04:00
CausedBy

- - - - -
c0b8a4f0 by Ben Gamari at 2023-05-09T00:24:18-04:00
NoCatch

- - - - -


3 changed files:

- libraries/base/GHC/Exception/Context.hs
- libraries/base/GHC/Exception/Type.hs
- libraries/base/GHC/IO.hs


Changes:

=====================================
libraries/base/GHC/Exception/Context.hs
=====================================
@@ -64,7 +64,7 @@ addExceptionAnnotation x (ExceptionContext xs) = ExceptionContext (SomeException
 getExceptionAnnotations :: forall a. ExceptionAnnotation a => ExceptionContext -> [a]
 getExceptionAnnotations (ExceptionContext xs) =
     [ x
-    | SomeExceptionAnnotation (x :: b) <- xs 
+    | SomeExceptionAnnotation (x :: b) <- xs
     , Just HRefl <- return (typeRep @a `eqTypeRep` typeRep @b)
     ]
 


=====================================
libraries/base/GHC/Exception/Type.hs
=====================================
@@ -32,6 +32,8 @@ module GHC.Exception.Type
        , emptyExceptionContext
        , mergeExceptionContext
        , ExceptionWithContext(..)
+         -- * CausedBy annotations
+       , CausedBy(..)
          -- * Arithmetic exceptions
        , ArithException(..)
        , divZeroException, overflowException, ratioZeroDenomException
@@ -225,6 +227,15 @@ instance Exception a => Exception (ExceptionWithContext a) where
     backtraceDesired (ExceptionWithContext _ e) = backtraceDesired e
     displayException = displayException . toException
 
+-- | An 'ExceptionAnnotation' which wraps the exception which
+--
+-- @since 4.19.0.0
+newtype CausedBy = CausedBy SomeException
+
+instance ExceptionAnnotation CausedBy where
+    displayExceptionAnnotation (CausedBy e) =
+        "Caused by: " ++ displayException e
+
 -- |Arithmetic exceptions.
 data ArithException
   = Overflow


=====================================
libraries/base/GHC/IO.hs
=====================================
@@ -161,6 +161,10 @@ catchException !io handler = catch io handler
 -- to catch exceptions of any type, see the section \"Catching all
 -- exceptions\" (in "Control.Exception") for an explanation of the problems with doing so.
 --
+-- If the exception handler throws an exception during execution, the
+-- thrown exception will be annotated with a 'CausedBy'
+-- 'ExceptionAnnotation'.
+--
 -- For catching exceptions in pure (non-'IO') expressions, see the
 -- function 'evaluate'.
 --
@@ -184,11 +188,24 @@ catch   :: Exception e
         -> (e -> IO a)  -- ^ Handler to invoke if an exception is raised
         -> IO a
 -- See #exceptions_and_strictness#.
-catch (IO io) handler = IO $ catch# io handler'
+catch io handler = catchNoCause io (\e -> withCausedBy e (handler e))
+
+-- | Catch an exception without adding a 'CausedBy' 'ExceptionContext' to any
+-- exceptions thrown by the handler. See the documentation of 'catch' for a
+-- detailed description of the semantics of this function.
+--
+-- @since 4.19.0.0
+catchNoCause
+    :: Exception e
+    => IO a         -- ^ The computation to run
+    -> (e -> IO a)  -- ^ Handler to invoke if an exception is raised
+    -> IO a
+-- See #exceptions_and_strictness#.
+catchNoCause (IO io) handler = IO $ catch# io handler'
   where
     handler' e =
       case fromException e of
-        Just e' -> unIO (withAugmentedContext (exceptionContext e) (handler e'))
+        Just e' -> unIO (handler e')
         Nothing -> raiseIO# e
 
 -- | Catch any 'Exception' type in the 'IO' monad.
@@ -200,12 +217,10 @@ catchAny :: IO a -> (forall e . Exception e => e -> IO a) -> IO a
 catchAny !(IO io) handler = IO $ catch# io handler'
   where
     handler' se@(SomeException e) =
-        unIO (withAugmentedContext (exceptionContext se) (handler e))
+        unIO (withCausedBy se (handler e))
 
-withAugmentedContext :: ExceptionContext -> IO a -> IO a
-withAugmentedContext ctxt (IO io) = IO (catch# io handler)
-  where
-    handler se = raiseIO# (augmentExceptionContext ctxt se)
+withCausedBy :: SomeException -> IO a -> IO a
+withCausedBy cause = annotateIO (CausedBy cause)
 
 -- | Execute an 'IO' action, adding the given 'ExceptionContext'
 -- to any thrown synchronous exceptions.



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c39cf7827eb4f96ce27efa784440f19514abc919...c0b8a4f0294a420cf8e2bc9d1233ca2ae094022e

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c39cf7827eb4f96ce27efa784440f19514abc919...c0b8a4f0294a420cf8e2bc9d1233ca2ae094022e
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/20230509/bb0167be/attachment-0001.html>