[commit: ghc] master: Keep top-level names in typed TH quotes alive (bb835c9)

[git at git.haskell.org]

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

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

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

commit bb835c96c3d962c2e08d23f6fb900665c89953b4
Author: Ryan Scott <ryan.gl.scott at gmail.com>
Date:   Wed Oct 24 07:02:59 2018 -0400

    Keep top-level names in typed TH quotes alive
    
    Summary:
    When renaming untyped TH quotes, some care is taken to
    ensure that uses of top-level names in quotes do not have their
    bindings discarded during desugaring. The same care was not applied
    to typed TH quotes, so this patch brings the two into sync.
    
    Test Plan: make test TEST=T15783
    
    Reviewers: bgamari, mpickering
    
    Reviewed By: mpickering
    
    Subscribers: mpickering, rwbarton, carter
    
    GHC Trac Issues: #15783
    
    Differential Revision: https://phabricator.haskell.org/D5248


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

bb835c96c3d962c2e08d23f6fb900665c89953b4
 compiler/typecheck/TcExpr.hs  | 21 ++++++++++++++-------
 testsuite/tests/th/T15783A.hs |  6 ++++++
 testsuite/tests/th/T15783B.hs |  6 ++++++
 testsuite/tests/th/all.T      |  2 ++
 4 files changed, 28 insertions(+), 7 deletions(-)

diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index bb9279e..17678a5 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -1998,14 +1998,13 @@ checkThLocalId id
         ; case mb_local_use of
              Just (top_lvl, bind_lvl, use_stage)
                 | thLevel use_stage > bind_lvl
-                , isNotTopLevel top_lvl
-                -> checkCrossStageLifting id use_stage
+                -> checkCrossStageLifting top_lvl id use_stage
              _  -> return ()   -- Not a locally-bound thing, or
                                -- no cross-stage link
     }
 
 --------------------------------------
-checkCrossStageLifting :: Id -> ThStage -> TcM ()
+checkCrossStageLifting :: TopLevelFlag -> Id -> ThStage -> TcM ()
 -- If we are inside typed brackets, and (use_lvl > bind_lvl)
 -- we must check whether there's a cross-stage lift to do
 -- Examples   \x -> [|| x ||]
@@ -2015,7 +2014,12 @@ checkCrossStageLifting :: Id -> ThStage -> TcM ()
 -- This is similar to checkCrossStageLifting in RnSplice, but
 -- this code is applied to *typed* brackets.
 
-checkCrossStageLifting id (Brack _ (TcPending ps_var lie_var))
+checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var))
+  | isTopLevel top_lvl
+  = when (isExternalName id_name) (keepAlive id_name)
+    -- See Note [Keeping things alive for Template Haskell] in RnSplice
+
+  | otherwise
   =     -- Nested identifiers, such as 'x' in
         -- E.g. \x -> [|| h x ||]
         -- We must behave as if the reference to x was
@@ -2040,17 +2044,20 @@ checkCrossStageLifting id (Brack _ (TcPending ps_var lie_var))
                   else
                      setConstraintVar lie_var   $
                           -- Put the 'lift' constraint into the right LIE
-                     newMethodFromName (OccurrenceOf (idName id))
+                     newMethodFromName (OccurrenceOf id_name)
                                        THNames.liftName id_ty
 
                    -- Update the pending splices
         ; ps <- readMutVar ps_var
-        ; let pending_splice = PendingTcSplice (idName id) (nlHsApp (noLoc lift) (nlHsVar id))
+        ; let pending_splice = PendingTcSplice id_name
+                                 (nlHsApp (noLoc lift) (nlHsVar id))
         ; writeMutVar ps_var (pending_splice : ps)
 
         ; return () }
+  where
+    id_name = idName id
 
-checkCrossStageLifting _ _ = return ()
+checkCrossStageLifting _ _ _ = return ()
 
 polySpliceErr :: Id -> SDoc
 polySpliceErr id
diff --git a/testsuite/tests/th/T15783A.hs b/testsuite/tests/th/T15783A.hs
new file mode 100644
index 0000000..591a975
--- /dev/null
+++ b/testsuite/tests/th/T15783A.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE TemplateHaskell #-}
+module T15783A where
+
+import T15783B
+
+main = $$f
diff --git a/testsuite/tests/th/T15783B.hs b/testsuite/tests/th/T15783B.hs
new file mode 100644
index 0000000..818f57d
--- /dev/null
+++ b/testsuite/tests/th/T15783B.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE TemplateHaskell #-}
+module T15783B(f) where
+
+d = 0
+
+f = [|| d ||]
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index df114b5..d10523c 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -439,3 +439,5 @@ test('TH_recursiveDo', normal, compile_and_run, ['-v0 -dsuppress-uniques'])
 test('T15481', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('TH_recover_warns', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('T15738', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
+test('T15783', normal, multimod_compile,
+    ['T15783A', '-v0 ' + config.ghc_th_way_flags])