Commit 5dffb4ac authored by Simon Peyton Jones's avatar Simon Peyton Jones

Refactor the way shadowing in handled in GHCi

If you say
  ghci> import Foo( T )
  ghci> data T = MkT
  ghci> data T = XXX
then the second 'data T' should shadow the first.  But the qualified
Foo.T should still be available.  We really weren't handling this
correctly at all, resulting in Trac #8639 and #8628 among others

This patch:

* Add RdrName.extendGlobalRdrEnv, which does shadowing properly

* Change HscTypes.icExtendGblRdrEnv (was badly-named icPlusGblRdrEnv)
  to use the new function

* Change RnNames.extendGobalRdrEnvRn to use the new function

* Move gresFrom Avails into RdrName
* Better pprGlobalRdrEnv function in RdrName
parent e60a841b
......@@ -8,15 +8,12 @@ module Avail (
availsToNameSet,
availsToNameEnv,
availName, availNames,
stableAvailCmp,
gresFromAvails,
gresFromAvail
stableAvailCmp
) where
import Name
import NameEnv
import NameSet
import RdrName
import Binary
import Outputable
......@@ -77,24 +74,6 @@ availNames :: AvailInfo -> [Name]
availNames (Avail n) = [n]
availNames (AvailTC _ ns) = ns
-- | make a 'GlobalRdrEnv' where all the elements point to the same
-- Provenance (useful for "hiding" imports, or imports with
-- no details).
gresFromAvails :: Provenance -> [AvailInfo] -> [GlobalRdrElt]
gresFromAvails prov avails
= concatMap (gresFromAvail (const prov)) avails
gresFromAvail :: (Name -> Provenance) -> AvailInfo -> [GlobalRdrElt]
gresFromAvail prov_fn avail
= [ GRE {gre_name = n,
gre_par = parent n avail,
gre_prov = prov_fn n}
| n <- availNames avail ]
where
parent _ (Avail _) = NoParent
parent n (AvailTC m _) | n == m = NoParent
| otherwise = ParentIs m
-- -----------------------------------------------------------------------------
-- Printing
......
......@@ -45,11 +45,14 @@ module RdrName (
-- * Global mapping of 'RdrName' to 'GlobalRdrElt's
GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv,
lookupGlobalRdrEnv, extendGlobalRdrEnv,
lookupGlobalRdrEnv, extendGlobalRdrEnv,
pprGlobalRdrEnv, globalRdrEnvElts,
lookupGRE_RdrName, lookupGRE_Name, getGRE_NameQualifier_maybes,
transformGREs, findLocalDupsRdrEnv, pickGREs,
-- * GlobalRdrElts
gresFromAvails, gresFromAvail,
-- ** Global 'RdrName' mapping elements: 'GlobalRdrElt', 'Provenance', 'ImportSpec'
GlobalRdrElt(..), isLocalGRE, unQualOK, qualSpecOK, unQualSpecOK,
Provenance(..), pprNameProvenance,
......@@ -62,6 +65,7 @@ module RdrName (
import Module
import Name
import Avail
import NameSet
import Maybes
import SrcLoc
......@@ -410,7 +414,25 @@ data GlobalRdrElt
data Parent = NoParent | ParentIs Name
deriving (Eq)
{- Note [Parents]
instance Outputable Parent where
ppr NoParent = empty
ppr (ParentIs n) = ptext (sLit "parent:") <> ppr n
plusParent :: Parent -> Parent -> Parent
-- See Note [Combining parents]
plusParent (ParentIs n) p2 = hasParent n p2
plusParent p1 (ParentIs n) = hasParent n p1
plusParent _ _ = NoParent
hasParent :: Name -> Parent -> Parent
#ifdef DEBUG
hasParent n (ParentIs n')
| n /= n' = pprPanic "hasParent" (ppr n <+> ppr n') -- Parents should agree
#endif
hasParent n _ = ParentIs n
\end{code}
Note [Parents]
~~~~~~~~~~~~~~~~~
Parent Children
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -449,25 +471,28 @@ those. For T that will mean we have
one GRE with Parent C
one GRE with NoParent
That's why plusParent picks the "best" case.
-}
instance Outputable Parent where
ppr NoParent = empty
ppr (ParentIs n) = ptext (sLit "parent:") <> ppr n
\begin{code}
-- | make a 'GlobalRdrEnv' where all the elements point to the same
-- Provenance (useful for "hiding" imports, or imports with
-- no details).
gresFromAvails :: Provenance -> [AvailInfo] -> [GlobalRdrElt]
gresFromAvails prov avails
= concatMap (gresFromAvail (const prov)) avails
gresFromAvail :: (Name -> Provenance) -> AvailInfo -> [GlobalRdrElt]
gresFromAvail prov_fn avail
= [ GRE {gre_name = n,
gre_par = mkParent n avail,
gre_prov = prov_fn n}
| n <- availNames avail ]
where
plusParent :: Parent -> Parent -> Parent
-- See Note [Combining parents]
plusParent (ParentIs n) p2 = hasParent n p2
plusParent p1 (ParentIs n) = hasParent n p1
plusParent _ _ = NoParent
hasParent :: Name -> Parent -> Parent
#ifdef DEBUG
hasParent n (ParentIs n')
| n /= n' = pprPanic "hasParent" (ppr n <+> ppr n') -- Parents should agree
#endif
hasParent n _ = ParentIs n
mkParent :: Name -> AvailInfo -> Parent
mkParent _ (Avail _) = NoParent
mkParent n (AvailTC m _) | n == m = NoParent
| otherwise = ParentIs m
emptyGlobalRdrEnv :: GlobalRdrEnv
emptyGlobalRdrEnv = emptyOccEnv
......@@ -479,25 +504,28 @@ instance Outputable GlobalRdrElt where
ppr gre = hang (ppr (gre_name gre) <+> ppr (gre_par gre))
2 (pprNameProvenance gre)
pprGlobalRdrEnv :: GlobalRdrEnv -> SDoc
pprGlobalRdrEnv env
= vcat (map pp (occEnvElts env))
pprGlobalRdrEnv :: Bool -> GlobalRdrEnv -> SDoc
pprGlobalRdrEnv locals_only env
= vcat [ ptext (sLit "GlobalRdrEnv") <+> ppWhen locals_only (ptext (sLit "(locals only)"))
<+> lbrace
, nest 2 (vcat [ pp (remove_locals gre_list) | gre_list <- occEnvElts env ]
<+> rbrace) ]
where
pp gres = ppr (nameOccName (gre_name (head gres))) <> colon <+>
vcat (map ppr gres)
\end{code}
remove_locals gres | locals_only = filter isLocalGRE gres
| otherwise = gres
pp [] = empty
pp gres = hang (ppr occ
<+> parens (ptext (sLit "unique") <+> ppr (getUnique occ))
<> colon)
2 (vcat (map ppr gres))
where
occ = nameOccName (gre_name (head gres))
\begin{code}
lookupGlobalRdrEnv :: GlobalRdrEnv -> OccName -> [GlobalRdrElt]
lookupGlobalRdrEnv env occ_name = case lookupOccEnv env occ_name of
Nothing -> []
Just gres -> gres
extendGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrElt -> GlobalRdrEnv
extendGlobalRdrEnv env gre = extendOccEnv_Acc (:) singleton env occ gre
where
occ = nameOccName (gre_name gre)
lookupGRE_RdrName :: RdrName -> GlobalRdrEnv -> [GlobalRdrElt]
lookupGRE_RdrName rdr_name env
= case lookupOccEnv env (rdrNameOcc rdr_name) of
......@@ -519,6 +547,15 @@ getGRE_NameQualifier_maybes env
qualifier_maybe LocalDef = Nothing
qualifier_maybe (Imported iss) = Just $ map (is_as . is_decl) iss
isLocalGRE :: GlobalRdrElt -> Bool
isLocalGRE (GRE {gre_prov = LocalDef}) = True
isLocalGRE _ = False
unQualOK :: GlobalRdrElt -> Bool
-- ^ Test if an unqualifed version of this thing would be in scope
unQualOK (GRE {gre_prov = LocalDef}) = True
unQualOK (GRE {gre_prov = Imported is}) = any unQualSpecOK is
pickGREs :: RdrName -> [GlobalRdrElt] -> [GlobalRdrElt]
-- ^ Take a list of GREs which have the right OccName
-- Pick those GREs that are suitable for this RdrName
......@@ -580,16 +617,11 @@ pickGREs rdr_name gres
= filter ((== mod) . is_as . is_decl) is
| otherwise
= []
\end{code}
isLocalGRE :: GlobalRdrElt -> Bool
isLocalGRE (GRE {gre_prov = LocalDef}) = True
isLocalGRE _ = False
unQualOK :: GlobalRdrElt -> Bool
-- ^ Test if an unqualifed version of this thing would be in scope
unQualOK (GRE {gre_prov = LocalDef}) = True
unQualOK (GRE {gre_prov = Imported is}) = any unQualSpecOK is
Building GlobalRdrEnvs
\begin{code}
plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv
plusGlobalRdrEnv env1 env2 = plusOccEnv_C (foldr insertGRE) env1 env2
......@@ -601,33 +633,6 @@ mkGlobalRdrEnv gres
(nameOccName (gre_name gre))
gre
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
findLocalDupsRdrEnv rdr_env occs
= go rdr_env [] occs
where
go _ dups [] = dups
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
occ = nameOccName name
gres = lookupOccEnv rdr_env occ `orElse` []
rdr_env' = delFromOccEnv rdr_env occ
-- The delFromOccEnv avoids repeating the same
-- 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)
......@@ -654,6 +659,77 @@ transformGREs trans_gre occs rdr_env
= case lookupOccEnv env occ of
Just gres -> extendOccEnv env occ (map trans_gre gres)
Nothing -> env
extendGlobalRdrEnv :: Bool -> GlobalRdrEnv -> [AvailInfo] -> GlobalRdrEnv
-- Extend with new LocalDef GREs from the AvailInfos.
--
-- If do_shadowing is True, first remove name clashes between the new
-- AvailInfos and the existing GlobalRdrEnv.
-- This is used by the GHCi top-level
--
-- E.g. Adding a LocalDef "x" when there is an existing GRE for Q.x
-- should remove any unqualified import of Q.x,
-- leaving only the qualified one
--
-- However do *not* remove name clashes between the AvailInfos themselves,
-- so that (say) data T = A | A
-- will still give a duplicate-binding error.
-- Same thing if there are multiple AvailInfos (don't remove clashes),
-- though I'm not sure this ever happens with do_shadowing=True
extendGlobalRdrEnv do_shadowing env avails
= foldl add_avail env1 avails
where
names = concatMap availNames avails
env1 | do_shadowing = foldl shadow_name env names
| otherwise = env
-- By doing the removal first, we ensure that the new AvailInfos
-- don't shadow each other; that would conceal genuine errors
-- E.g. in GHCi data T = A | A
add_avail env avail = foldl (add_name avail) env (availNames avail)
add_name avail env name
= extendOccEnv_Acc (:) singleton env occ gre
where
occ = nameOccName name
gre = GRE { gre_name = name
, gre_par = mkParent name avail
, gre_prov = LocalDef }
shadow_name :: GlobalRdrEnv -> Name -> GlobalRdrEnv
shadow_name env name
= alterOccEnv (fmap alter_fn) env (nameOccName name)
where
alter_fn :: [GlobalRdrElt] -> [GlobalRdrElt]
alter_fn gres = mapCatMaybes (shadow_with name) gres
shadow_with :: Name -> GlobalRdrElt -> Maybe GlobalRdrElt
shadow_with new_name old_gre@(GRE { gre_name = old_name, gre_prov = LocalDef })
= case (nameModule_maybe old_name, nameModule_maybe new_name) of
(Nothing, _) -> Nothing
(Just old_mod, Just new_mod) | new_mod == old_mod -> Nothing
(Just old_mod, _) -> Just (old_gre { gre_prov = Imported [fake_imp_spec] })
where
fake_imp_spec = ImpSpec id_spec ImpAll -- Urgh!
old_mod_name = moduleName old_mod
id_spec = ImpDeclSpec { is_mod = old_mod_name
, is_as = old_mod_name
, is_qual = True
, is_dloc = nameSrcSpan old_name }
shadow_with new_name old_gre@(GRE { gre_prov = Imported imp_specs })
| null imp_specs' = Nothing
| otherwise = Just (old_gre { gre_prov = Imported imp_specs' })
where
imp_specs' = mapCatMaybes (shadow_is new_name) imp_specs
shadow_is :: Name -> ImportSpec -> Maybe ImportSpec
shadow_is new_name is@(ImpSpec { is_decl = id_spec })
| Just new_mod <- nameModule_maybe new_name
, is_as id_spec == moduleName new_mod
= Nothing -- Shadow both qualified and unqualified
| otherwise -- Shadow unqualified only
= Just (is { is_decl = id_spec { is_qual = True } })
\end{code}
Note [Template Haskell binders in the GlobalRdrEnv]
......@@ -663,6 +739,35 @@ 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
\begin{code}
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
findLocalDupsRdrEnv rdr_env occs
= go rdr_env [] occs
where
go _ dups [] = dups
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
occ = nameOccName name
gres = lookupOccEnv rdr_env occ `orElse` []
rdr_env' = delFromOccEnv rdr_env occ
-- The delFromOccEnv avoids repeating the same
-- 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
\end{code}
%************************************************************************
%* *
Provenance
......
......@@ -45,7 +45,6 @@ import TcIface
import LoadIface
import Finder
import PrelNames
import Avail
import RdrName
import HscTypes
import Bag
......
......@@ -1439,11 +1439,12 @@ hscDeclsWithLocation hsc_env0 str source linenumber =
ext_ids = [ id | id <- bindersOfBinds core_binds
, isExternalName (idName id)
, not (isDFunId id) ]
, not (isDFunId id || isImplicitId id) ]
-- We only need to keep around the external bindings
-- (as decided by TidyPgm), since those are the only ones
-- that might be referenced elsewhere.
-- The DFunIds are in 'insts' (see Note [ic_tythings] in HscTypes
-- Implicit Ids are implicit in tcs
tythings = map AnId ext_ids ++ map ATyCon tcs
......
......@@ -48,7 +48,7 @@ module HscTypes (
-- * Interactive context
InteractiveContext(..), emptyInteractiveContext,
icPrintUnqual, icInScopeTTs, icPlusGblRdrEnv,
icPrintUnqual, icInScopeTTs, icExtendGblRdrEnv,
extendInteractiveContext, substInteractiveContext,
setInteractivePrintName,
InteractiveImport(..),
......@@ -1197,7 +1197,7 @@ icPrintUnqual dflags InteractiveContext{ ic_rn_gbl_env = grenv } =
extendInteractiveContext :: InteractiveContext -> [TyThing] -> InteractiveContext
extendInteractiveContext ictxt new_tythings
= ictxt { ic_tythings = new_tythings ++ old_tythings
, ic_rn_gbl_env = new_tythings `icPlusGblRdrEnv` ic_rn_gbl_env ictxt
, ic_rn_gbl_env = ic_rn_gbl_env ictxt `icExtendGblRdrEnv` new_tythings
}
where
old_tythings = filter (not . shadowed) (ic_tythings ictxt)
......@@ -1214,19 +1214,22 @@ setInteractivePrintName ic n = ic{ic_int_print = n}
-- | Add TyThings to the GlobalRdrEnv, earlier ones in the list shadowing
-- later ones, and shadowing existing entries in the GlobalRdrEnv.
icPlusGblRdrEnv :: [TyThing] -> GlobalRdrEnv -> GlobalRdrEnv
icPlusGblRdrEnv tythings env = extendOccEnvList env list
where new_gres = gresFromAvails LocalDef (map tyThingAvailInfo tythings)
list = [ (nameOccName (gre_name gre), [gre]) | gre <- new_gres ]
icExtendGblRdrEnv :: GlobalRdrEnv -> [TyThing] -> GlobalRdrEnv
icExtendGblRdrEnv env tythings
= foldr add env tythings -- Foldr makes things in the front of
-- the list shadow things at the back
where
add thing env = extendGlobalRdrEnv True {- Shadowing please -} env
[tyThingAvailInfo thing]
-- One at a time, to ensure each shadows the previous ones
substInteractiveContext :: InteractiveContext -> TvSubst -> InteractiveContext
substInteractiveContext ictxt subst
| isEmptyTvSubst subst = ictxt
substInteractiveContext ictxt@InteractiveContext{ ic_tythings = tts } subst
= ictxt { ic_tythings = map subst_ty tts }
where subst_ty (AnId id) = AnId $ id `setIdType` substTy subst (idType id)
subst_ty tt = tt
| isEmptyTvSubst subst = ictxt
| otherwise = ictxt { ic_tythings = map subst_ty tts }
where
subst_ty (AnId id) = AnId $ id `setIdType` substTy subst (idType id)
subst_ty tt = tt
data InteractiveImport
= IIDecl (ImportDecl RdrName)
......@@ -1241,7 +1244,6 @@ data InteractiveImport
instance Outputable InteractiveImport where
ppr (IIModule m) = char '*' <> ppr m
ppr (IIDecl d) = ppr d
\end{code}
%************************************************************************
......
......@@ -813,7 +813,7 @@ setContext imports
liftIO $ throwGhcExceptionIO (formatError dflags mod err)
Right all_env -> do {
; let old_ic = hsc_IC hsc_env
final_rdr_env = ic_tythings old_ic `icPlusGblRdrEnv` all_env
final_rdr_env = all_env `icExtendGblRdrEnv` ic_tythings old_ic
; modifySession $ \_ ->
hsc_env{ hsc_IC = old_ic { ic_imports = imports
, ic_rn_gbl_env = final_rdr_env }}}}
......
......@@ -411,44 +411,41 @@ extendGlobalRdrEnvRn avails new_fixities
inBracket = isBrackStage stage
lcl_env_TH = lcl_env { tcl_rdr = delLocalRdrEnvList (tcl_rdr lcl_env) new_occs }
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 new_gres
lcl_env2 | inBracket = lcl_env_TH
| otherwise = lcl_env
rdr_env2 = extendGlobalRdrEnv (isGHCi && not inBracket) rdr_env avails
-- Shadowing only applies for GHCi decls outside brackets
-- e.g. (Trac #4127a)
-- ghci> runQ [d| class C a where f :: a
-- f = True
-- instance C Int where f = 2 |]
-- We don't want the f=True to shadow the f class-op
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
fix_env' = foldl extend_fix_env fix_env new_names
dups = findLocalDupsRdrEnv rdr_env2 new_names
gbl_env' = gbl_env { tcg_rdr_env = rdr_env3, tcg_fix_env = fix_env' }
gbl_env' = gbl_env { tcg_rdr_env = rdr_env2, tcg_fix_env = fix_env' }
; traceRn (text "extendGlobalRdrEnvRn dups" <+> (ppr dups))
; traceRn (text "extendGlobalRdrEnvRn 1" <+> (ppr avails $$ (ppr dups)))
; mapM_ (addDupDeclErr . map gre_name) dups
; traceRn (text "extendGlobalRdrEnvRn" <+> (ppr new_fixities $$ ppr fix_env $$ ppr fix_env'))
; traceRn (text "extendGlobalRdrEnvRn 2" <+> (pprGlobalRdrEnv True rdr_env2))
; return (gbl_env', lcl_env3) }
where
new_gres = gresFromAvails LocalDef avails
new_names = map gre_name new_gres
new_names = concatMap availNames avails
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
extend_fix_env fix_env name
| Just (L _ fi) <- lookupFsEnv new_fixities (occNameFS occ)
= extendNameEnv fix_env name (FixItem occ fi)
| otherwise
= fix_env
where
name = gre_name gre
occ = nameOccName name
\end{code}
......@@ -476,6 +473,7 @@ getLocalNonValBinders fixity_env
hs_fords = foreign_decls })
= do { -- Process all type/class decls *except* family instances
; tc_avails <- mapM new_tc (tyClGroupConcat tycl_decls)
; traceRn (text "getLocalNonValBinders 1" <+> ppr tc_avails)
; envs <- extendGlobalRdrEnvRn tc_avails fixity_env
; setEnvs envs $ do {
-- Bring these things into scope first
......@@ -496,6 +494,7 @@ getLocalNonValBinders fixity_env
; let avails = nti_avails ++ val_avails
new_bndrs = availsToNameSet avails `unionNameSets`
availsToNameSet tc_avails
; traceRn (text "getLocalNonValBinders 2" <+> ppr avails)
; envs <- extendGlobalRdrEnvRn avails fixity_env
; return (envs, new_bndrs) } }
where
......
......@@ -114,6 +114,7 @@ rnSrcDecls extra_deps group@(HsGroup { hs_valds = val_decls,
let { val_binders = collectHsValBinders new_lhs ;
all_bndrs = addListToNameSet tc_bndrs val_binders ;
val_avails = map Avail val_binders } ;
traceRn (text "rnSrcDecls" <+> ppr val_avails) ;
(tcg_env, tcl_env) <- extendGlobalRdrEnvRn val_avails local_fix_env ;
traceRn (ptext (sLit "Val binders") <+> (ppr val_binders)) ;
setEnvs (tcg_env, tcl_env) $ do {
......
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