Introduce 2nd field in SomeExceptionWithLocation

10 files changed, 26 insertions, 14 deletions

diff --git a/compiler/GHC/Data/Maybe.hs b/compiler/GHC/Data/Maybe.hs
index 0962890ac5..3dad5013dc 100644
--- a/compiler/GHC/Data/Maybe.hs
+++ b/compiler/GHC/Data/Maybe.hs
@@ -96,7 +96,7 @@ liftMaybeT act = MaybeT $ Just `liftM` act
 tryMaybeT :: IO a -> MaybeT IO a
 tryMaybeT action = MaybeT $ catchException (Just `fmap` action) handler
   where
-    handler (SomeExceptionWithLocation _) = return Nothing
+    handler (SomeExceptionWithLocation _ _) = return Nothing
 
 {-
 ************************************************************************
diff --git a/compiler/GHC/Prelude.hs b/compiler/GHC/Prelude.hs
index 7067485ec4..46c5d3ee32 100644
--- a/compiler/GHC/Prelude.hs
+++ b/compiler/GHC/Prelude.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE CPP #-}
 {-# OPTIONS_HADDOCK not-home #-}
 {-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ViewPatterns #-}
 
 -- | Custom GHC "Prelude"
 --
@@ -103,6 +104,8 @@ shiftR = Bits.unsafeShiftR
 type SomeExceptionWithLocation = SomeException
 
 {-# COMPLETE SomeExceptionWithLocation #-}
-pattern SomeExceptionWithLocation :: () => forall e. Exception e => e -> SomeException
-pattern SomeExceptionWithLocation e = SomeException e
+pattern SomeExceptionWithLocation :: forall. forall a. Exception a => a -> () -> SomeException
+pattern SomeExceptionWithLocation e unit <- (\x -> ((), x) -> (unit, SomeException e))
+  where
+    SomeExceptionWithLocation e _ = SomeException e
 #endif
diff --git a/compiler/GHC/SysTools/Process.hs b/compiler/GHC/SysTools/Process.hs
index 2b67233b63..d697b92af7 100644
--- a/compiler/GHC/SysTools/Process.hs
+++ b/compiler/GHC/SysTools/Process.hs
@@ -281,7 +281,7 @@ builderMainLoop logger filter_fn pgm real_args mb_cwd mb_env = do
             inner hProcess
         case r of
           -- onException
-          Left (SomeExceptionWithLocation e) -> do
+          Left (SomeExceptionWithLocation e _) -> do
             terminateProcess hProcess
             cleanup_handles
             throw e
diff --git a/compiler/GHC/Utils/Panic.hs b/compiler/GHC/Utils/Panic.hs
index 13fccb22b2..673ee55d77 100644
--- a/compiler/GHC/Utils/Panic.hs
+++ b/compiler/GHC/Utils/Panic.hs
@@ -110,7 +110,7 @@ data GhcException
   | PprProgramError String SDoc
 
 instance Exception GhcException where
-  fromException (SomeExceptionWithLocation e)
+  fromException (SomeExceptionWithLocation e _)
     | Just ge <- cast e = Just ge
     | Just pge <- cast e = Just $
         case pge of
diff --git a/libraries/base/GHC/Conc/Sync.hs b/libraries/base/GHC/Conc/Sync.hs
index 1164ba6dde..d256b64129 100644
--- a/libraries/base/GHC/Conc/Sync.hs
+++ b/libraries/base/GHC/Conc/Sync.hs
@@ -906,7 +906,7 @@ uncaughtExceptionHandler :: IORef (SomeExceptionWithLocation -> IO ())
 uncaughtExceptionHandler = unsafePerformIO (newIORef defaultHandler)
    where
       defaultHandler :: SomeExceptionWithLocation -> IO ()
-      defaultHandler se@(SomeExceptionWithLocation ex) = do
+      defaultHandler se@(SomeExceptionWithLocation ex _) = do
          (hFlush stdout) `catchAny` (\ _ -> return ())
          let msg = case cast ex of
                Just Deadlock -> "no threads to run:  infinite loop or deadlock?"
diff --git a/libraries/base/GHC/Exception/Type.hs b/libraries/base/GHC/Exception/Type.hs
index 58844c3681..52a09a76f0 100644
--- a/libraries/base/GHC/Exception/Type.hs
+++ b/libraries/base/GHC/Exception/Type.hs
@@ -36,13 +36,14 @@ The @SomeExceptionWithLocation@ type is the root of the exception type hierarchy
 When an exception of type @e@ is thrown, behind the scenes it is
 encapsulated in a @SomeExceptionWithLocation@.
 -}
-data SomeExceptionWithLocation = forall e . Exception e => SomeExceptionWithLocation e
+data SomeExceptionWithLocation = forall e . Exception e => SomeExceptionWithLocation e [String]
 
 type SomeException = SomeExceptionWithLocation
 
 -- | @since 3.0
 instance Show SomeExceptionWithLocation where
-    showsPrec p (SomeExceptionWithLocation e) = showsPrec p e
+    -- TODO: Print backtraces
+    showsPrec p (SomeExceptionWithLocation e _) = showsPrec p e
 
 {- |
 Any type that you wish to throw or catch as an exception must be an
@@ -134,8 +135,8 @@ class (Typeable e, Show e) => Exception e where
     toException   :: e -> SomeExceptionWithLocation
     fromException :: SomeExceptionWithLocation -> Maybe e
 
-    toException = SomeExceptionWithLocation
-    fromException (SomeExceptionWithLocation e) = cast e
+    toException e = SomeExceptionWithLocation e []
+    fromException (SomeExceptionWithLocation e _) = cast e
 
     -- | Render this exception value in a human-friendly manner.
     --
@@ -149,7 +150,7 @@ class (Typeable e, Show e) => Exception e where
 instance Exception SomeExceptionWithLocation where
     toException se = se
     fromException = Just
-    displayException (SomeExceptionWithLocation e) = displayException e
+    displayException (SomeExceptionWithLocation e _) = displayException e
 
 -- |Arithmetic exceptions.
 data ArithException
diff --git a/libraries/base/GHC/IO.hs b/libraries/base/GHC/IO.hs
index 31b5b179da..be7f99b2cd 100644
--- a/libraries/base/GHC/IO.hs
+++ b/libraries/base/GHC/IO.hs
@@ -194,7 +194,7 @@ catch (IO io) handler = IO $ catch# io handler'
 -- details.
 catchAny :: IO a -> (forall e . Exception e => e -> IO a) -> IO a
 catchAny !(IO io) handler = IO $ catch# io handler'
-    where handler' (SomeExceptionWithLocation e) = unIO (handler e)
+    where handler' (SomeExceptionWithLocation e _) = unIO (handler e)
 
 -- Using catchException here means that if `m` throws an
 -- 'IOError' /as an imprecise exception/, we will not catch
diff --git a/testsuite/tests/concurrent/should_run/T3279.hs b/testsuite/tests/concurrent/should_run/T3279.hs
index a5ac0d7497..61fdf26530 100644
--- a/testsuite/tests/concurrent/should_run/T3279.hs
+++ b/testsuite/tests/concurrent/should_run/T3279.hs
@@ -7,14 +7,14 @@ import GHC.IO (unsafeUnmask)
 
 f :: Int
 f = (1 +) . unsafePerformIO $ do
-        throwIO (ErrorCall "foo") `catch` \(SomeExceptionWithLocation e) -> do
+        throwIO (ErrorCall "foo") `catch` \(SomeExceptionWithLocation e _) -> do
             myThreadId >>= flip throwTo e
             -- point X
             unsafeUnmask $ return 1
 
 main :: IO ()
 main = do
-    evaluate f `catch` \(SomeExceptionWithLocation e) -> return 0
+    evaluate f `catch` \(SomeExceptionWithLocation e _) -> return 0
     -- the evaluation of 'x' is now suspended at point X
     tid <- mask_ $ forkIO (evaluate f >> return ())
     killThread tid
diff --git a/testsuite/tests/ghci.debugger/scripts/break011.stdout b/testsuite/tests/ghci.debugger/scripts/break011.stdout
index 93e6a8e3ec..2b3cdfd338 100644
--- a/testsuite/tests/ghci.debugger/scripts/break011.stdout
+++ b/testsuite/tests/ghci.debugger/scripts/break011.stdout
@@ -23,12 +23,14 @@ _exception = SomeExceptionWithLocation
                   "foo"
                   "CallStack (from HasCallStack):
   error, called at Test7.hs:2:18 in main:Main")
+               []
 _result :: a = _
 _exception :: SomeExceptionWithLocation = SomeExceptionWithLocation
                                             (ErrorCallWithLocation
                                                "foo"
                                                "CallStack (from HasCallStack):
   error, called at Test7.hs:2:18 in main:Main")
+                                            []
 *** Exception: foo
 CallStack (from HasCallStack):
   error, called at Test7.hs:2:18 in main:Main
@@ -38,12 +40,14 @@ _exception :: e = SomeExceptionWithLocation
                        "foo"
                        "CallStack (from HasCallStack):
   error, called at Test7.hs:2:18 in main:Main")
+                    []
 Stopped in <exception thrown>, <unknown>
 _exception :: e = SomeExceptionWithLocation
                     (ErrorCallWithLocation
                        "foo"
                        "CallStack (from HasCallStack):
   error, called at Test7.hs:2:18 in main:Main")
+                    []
 *** Exception: foo
 CallStack (from HasCallStack):
   error, called at Test7.hs:2:18 in main:Main
diff --git a/testsuite/tests/ghci.debugger/scripts/break024.stdout b/testsuite/tests/ghci.debugger/scripts/break024.stdout
index 211b1cf348..8f949411fb 100644
--- a/testsuite/tests/ghci.debugger/scripts/break024.stdout
+++ b/testsuite/tests/ghci.debugger/scripts/break024.stdout
@@ -4,18 +4,22 @@ _exception :: e = _
 _exception = SomeExceptionWithLocation
                (GHC.IO.Exception.IOError
                   Nothing GHC.IO.Exception.UserError [] "error" Nothing Nothing)
+               []
 *** Exception: user error (error)
 Stopped in <exception thrown>, <unknown>
 _exception :: e = _
 _exception = SomeExceptionWithLocation
                (GHC.IO.Exception.IOError
                   Nothing GHC.IO.Exception.UserError [] "error" Nothing Nothing)
+               []
 Stopped in <exception thrown>, <unknown>
 _exception :: e = SomeExceptionWithLocation
                     (GHC.IO.Exception.IOError Nothing GHC.IO.Exception.UserError ....)
+                    []
 Stopped in <exception thrown>, <unknown>
 _exception :: e = _
 _exception = SomeExceptionWithLocation
                (GHC.IO.Exception.IOError
                   Nothing GHC.IO.Exception.UserError [] "error" Nothing Nothing)
+               []
 Left user error (error)