[commit: ghc] master: Make qReport force its error message before printing it (241c660)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/241c6601568969156403fde8089c97024b082de0/ghc

>---------------------------------------------------------------

commit 241c6601568969156403fde8089c97024b082de0
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Thu Apr 17 11:15:16 2014 +0100

    Make qReport force its error message before printing it
    
    Fixes Trac #8987.  See Note [Exceptions in TH]
    
    Thanks to Yuras Shumovich for doing this.


>---------------------------------------------------------------

241c6601568969156403fde8089c97024b082de0
 compiler/typecheck/TcSplice.lhs |   12 ++++++++++--
 testsuite/tests/th/T8987.hs     |    6 ++++++
 testsuite/tests/th/T8987.stderr |    5 +++++
 testsuite/tests/th/all.T        |    1 +
 4 files changed, 22 insertions(+), 2 deletions(-)

diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index 2f4687d..7fce241 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -845,6 +845,12 @@ like that.  Here's how it's processed:
     (qReport True s) by using addErr to add an error message to the bag of errors.
     The 'fail' in TcM raises an IOEnvFailure exception
 
+ * 'qReport' forces the message to ensure any exception hidden in unevaluated
+   thunk doesn't get into the bag of errors. Otherwise the following splice
+   will triger panic (Trac #8987):
+        $(fail undefined)
+   See also Note [Concealed TH exceptions]
+
   * So, when running a splice, we catch all exceptions; then for
         - an IOEnvFailure exception, we assume the error is already
                 in the error-bag (above)
@@ -875,8 +881,10 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
                   ; let i = getKey u
                   ; return (TH.mkNameU s i) }
 
-  qReport True msg  = addErr  (text msg)
-  qReport False msg = addWarn (text msg)
+  -- 'msg' is forced to ensure exceptions don't escape,
+  -- see Note [Exceptions in TH]
+  qReport True msg  = seqList msg $ addErr  (text msg)
+  qReport False msg = seqList msg $ addWarn (text msg)
 
   qLocation = do { m <- getModule
                  ; l <- getSrcSpanM
diff --git a/testsuite/tests/th/T8987.hs b/testsuite/tests/th/T8987.hs
new file mode 100644
index 0000000..d6f5781
--- /dev/null
+++ b/testsuite/tests/th/T8987.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module T8987 where
+import Language.Haskell.TH
+
+$(reportWarning ['1', undefined] >> return [])
\ No newline at end of file
diff --git a/testsuite/tests/th/T8987.stderr b/testsuite/tests/th/T8987.stderr
new file mode 100644
index 0000000..2b128bb
--- /dev/null
+++ b/testsuite/tests/th/T8987.stderr
@@ -0,0 +1,5 @@
+
+T8987.hs:1:1:
+    Exception when trying to run compile-time code:
+      Prelude.undefined
+    Code: (>>) reportWarning ['1', undefined] return []
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index ce723dd..22bb7cc 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -325,4 +325,5 @@ test('T8807', normal, compile, ['-v0'])
 test('T8884', normal, compile, ['-v0'])
 test('T8954', normal, compile, ['-v0'])
 test('T8932', normal, compile_fail, ['-v0'])
+test('T8987', normal, compile_fail, ['-v0'])