Commit 78814882 authored by Simon Peyton Jones's avatar Simon Peyton Jones

A raft of changes driven by Trac #8540

The root cause of #8450 is that the new Template Haskell story, with
the renamer doing more of the work of Template Haskell, wasn't dealing
correctly with the keepAlive problem.  Consider
    g = ..blah...
    f = [| g |]
Then f's RHS refers to g's name but not to g, so g was being discarded
as dead code.

Fixing this sucked me into a deep swamp of understanding how all the moving
parts of hte new Template Haskell fit together, leading to a large collection
of related changes and better documentation.  Specifically:

* Instead of putting the TH level of a binder in the LocalRdrEnv, there
  is now a separate field
      tcl_th_bndrs :: NameEnv (TopLevelFlag, ThLevel)
  in the TcLclEnv, which records for each binder
     a) whether it is syntactically a top-level binder or not
     b) its TH level
  This deals uniformly with top-level and non-top-level binders, which was
  previously dealt with via greviously-delicate meddling with Internal and
  External Names.  Much better.

* As a result I could remove the tct_level field of ATcId.

* There are consequential changes in TcEnv too, which must also extend the
  level bindings.  Again, more clarity.

  I renamed TcEnv.tcExtendTcTyThingEnv to tcExtendKindEnv2, since it's only used
  during kind inference, for (AThing kind) and APromotionErr; and that is
  relevant to whether we want to extend the tcl_th_bndrs field (no).

* I de-crufted the code in RnEnv.extendGlobalRdrEnv, by getting rid of the
  qual_gre code which said "Seems like 5 times as much work as it deserves!".
  Instead, RdrName.pickGREs makes the Internal names shadow External ones.

* I moved the checkThLocalName cross-stage test to finishHsVar; previously
  we weren't doing the test at all in the OpApp case!

* Quite a few changes (shortening the code) in the cross-stage checking code
  in TcExpr and RnSplice, notably to move the keepAlive call to the renamer

One leftover piece:

* In TcEnv I removed tcExtendGhciEnv and refactored
  tcExtendGlobalTyVars; this is really related to the next commit, but
  it was too hard to disentangle.
parent 3e5905b4
......@@ -39,7 +39,7 @@ module RdrName (
-- * Local mapping of 'RdrName' to 'Name.Name'
LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, extendLocalRdrEnvList,
lookupLocalRdrEnv, lookupLocalRdrThLvl, lookupLocalRdrOcc,
lookupLocalRdrEnv, lookupLocalRdrOcc,
elemLocalRdrEnv, inLocalRdrEnvScope,
localRdrEnvElts, delLocalRdrEnvList,
......@@ -329,51 +329,47 @@ instance Ord RdrName where
-- It is keyed by OccName, because we never use it for qualified names
-- We keep the current mapping, *and* the set of all Names in scope
-- Reason: see Note [Splicing Exact Names] in RnEnv
type ThLevel = Int
type LocalRdrEnv = (OccEnv Name, OccEnv ThLevel, NameSet)
type LocalRdrEnv = (OccEnv Name, NameSet)
emptyLocalRdrEnv :: LocalRdrEnv
emptyLocalRdrEnv = (emptyOccEnv, emptyOccEnv, emptyNameSet)
emptyLocalRdrEnv = (emptyOccEnv, emptyNameSet)
extendLocalRdrEnv :: LocalRdrEnv -> ThLevel -> Name -> LocalRdrEnv
extendLocalRdrEnv (env, thenv, ns) thlvl name
= ( extendOccEnv env (nameOccName name) name
, extendOccEnv thenv (nameOccName name) thlvl
extendLocalRdrEnv :: LocalRdrEnv -> Name -> LocalRdrEnv
-- The Name should be a non-top-level thing
extendLocalRdrEnv (env, ns) name
= WARN( isExternalName name, ppr name )
( extendOccEnv env (nameOccName name) name
, addOneToNameSet ns name
)
extendLocalRdrEnvList :: LocalRdrEnv -> ThLevel -> [Name] -> LocalRdrEnv
extendLocalRdrEnvList (env, thenv, ns) thlvl names
= ( extendOccEnvList env [(nameOccName n, n) | n <- names]
, extendOccEnvList thenv [(nameOccName n, thlvl) | n <- names]
extendLocalRdrEnvList :: LocalRdrEnv -> [Name] -> LocalRdrEnv
extendLocalRdrEnvList (env, ns) names
= WARN( any isExternalName names, ppr names )
( extendOccEnvList env [(nameOccName n, n) | n <- names]
, addListToNameSet ns names
)
lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name
lookupLocalRdrEnv (env, _, _) (Unqual occ) = lookupOccEnv env occ
lookupLocalRdrEnv _ _ = Nothing
lookupLocalRdrThLvl :: LocalRdrEnv -> RdrName -> Maybe ThLevel
lookupLocalRdrThLvl (_, thenv, _) (Unqual occ) = lookupOccEnv thenv occ
lookupLocalRdrThLvl _ _ = Nothing
lookupLocalRdrEnv (env, _) (Unqual occ) = lookupOccEnv env occ
lookupLocalRdrEnv _ _ = Nothing
lookupLocalRdrOcc :: LocalRdrEnv -> OccName -> Maybe Name
lookupLocalRdrOcc (env, _, _) occ = lookupOccEnv env occ
lookupLocalRdrOcc (env, _) occ = lookupOccEnv env occ
elemLocalRdrEnv :: RdrName -> LocalRdrEnv -> Bool
elemLocalRdrEnv rdr_name (env, _, _)
elemLocalRdrEnv rdr_name (env, _)
| isUnqual rdr_name = rdrNameOcc rdr_name `elemOccEnv` env
| otherwise = False
localRdrEnvElts :: LocalRdrEnv -> [Name]
localRdrEnvElts (env, _, _) = occEnvElts env
localRdrEnvElts (env, _) = occEnvElts env
inLocalRdrEnvScope :: Name -> LocalRdrEnv -> Bool
-- This is the point of the NameSet
inLocalRdrEnvScope name (_, _, ns) = name `elemNameSet` ns
inLocalRdrEnvScope name (_, ns) = name `elemNameSet` ns
delLocalRdrEnvList :: LocalRdrEnv -> [OccName] -> LocalRdrEnv
delLocalRdrEnvList (env, thenv, ns) occs = (delListFromOccEnv env occs, delListFromOccEnv thenv occs, ns)
delLocalRdrEnvList (env, ns) occs = (delListFromOccEnv env occs, ns)
\end{code}
%************************************************************************
......@@ -544,9 +540,20 @@ pickGREs :: RdrName -> [GlobalRdrElt] -> [GlobalRdrElt]
-- the locally-defined @f@, and a GRE for the imported @f@, with a /single/
-- provenance, namely the one for @Baz(f)@.
pickGREs rdr_name gres
| (_ : _ : _) <- candidates -- This is usually false, so we don't have to
-- even look at internal_candidates
, (gre : _) <- internal_candidates
= [gre] -- For this internal_candidate stuff,
-- see Note [Template Haskell binders in the GlobalRdrEnv]
-- If there are multiple Internal candidates, pick the
-- first one (ie with the (innermost binding)
| otherwise
= ASSERT2( isSrcRdrName rdr_name, ppr rdr_name )
mapCatMaybes pick gres
candidates
where
candidates = mapCatMaybes pick gres
internal_candidates = filter (isInternalName . gre_name) candidates
rdr_is_unqual = isUnqual rdr_name
rdr_is_qual = isQual_maybe rdr_name
......@@ -594,7 +601,7 @@ mkGlobalRdrEnv gres
(nameOccName (gre_name gre))
gre
findLocalDupsRdrEnv :: GlobalRdrEnv -> [OccName] -> [[Name]]
findLocalDupsRdrEnv :: GlobalRdrEnv -> [Name] -> [[GlobalRdrElt]]
-- ^ For each 'OccName', see if there are multiple local definitions
-- for it; return a list of all such
-- and return a list of the duplicate bindings
......@@ -602,18 +609,25 @@ findLocalDupsRdrEnv rdr_env occs
= go rdr_env [] occs
where
go _ dups [] = dups
go rdr_env dups (occ:occs)
= case filter isLocalGRE gres of
[] -> go rdr_env dups occs
[_] -> go rdr_env dups occs -- The common case
dup_gres -> go rdr_env' (map gre_name dup_gres : dups) occs
go rdr_env dups (name:names)
= case filter (pick name) gres of
[] -> go rdr_env dups names
[_] -> go rdr_env dups names -- The common case
dup_gres -> go rdr_env' (dup_gres : dups) names
where
gres = lookupOccEnv rdr_env occ `orElse` []
occ = nameOccName name
gres = lookupOccEnv rdr_env occ `orElse` []
rdr_env' = delFromOccEnv rdr_env occ
-- The delFromOccEnv avoids repeating the same
-- complaint twice, when occs itself has a duplicate
-- complaint twice, when names itself has a duplicate
-- which is a common case
-- See Note [Template Haskell binders in the GlobalRdrEnv]
pick name (GRE { gre_name = n, gre_prov = LocalDef })
| isInternalName name = isInternalName n
| otherwise = True
pick _ _ = False
insertGRE :: GlobalRdrElt -> [GlobalRdrElt] -> [GlobalRdrElt]
insertGRE new_g [] = [new_g]
insertGRE new_g (old_g : old_gs)
......@@ -642,6 +656,13 @@ transformGREs trans_gre occs rdr_env
Nothing -> env
\end{code}
Note [Template Haskell binders in the GlobalRdrEnv]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For reasons described in Note [Top-level Names in Template Haskell decl quotes]
in RnNames, a GRE with an Internal gre_name (i.e. one generated by a TH decl
quote) should *shadow* a GRE with an External gre_name. Hence some faffing
around in pickGREs and findLocalDupsRdrEnv
%************************************************************************
%* *
Provenance
......
......@@ -26,7 +26,7 @@ module RnEnv (
getLookupOccRn, addUsedRdrNames,
newLocalBndrRn, newLocalBndrsRn,
bindLocalName, bindLocalNames, bindLocalNamesFV,
bindLocalNames, bindLocalNamesFV,
MiniFixityEnv,
addLocalFixities,
bindLocatedLocalsFV, bindLocatedLocalsRn,
......@@ -37,7 +37,7 @@ module RnEnv (
addFvRn, mapFvRn, mapMaybeFvRn, mapFvRnCPS,
warnUnusedMatches,
warnUnusedTopBinds, warnUnusedLocalBinds,
dataTcOccs, unknownNameErr, kindSigErr, perhapsForallMsg,
dataTcOccs, kindSigErr, perhapsForallMsg,
HsDocContext(..), docOfHsDocContext,
-- FsEnv
......@@ -69,6 +69,7 @@ import SrcLoc
import Outputable
import Util
import Maybes
import BasicTypes ( TopLevelFlag(..) )
import ListSetOps ( removeDups )
import DynFlags
import FastString
......@@ -551,18 +552,18 @@ lookupLocalOccRn_maybe rdr_name
= do { local_env <- getLocalRdrEnv
; return (lookupLocalRdrEnv local_env rdr_name) }
lookupLocalOccThLvl_maybe :: RdrName -> RnM (Maybe ThLevel)
lookupLocalOccThLvl_maybe :: Name -> RnM (Maybe (TopLevelFlag, ThLevel))
-- Just look in the local environment
lookupLocalOccThLvl_maybe rdr_name
= do { local_env <- getLocalRdrEnv
; return (lookupLocalRdrThLvl local_env rdr_name) }
lookupLocalOccThLvl_maybe name
= do { lcl_env <- getLclEnv
; return (lookupNameEnv (tcl_th_bndrs lcl_env) name) }
-- lookupOccRn looks up an occurrence of a RdrName
lookupOccRn :: RdrName -> RnM Name
lookupOccRn rdr_name
lookupOccRn rdr_name
= do { mb_name <- lookupOccRn_maybe rdr_name
; case mb_name of
Just name -> return name
Just name -> return name
Nothing -> reportUnboundName rdr_name }
lookupKindOccRn :: RdrName -> RnM Name
......@@ -619,8 +620,23 @@ The final result (after the renamer) will be:
HsTyVar ("Zero", DataName)
\begin{code}
-- lookupOccRn looks up an occurrence of a RdrName
-- Use this version to get tracing
--
-- lookupOccRn_maybe, lookupOccRn_maybe' :: RdrName -> RnM (Maybe Name)
-- lookupOccRn_maybe rdr_name
-- = do { mb_res <- lookupOccRn_maybe' rdr_name
-- ; gbl_rdr_env <- getGlobalRdrEnv
-- ; local_rdr_env <- getLocalRdrEnv
-- ; traceRn $ text "lookupOccRn_maybe" <+>
-- vcat [ ppr rdr_name <+> ppr (getUnique (rdrNameOcc rdr_name))
-- , ppr mb_res
-- , text "Lcl env" <+> ppr local_rdr_env
-- , text "Gbl env" <+> ppr [ (getUnique (nameOccName (gre_name (head gres'))),gres') | gres <- occEnvElts gbl_rdr_env
-- , let gres' = filter isLocalGRE gres, not (null gres') ] ]
-- ; return mb_res }
lookupOccRn_maybe :: RdrName -> RnM (Maybe Name)
-- lookupOccRn looks up an occurrence of a RdrName
lookupOccRn_maybe rdr_name
= do { local_env <- getLocalRdrEnv
; case lookupLocalRdrEnv local_env rdr_name of {
......@@ -644,7 +660,7 @@ lookupOccRn_maybe rdr_name
-- and only happens for failed lookups
; if isQual rdr_name && allow_qual && is_ghci
then lookupQualifiedName rdr_name
else do { traceRn (text "lookupOccRn" <+> ppr rdr_name)
else do { traceRn (text "lookupOccRn failed" <+> ppr rdr_name)
; return Nothing } } } } } }
......@@ -1266,17 +1282,14 @@ bindLocatedLocalsRn rdr_names_w_loc enclosed_scope
bindLocalNames :: [Name] -> RnM a -> RnM a
bindLocalNames names enclosed_scope
= do { name_env <- getLocalRdrEnv
; stage <- getStage
; setLocalRdrEnv (extendLocalRdrEnvList name_env (thLevel stage) names)
enclosed_scope }
bindLocalName :: Name -> RnM a -> RnM a
bindLocalName name enclosed_scope
= do { name_env <- getLocalRdrEnv
; stage <- getStage
; setLocalRdrEnv (extendLocalRdrEnv name_env (thLevel stage) name)
enclosed_scope }
= do { lcl_env <- getLclEnv
; let th_level = thLevel (tcl_th_ctxt lcl_env)
th_bndrs' = extendNameEnvList (tcl_th_bndrs lcl_env)
[ (n, (NotTopLevel, th_level)) | n <- names ]
rdr_env' = extendLocalRdrEnvList (tcl_rdr lcl_env) names
; setLclEnv (lcl_env { tcl_th_bndrs = th_bndrs'
, tcl_rdr = rdr_env' })
enclosed_scope }
bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindLocalNamesFV names enclosed_scope
......@@ -1407,7 +1420,6 @@ unboundNameX where_look rdr_name extra
then addErr err
else do { suggestions <- unknownNameSuggestErr where_look rdr_name
; addErr (err $$ suggestions) }
; return (mkUnboundName rdr_name) }
unknownNameErr :: SDoc -> RdrName -> SDoc
......
......@@ -22,6 +22,7 @@ import RnBinds ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
rnMatchGroup, rnGRHS, makeMiniFixityEnv)
import HsSyn
import TcRnMonad
import Module ( getModule )
import RnEnv
import RnSplice
import RnTypes
......@@ -90,7 +91,11 @@ finishHsVar :: Name -> RnM (HsExpr Name, FreeVars)
-- when renaming infix expressions
-- See Note [Adding the implicit parameter to 'assert']
finishHsVar name
= do { ignore_asserts <- goptM Opt_IgnoreAsserts
= do { this_mod <- getModule
; when (nameIsLocalOrFrom this_mod name) $
checkThLocalName name
; ignore_asserts <- goptM Opt_IgnoreAsserts
; if ignore_asserts || not (name `hasKey` assertIdKey)
then return (HsVar name, unitFV name)
else do { e <- mkAssertErrorExpr
......@@ -107,15 +112,9 @@ rnExpr (HsVar v)
| name == nilDataConName -- Treat [] as an ExplicitList, so that
-- OverloadedLists works correctly
-> rnExpr (ExplicitList placeHolderType Nothing [])
| otherwise
-> do { mb_bind_lvl <- lookupLocalOccThLvl_maybe v
; case mb_bind_lvl of
{ Nothing -> return ()
; Just bind_lvl
| isExternalName name -> return ()
| otherwise -> checkThLocalName name bind_lvl
}
; finishHsVar name }}}
-> finishHsVar name }}
rnExpr (HsIPVar v)
= return (HsIPVar v, emptyFVs)
......
......@@ -31,6 +31,7 @@ import RdrName
import Outputable
import Maybes
import SrcLoc
import BasicTypes ( TopLevelFlag(..) )
import ErrUtils
import Util
import FastString
......@@ -346,6 +347,8 @@ created by its bindings.
Note [Top-level Names in Template Haskell decl quotes]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
See also: Note [Interactively-bound Ids in GHCi] in TcRnDriver
Consider a Template Haskell declaration quotation like this:
module M where
f x = h [d| f = 3 |]
......@@ -396,36 +399,47 @@ extendGlobalRdrEnvRn avails new_fixities
= do { (gbl_env, lcl_env) <- getEnvs
; stage <- getStage
; isGHCi <- getIsGHCi
; let rdr_env = tcg_rdr_env gbl_env
fix_env = tcg_fix_env gbl_env
; let rdr_env = tcg_rdr_env gbl_env
fix_env = tcg_fix_env gbl_env
th_bndrs = tcl_th_bndrs lcl_env
th_lvl = thLevel stage
-- Delete new_occs from global and local envs
-- If we are in a TemplateHaskell decl bracket,
-- we are going to shadow them
-- See Note [Top-level Names in Template Haskell decl quotes]
shadowP = isBrackStage stage
new_occs = map (nameOccName . gre_name) gres
rdr_env_TH = transformGREs qual_gre new_occs rdr_env
rdr_env_GHCi = delListFromOccEnv rdr_env new_occs
inBracket = isBrackStage stage
lcl_env_TH = lcl_env { tcl_rdr = delLocalRdrEnvList (tcl_rdr lcl_env) new_occs }
lcl_env1 = lcl_env { tcl_rdr = delLocalRdrEnvList (tcl_rdr lcl_env) new_occs }
(rdr_env2, lcl_env2) | shadowP = (rdr_env_TH, lcl_env1)
| isGHCi = (rdr_env_GHCi, lcl_env1)
rdr_env_GHCi = delListFromOccEnv rdr_env new_occs
-- This seems a bit brutal.
-- Mightn't we lose some qualified bindings that we want?
-- e.g. ghci> import Prelude as Q
-- ghci> data Int = Mk Q.Int
-- This fails because we expunge the binding for Prelude.Q
(rdr_env2, lcl_env2) | inBracket = (rdr_env, lcl_env_TH)
| isGHCi = (rdr_env_GHCi, lcl_env)
| otherwise = (rdr_env, lcl_env)
rdr_env3 = foldl extendGlobalRdrEnv rdr_env2 gres
fix_env' = foldl extend_fix_env fix_env gres
dups = findLocalDupsRdrEnv rdr_env3 new_occs
rdr_env3 = foldl extendGlobalRdrEnv rdr_env2 new_gres
lcl_env3 = lcl_env2 { tcl_th_bndrs = extendNameEnvList th_bndrs
[ (n, (TopLevel, th_lvl))
| n <- new_names ] }
fix_env' = foldl extend_fix_env fix_env new_gres
dups = findLocalDupsRdrEnv rdr_env3 new_names
gbl_env' = gbl_env { tcg_rdr_env = rdr_env3, tcg_fix_env = fix_env' }
; traceRn (text "extendGlobalRdrEnvRn dups" <+> (ppr dups))
; mapM_ addDupDeclErr dups
; mapM_ (addDupDeclErr . map gre_name) dups
; traceRn (text "extendGlobalRdrEnvRn" <+> (ppr new_fixities $$ ppr fix_env $$ ppr fix_env'))
; return (gbl_env', lcl_env2) }
; return (gbl_env', lcl_env3) }
where
gres = gresFromAvails LocalDef avails
new_gres = gresFromAvails LocalDef avails
new_names = map gre_name new_gres
new_occs = map nameOccName new_names
-- If there is a fixity decl for the gre, add it to the fixity env
extend_fix_env fix_env gre
......@@ -436,35 +450,6 @@ extendGlobalRdrEnvRn avails new_fixities
where
name = gre_name gre
occ = nameOccName name
qual_gre :: GlobalRdrElt -> GlobalRdrElt
-- Transform top-level GREs from the module being compiled
-- so that they are out of the way of new definitions in a Template
-- Haskell bracket
-- See Note [Top-level Names in Template Haskell decl quotes]
-- Seems like 5 times as much work as it deserves!
--
-- For a LocalDef we make a (fake) qualified imported GRE for a
-- local GRE so that the original *qualified* name is still in scope
-- but the *unqualified* one no longer is. What a hack!
qual_gre gre@(GRE { gre_prov = LocalDef, gre_name = name })
| isExternalName name = gre { gre_prov = Imported [imp_spec] }
| otherwise = gre
-- Do not shadow Internal (ie Template Haskell) Names
-- See Note [Top-level Names in Template Haskell decl quotes]
where
mod = ASSERT2( isExternalName name, ppr name) moduleName (nameModule name)
imp_spec = ImpSpec { is_item = ImpAll, is_decl = decl_spec }
decl_spec = ImpDeclSpec { is_mod = mod, is_as = mod,
is_qual = True, -- Qualified only!
is_dloc = srcLocSpan (nameSrcLoc name) }
qual_gre gre@(GRE { gre_prov = Imported specs })
= gre { gre_prov = Imported (map qual_spec specs) }
qual_spec spec@(ImpSpec { is_decl = decl_spec })
= spec { is_decl = decl_spec { is_qual = True } }
\end{code}
@getLocalDeclBinders@ returns the names for an @HsDecl@. It's
......
......@@ -199,7 +199,7 @@ newPatName :: NameMaker -> Located RdrName -> CpsRn Name
newPatName (LamMk report_unused) rdr_name
= CpsRn (\ thing_inside ->
do { name <- newLocalBndrRn rdr_name
; (res, fvs) <- bindLocalName name (thing_inside name)
; (res, fvs) <- bindLocalNames [name] (thing_inside name)
; when report_unused $ warnUnusedMatches [name] fvs
; return (res, name `delFV` fvs) })
......@@ -208,12 +208,12 @@ newPatName (LetMk is_top fix_env) rdr_name
do { name <- case is_top of
NotTopLevel -> newLocalBndrRn rdr_name
TopLevel -> newTopSrcBinder rdr_name
; bindLocalName name $ -- Do *not* use bindLocalNameFV here
; bindLocalNames [name] $ -- Do *not* use bindLocalNameFV here
-- See Note [View pattern usage]
addLocalFixities fix_env [name] $
thing_inside name })
-- Note: the bindLocalName is somewhat suspicious
-- Note: the bindLocalNames is somewhat suspicious
-- because it binds a top-level name as a local name.
-- however, this binding seems to work, and it only exists for
-- the duration of the patterns and the continuation;
......@@ -227,7 +227,7 @@ Consider
let (r, (r -> x)) = x in ...
Here the pattern binds 'r', and then uses it *only* in the view pattern.
We want to "see" this use, and in let-bindings we collect all uses and
report unused variables at the binding level. So we must use bindLocalName
report unused variables at the binding level. So we must use bindLocalNames
here, *not* bindLocalNameFV. Trac #3943.
%*********************************************************
......
......@@ -21,6 +21,7 @@ import RnBinds
import RnEnv
import RnNames
import RnHsDoc ( rnHsDoc, rnMbLHsDoc )
import TcAnnotations ( annCtxt )
import TcRnMonad
import ForeignCall ( CCallTarget(..) )
......@@ -338,10 +339,12 @@ dupWarnDecl (L loc _) rdr_name
\begin{code}
rnAnnDecl :: AnnDecl RdrName -> RnM (AnnDecl Name, FreeVars)
rnAnnDecl (HsAnnotation provenance expr) = do
(provenance', provenance_fvs) <- rnAnnProvenance provenance
(expr', expr_fvs) <- rnLExpr expr
return (HsAnnotation provenance' expr', provenance_fvs `plusFV` expr_fvs)
rnAnnDecl ann@(HsAnnotation provenance expr)
= addErrCtxt (annCtxt ann) $
do { (provenance', provenance_fvs) <- rnAnnProvenance provenance
; (expr', expr_fvs) <- setStage (Splice False) $
rnLExpr expr
; return (HsAnnotation provenance' expr', provenance_fvs `plusFV` expr_fvs) }
rnAnnProvenance :: AnnProvenance RdrName -> RnM (AnnProvenance Name, FreeVars)
rnAnnProvenance provenance = do
......
......@@ -23,8 +23,9 @@ import RnPat
import RnSource ( rnSrcDecls, findSplice )
import RnTypes
import SrcLoc
import TcEnv ( checkWellStaged, tcLookup, tcMetaTy, thTopLevelId )
import TcEnv ( checkWellStaged, tcMetaTy )
import Outputable
import BasicTypes ( TopLevelFlag, isTopLevel )
import FastString
import {-# SOURCE #-} RnExpr ( rnLExpr )
......@@ -82,6 +83,7 @@ type checker. Not very satisfactory really.
\begin{code}
rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars)
-- Not exported...used for all
rnSplice (HsSplice isTyped n expr)
= do { checkTH expr "Template Haskell splice"
; loc <- getSrcSpanM
......@@ -316,7 +318,9 @@ rnBracket e br_body
; recordThUse
; pending_splices <- newMutVar []
; let brack_stage = Brack (isTypedBracket br_body) cur_stage pending_splices (error "rnBracket: don't neet lie")
; let brack_stage = Brack (isTypedBracket br_body)
cur_stage pending_splices
(error "rnBracket: don't neet lie")
; (body', fvs_e) <- setStage brack_stage $
rn_bracket cur_stage br_body
......@@ -326,45 +330,33 @@ rnBracket e br_body
}
rn_bracket :: ThStage -> HsBracket RdrName -> RnM (HsBracket Name, FreeVars)
rn_bracket outer_stage br@(VarBr flg n)
= do { name <- lookupOccRn n
rn_bracket outer_stage br@(VarBr flg rdr_name)
= do { name <- lookupOccRn rdr_name
; this_mod <- getModule
; case flg of
{ -- Type variables can be quoted in TH. See #5721.
False -> return ()
; True | nameIsLocalOrFrom this_mod name ->
do { mb_bind_lvl <- lookupLocalOccThLvl_maybe n
do { mb_bind_lvl <- lookupLocalOccThLvl_maybe name
; case mb_bind_lvl of
{ Nothing -> return ()
; Just bind_lvl
| isExternalName name -> return ()
-- Local non-external things can still be
-- top-level in GHCi, so check for that here.
| bind_lvl == impLevel -> return ()
| otherwise -> checkTc (thLevel outer_stage + 1 == bind_lvl)
(quotedNameStageErr br)
}
}
; True | otherwise ->
-- Reason: deprecation checking assumes
-- the home interface is loaded, and
-- this is the only way that is going
-- to happen
do { _ <- loadInterfaceForName msg name
; thing <- tcLookup name
; case thing of
{ AGlobal {} -> return ()
; ATyVar {} -> return ()
; ATcId { tct_level = bind_lvl, tct_id = id }
| thTopLevelId id -- C.f TcExpr.checkCrossStageLifting
-> keepAliveTc id
| otherwise
-> do { checkTc (thLevel outer_stage + 1 == bind_lvl)
(quotedNameStageErr br) }
; _ -> pprPanic "rh_bracket" (ppr name $$ ppr thing)
{ Nothing -> pprTrace "rn_bracket" (ppr name) $ -- Should not happen for local names
return ()
; Just (top_lvl, bind_lvl) -- See Note [Quoting names]
| isTopLevel top_lvl
-> when (isExternalName name) (keepAlive name)
| otherwise
-> do { traceRn (text "rn_bracket VarBr" <+> ppr name <+> ppr bind_lvl <+> ppr outer_stage)
; checkTc (thLevel outer_stage + 1 == bind_lvl)
(quotedNameStageErr br) }
}
}
; True | otherwise -> -- Imported thing
discardResult (loadInterfaceForName msg name)
-- Reason for loadInterface: deprecation checking
-- assumes that the home interface is loaded, and
-- this is the only way that is going to happen
}
; return (VarBr flg name, unitFV name) }
where
......@@ -457,32 +449,35 @@ quotationCtxtDoc br_body
spliceResultDoc :: OutputableBndr id => LHsExpr id -> SDoc
spliceResultDoc expr
= sep [ ptext (sLit "In the result of the splice:")
, nest 2 (char '$' <> pprParendExpr expr)
, ptext (sLit "To see what the splice expanded to, use -ddump-splices")]
= vcat [ hang (ptext (sLit "In the splice:"))
2 (char '$' <> pprParendExpr expr)
, ptext (sLit "To see what the splice expanded to, use -ddump-splices") ]
#endif
\end{code}
\begin{code}
checkThLocalName :: Name -> ThLevel -> RnM ()
checkThLocalName :: Name -> RnM ()
#ifndef GHCI /* GHCI and TH is off */
--------------------------------------
-- Check for cross-stage lifting
checkThLocalName _name _bind_lvl
checkThLocalName _name
= return ()
#else /* GHCI and TH is on */
checkThLocalName name bind_lvl
= do { use_stage <- getStage -- TH case
; let use_lvl = thLevel use_stage
; traceRn (text "checkThLocalName" <+> ppr name)
checkThLocalName name
= do { traceRn (text "checkThLocalName" <+> ppr name)
; mb_local_use <- getStageAndBindLevel name
; case mb_local_use of {
Nothing -> return () ; -- Not a locally-bound thing
Just (top_lvl, bind_lvl, use_stage) ->
do { let use_lvl = thLevel use_stage
; checkWellStaged (quotes (ppr name)) bind_lvl use_lvl
; traceTc "thLocalId" (ppr name <+> ppr bind_lvl <+> ppr use_stage <+> ppr use_lvl)
; traceRn (text "checkThLocalName" <+> ppr name <+> ppr bind_lvl <+> ppr use_stage <+> ppr use_lvl)
; when (use_lvl > bind_lvl) $
checkCrossStageLifting name bind_lvl use_stage }
checkCrossStageLifting top_lvl name use_stage } } }
--------------------------------------
checkCrossStageLifting :: Name -> ThLevel -> ThStage -> TcM ()
checkCrossStageLifting :: TopLevelFlag -> Name -> ThStage -> TcM ()
-- We are inside brackets, and (use_lvl > bind_lvl)
-- Now we must check whether there's a cross-stage lift to do
-- Examples \x -> [| x |]
......@@ -491,21 +486,18 @@ checkCrossStageLifting :: Name -> ThLevel -> ThStage -> TcM ()
checkCrossStageLifting _ _ Comp = return ()
checkCrossStageLifting _ _ (Splice _) = return ()
checkCrossStageLifting name _ (Brack _ _ ps_var _)
| isExternalName name
= -- Top-level identifiers in this module,
checkCrossStageLifting top_lvl name (Brack _ _ ps_var _)
| isTopLevel top_lvl
-- Top-level identifiers in this module,
-- (which have External Names)
-- are just like the imported case:
-- no need for the 'lifting' treatment
-- E.g. this is fine:
-- f x = x
-- g y = [| f 3 |]
-- But we do need to put f into the keep-alive
-- set, because after desugaring the code will
-- only mention f's *name*, not f itself.
--
-- The type checker will put f into the keep-alive set.
return ()
= when (isExternalName name) (keepAlive name)
-- See Note [Keeping things alive for Template Haskell]
| otherwise
= -- Nested identifiers, such as 'x' in
-- E.g. \x -> [| h x |]
......@@ -523,3 +515,64 @@ checkCrossStageLifting name _ (Brack _ _ ps_var _)
}
#endif /* GHCI */
\end{code}
Note [Keeping things alive for Template Haskell]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
f x = x+1
g y = [| f 3 |]
Here 'f' is referred to from inside the bracket, which turns into data
and mentions only f's *name*, not 'f' itself. So we need some other
way to keep 'f' alive, lest it get dropped as dead code. That's what
keepAlive does. It puts it in the keep-alive set, which subsequently
ensures that 'f' stays as a top level binding.
This must be done by the renamer, not the type checker (as of old),
because the type checker doesn't typecheck the body of untyped