Prevent nested TH exceptions from bubbling up to the top level (#5976)

2 files changed, 37 insertions, 6 deletions

diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index a345da507f..e535f24d59 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -831,7 +831,7 @@ runMeta show_code run_and_convert expr
         ; either_hval <- tryM $ liftIO $
                          HscMain.hscCompileCoreExpr hsc_env src_span ds_expr
         ; case either_hval of {
-            Left exn   -> failWithTc (mk_msg "compile and link" exn) ;
+            Left exn   -> fail_with_exn "compile and link" exn ;
             Right hval -> do
 
         {       -- Coerce it to Q t, and run it
@@ -859,12 +859,16 @@ runMeta show_code run_and_convert expr
             Right v -> return v
             Left se -> case fromException se of
                          Just IOEnvFailure -> failM -- Error already in Tc monad
-                         _ -> failWithTc (mk_msg "run" se)      -- Exception
+                         _ -> fail_with_exn "run" se -- Exception
         }}}
   where
-    mk_msg s exn = vcat [text "Exception when trying to" <+> text s <+> text "compile-time code:",
-                         nest 2 (text (Panic.showException exn)),
-                         if show_code then nest 2 (text "Code:" <+> ppr expr) else empty]
+    -- see Note [Concealed TH exceptions]
+    fail_with_exn phase exn = do
+        exn_msg <- liftIO $ Panic.safeShowException exn
+        let msg = vcat [text "Exception when trying to" <+> text phase <+> text "compile-time code:",
+                        nest 2 (text exn_msg),
+                        if show_code then nest 2 (text "Code:" <+> ppr expr) else empty]
+        failWithTc msg
 \end{code}
 
 Note [Exceptions in TH]
@@ -896,6 +900,21 @@ like that.  Here's how it's processed:
         - other errors, we add an error to the bag
     and then fail
 
+Note [Concealed TH exceptions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When displaying the error message contained in an exception originated from TH
+code, we need to make sure that the error message itself does not contain an
+exception.  For example, when executing the following splice:
+
+    $( error ("foo " ++ error "bar") )
+
+the message for the outer exception is a thunk which will throw the inner
+exception when evaluated.
+
+For this reason, we display the message of a TH exception using the
+'safeShowException' function, which recursively catches any exception thrown
+when showing an error message.
+
 
 To call runQ in the Tc monad, we need to make TcM an instance of Quasi:
 
diff --git a/compiler/utils/Panic.lhs b/compiler/utils/Panic.lhs
index cc3603baeb..0fb206ca77 100644
--- a/compiler/utils/Panic.lhs
+++ b/compiler/utils/Panic.lhs
@@ -22,7 +22,7 @@ module Panic (
 
      panic, sorry, panicFastInt, assertPanic, trace,
      
-     Exception.Exception(..), showException, try, tryMost, throwTo,
+     Exception.Exception(..), showException, safeShowException, try, tryMost, throwTo,
 
      installSignalHandlers, interruptTargetThread
 ) where
@@ -113,6 +113,18 @@ short_usage = "Usage: For basic information, try the `--help' option."
 showException :: Exception e => e -> String
 showException = show
 
+-- | Show an exception which can possibly throw other exceptions.
+-- Used when displaying exception thrown within TH code.
+safeShowException :: Exception e => e -> IO String
+safeShowException e = do
+    -- ensure the whole error message is evaluated inside try
+    r <- try (return $! forceList (showException e))
+    case r of
+        Right msg -> return msg
+        Left e' -> safeShowException (e' :: SomeException)
+    where
+        forceList [] = []
+        forceList xs@(x : xt) = x `seq` forceList xt `seq` xs
 
 -- | Append a description of the given exception to this string.
 showGhcException :: GhcException -> String -> String