Skip to content
Snippets Groups Projects
Commit 921a1d5d authored by pcapriotti's avatar pcapriotti
Browse files

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

MERGED from commit e7e5e277
parent 961b2e55
No related branches found
No related tags found
No related merge requests found
...@@ -828,7 +828,7 @@ runMeta show_code run_and_convert expr ...@@ -828,7 +828,7 @@ runMeta show_code run_and_convert expr
; either_hval <- tryM $ liftIO $ ; either_hval <- tryM $ liftIO $
HscMain.hscCompileCoreExpr hsc_env src_span ds_expr HscMain.hscCompileCoreExpr hsc_env src_span ds_expr
; case either_hval of { ; 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 Right hval -> do
{ -- Coerce it to Q t, and run it { -- Coerce it to Q t, and run it
...@@ -856,12 +856,16 @@ runMeta show_code run_and_convert expr ...@@ -856,12 +856,16 @@ runMeta show_code run_and_convert expr
Right v -> return v Right v -> return v
Left se -> case fromException se of Left se -> case fromException se of
Just IOEnvFailure -> failM -- Error already in Tc monad Just IOEnvFailure -> failM -- Error already in Tc monad
_ -> failWithTc (mk_msg "run" se) -- Exception _ -> fail_with_exn "run" se -- Exception
}}} }}}
where where
mk_msg s exn = vcat [text "Exception when trying to" <+> text s <+> text "compile-time code:", -- see Note [Concealed TH exceptions]
nest 2 (text (Panic.showException exn)), fail_with_exn phase exn = do
if show_code then nest 2 (text "Code:" <+> ppr expr) else empty] 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} \end{code}
Note [Exceptions in TH] Note [Exceptions in TH]
...@@ -893,6 +897,21 @@ like that. Here's how it's processed: ...@@ -893,6 +897,21 @@ like that. Here's how it's processed:
- other errors, we add an error to the bag - other errors, we add an error to the bag
and then fail 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: To call runQ in the Tc monad, we need to make TcM an instance of Quasi:
......
...@@ -22,7 +22,7 @@ module Panic ( ...@@ -22,7 +22,7 @@ module Panic (
panic, sorry, panicFastInt, assertPanic, trace, panic, sorry, panicFastInt, assertPanic, trace,
Exception.Exception(..), showException, try, tryMost, throwTo, Exception.Exception(..), showException, safeShowException, try, tryMost, throwTo,
installSignalHandlers, interruptTargetThread installSignalHandlers, interruptTargetThread
) where ) where
...@@ -113,6 +113,18 @@ short_usage = "Usage: For basic information, try the `--help' option." ...@@ -113,6 +113,18 @@ short_usage = "Usage: For basic information, try the `--help' option."
showException :: Exception e => e -> String showException :: Exception e => e -> String
showException = show 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. -- | Append a description of the given exception to this string.
showGhcException :: GhcException -> String -> String showGhcException :: GhcException -> String -> String
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment