[commit: ghc] wip/ghc-8.8-merges: Capture and simplify constraints arising from running typed splices (ac37ab7)

[git at git.haskell.org]

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

On branch  : wip/ghc-8.8-merges
Link       : http://ghc.haskell.org/trac/ghc/changeset/ac37ab795fbe7a07894ce1d6b0fe9863c0e29135/ghc

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

commit ac37ab795fbe7a07894ce1d6b0fe9863c0e29135
Author: Matthew Pickering <matthewtpickering at gmail.com>
Date:   Sun Feb 3 11:46:28 2019 +0000

    Capture and simplify constraints arising from running typed splices
    
    This fixes a regression caused by #15471 where splicing in a trivial
    program such as `[|| return () ||]` would fail as the dictionary for
    `return` would never get bound in the module containing the splice.
    
    Arguably this is symptomatic of a major problem affecting TTH where we
    serialise renamed asts and then retype check them. The reference to the
    dictionary should be fully determined at the quote site so that splicing
    doesn't have to solve any implicits at all. It's a coincidence this
    works due to coherence but see #15863 and #15865 for examples where
    things do go very wrong.
    
    Fixes #16195
    
    (cherry picked from commit a48753bdbc99cda36890e851950f5b79e1c3b2b2)


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

ac37ab795fbe7a07894ce1d6b0fe9863c0e29135
 compiler/typecheck/TcSplice.hs | 11 ++++++++---
 testsuite/tests/th/T16195.hs   | 15 +++++++++++++++
 testsuite/tests/th/T16195A.hs  | 13 +++++++++++++
 testsuite/tests/th/all.T       |  1 +
 4 files changed, 37 insertions(+), 3 deletions(-)

diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs
index 1bb844a..73a9e9e 100644
--- a/compiler/typecheck/TcSplice.hs
+++ b/compiler/typecheck/TcSplice.hs
@@ -525,9 +525,14 @@ runTopSplice (DelayedSplice lcl_env orig_expr res_ty q_expr)
         -- Rename and typecheck the spliced-in expression,
         -- making sure it has type res_ty
         -- These steps should never fail; this is a *typed* splice
-       ; addErrCtxt (spliceResultDoc zonked_q_expr) $ do
-         { (exp3, _fvs) <- rnLExpr expr2
-         ; unLoc <$> tcMonoExpr exp3 (mkCheckExpType zonked_ty)} }
+       ; (res, wcs) <-
+            captureConstraints $
+              addErrCtxt (spliceResultDoc zonked_q_expr) $ do
+                { (exp3, _fvs) <- rnLExpr expr2
+                ; tcMonoExpr exp3 (mkCheckExpType zonked_ty)}
+       ; ev <- simplifyTop wcs
+       ; return $ unLoc (mkHsDictLet (EvBinds ev) res)
+       }
 
 
 {-
diff --git a/testsuite/tests/th/T16195.hs b/testsuite/tests/th/T16195.hs
new file mode 100644
index 0000000..70e9365
--- /dev/null
+++ b/testsuite/tests/th/T16195.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE TemplateHaskell #-}
+module T16195 where
+
+import T16195A
+
+main2 :: IO ()
+main2 = return ()
+
+main :: IO ()
+main = $$foo
+
+main3 :: IO ()
+main3 = putStrLn ($$showC $$unitC)
+
+
diff --git a/testsuite/tests/th/T16195A.hs b/testsuite/tests/th/T16195A.hs
new file mode 100644
index 0000000..b79aff7
--- /dev/null
+++ b/testsuite/tests/th/T16195A.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE TemplateHaskell #-}
+module T16195A where
+
+import Language.Haskell.TH
+
+foo :: Q (TExp (IO ()))
+foo = [|| return () ||]
+
+showC :: Q (TExp (() -> String))
+showC = [|| show ||]
+
+unitC :: Q (TExp ())
+unitC = [|| () ||]
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index b93673c..4d95e20 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -469,3 +469,4 @@ test('T16133', normal, compile_fail, [''])
 test('T15471', normal, multimod_compile, ['T15471.hs', '-v0'])
 test('T16180', when(opsys('darwin'), expect_broken(16218)), compile_and_run, [''])
 test('T16183', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
+test('T16195', normal, multimod_compile, ['T16195.hs', '-v0'])