Commit bb835c96 authored by Ryan Scott's avatar Ryan Scott

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
parent 79c641de
......@@ -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
......
{-# LANGUAGE TemplateHaskell #-}
module T15783A where
import T15783B
main = $$f
{-# LANGUAGE TemplateHaskell #-}
module T15783B(f) where
d = 0
f = [|| d ||]
......@@ -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])
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment