Commit 5ad61e14 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

More refactoring in RnNames

I rather self-indulgently spent a chunk of yesterday working on 
refactoring RnNames further.  The result is significantly simpler:

* A GlobalRdrElt gets an extra field, gre_par, which records
  the parent (if any) of the name

* ImportAvails has two fields deleted: imp_env and imp_parent.
  The information provided by these fields was only used when
  processing the export list; and the same information is now readily
  generated from the GlobalRdrElts in the GlobalRdrEnv

I also did some tidying up; notably moving AvailEnv stuff from
TcRnTypes to RnNames.

The result is tha the compiler is some 130 lines shorter than before
parent 311b1cdf
......@@ -31,15 +31,15 @@ module RdrName (
lookupGRE_RdrName, lookupGRE_Name, hideSomeUnquals,
-- GlobalRdrElt, Provenance, ImportSpec
GlobalRdrElt(..), isLocalGRE, unQualOK,
GlobalRdrElt(..), isLocalGRE, unQualOK, qualSpecOK, unQualSpecOK,
Provenance(..), pprNameProvenance,
Parent(..),
ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..),
importSpecLoc, importSpecModule
) where
#include "HsVersions.h"
import OccName
import Module
import Name
import Maybes
......@@ -295,22 +295,32 @@ type GlobalRdrEnv = OccEnv [GlobalRdrElt]
-- INVARIANT: All the members of the list have distinct
-- gre_name fields; that is, no duplicate Names
data GlobalRdrElt
= GRE { gre_name :: Name,
gre_par :: Parent,
gre_prov :: Provenance -- Why it's in scope
}
data Parent = NoParent | ParentIs Name
instance Outputable Parent where
ppr NoParent = empty
ppr (ParentIs n) = ptext SLIT("parent:") <> ppr n
plusParent :: Parent -> Parent -> Parent
plusParent NoParent rel = ASSERT( case rel of { NoParent -> True; other -> False } ) NoParent
plusParent (ParentIs n) rel = ASSERT( case rel of { ParentIs m -> n==m; other -> False } ) ParentIs n
emptyGlobalRdrEnv = emptyOccEnv
globalRdrEnvElts :: GlobalRdrEnv -> [GlobalRdrElt]
globalRdrEnvElts env = foldOccEnv (++) [] env
data GlobalRdrElt
= GRE { gre_name :: Name,
gre_prov :: Provenance -- Why it's in scope
}
instance Outputable GlobalRdrElt where
ppr gre = ppr name <+> parens (pprNameProvenance gre)
ppr gre = ppr name <+> parens (ppr (gre_par gre) <+> pprNameProvenance gre)
where
name = gre_name gre
pp_parent (Just p) = brackets (text "parent:" <+> ppr p)
pp_parent Nothing = empty
pprGlobalRdrEnv :: GlobalRdrEnv -> SDoc
pprGlobalRdrEnv env
......@@ -396,7 +406,15 @@ isLocalGRE other = False
unQualOK :: GlobalRdrElt -> Bool
-- An unqualifed version of this thing is in scope
unQualOK (GRE {gre_prov = LocalDef}) = True
unQualOK (GRE {gre_prov = Imported is}) = not (all (is_qual . is_decl) is)
unQualOK (GRE {gre_prov = Imported is}) = any unQualSpecOK is
unQualSpecOK :: ImportSpec -> Bool
-- In scope unqualified
unQualSpecOK is = not (is_qual (is_decl is))
qualSpecOK :: ModuleName -> ImportSpec -> Bool
-- In scope qualified with M
qualSpecOK mod is = mod == is_as (is_decl is)
plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv
plusGlobalRdrEnv env1 env2 = plusOccEnv_C (foldr insertGRE) env1 env2
......@@ -421,7 +439,8 @@ plusGRE :: GlobalRdrElt -> GlobalRdrElt -> GlobalRdrElt
-- Used when the gre_name fields match
plusGRE g1 g2
= GRE { gre_name = gre_name g1,
gre_prov = gre_prov g1 `plusProv` gre_prov g2 }
gre_prov = gre_prov g1 `plusProv` gre_prov g2,
gre_par = gre_par g1 `plusParent` gre_par g2 }
hideSomeUnquals :: GlobalRdrEnv -> [OccName] -> GlobalRdrEnv
-- Hide any unqualified bindings for the specified OccNames
......@@ -438,7 +457,7 @@ hideSomeUnquals rdr_env occs
| Just gres <- lookupOccEnv env occ = extendOccEnv env occ (map qual_gre gres)
| otherwise = env
qual_gre gre@(GRE { gre_name = name, gre_prov = LocalDef })
= GRE { gre_name = name, gre_prov = Imported [imp_spec] }
= gre { gre_prov = Imported [imp_spec] }
where -- Local defs get transfomed to (fake) imported things
mod = moduleName (nameModule name)
imp_spec = ImpSpec { is_item = ImpAll, is_decl = decl_spec }
......
......@@ -857,11 +857,8 @@ instance Outputable n => Outputable (GenAvailInfo n) where
ppr = pprAvail
pprAvail :: Outputable n => GenAvailInfo n -> SDoc
pprAvail (AvailTC n ns) = ppr n <> case {- filter (/= n) -} ns of
[] -> empty
ns' -> braces (hsep (punctuate comma (map ppr ns')))
pprAvail (Avail n) = ppr n
pprAvail (Avail n) = ppr n
pprAvail (AvailTC n ns) = ppr n <> braces (hsep (punctuate comma (map ppr ns)))
\end{code}
\begin{code}
......
......@@ -14,7 +14,7 @@ module RnEnv (
lookupFixityRn, lookupTyFixityRn, lookupLocatedSigOccRn,
lookupLocatedInstDeclBndr,
lookupSyntaxName, lookupSyntaxTable, lookupImportedName,
lookupGreRn,
lookupGreRn, lookupGreRn_maybe,
newLocalsRn, newIPNameRn,
bindLocalNames, bindLocalNamesFV,
......@@ -42,18 +42,17 @@ import RdrName ( RdrName, isQual, isUnqual, isOrig_maybe,
mkRdrUnqual, setRdrNameSpace, rdrNameOcc,
pprGlobalRdrEnv, lookupGRE_RdrName,
isExact_maybe, isSrcRdrName,
Parent(..),
GlobalRdrElt(..), GlobalRdrEnv, lookupGlobalRdrEnv,
isLocalGRE, extendLocalRdrEnv, elemLocalRdrEnv, lookupLocalRdrEnv,
Provenance(..), pprNameProvenance,
importSpecLoc, importSpecModule
)
import HscTypes ( availNames, ModIface(..), FixItem(..), lookupFixity,
AvailInfo, GenAvailInfo(..) )
import HscTypes ( availNames, ModIface(..), FixItem(..), lookupFixity )
import TcRnMonad
import Name ( Name, nameIsLocalOrFrom, mkInternalName, isWiredInName,
nameSrcLoc, nameOccName, nameModule, isExternalName )
import NameSet
import NameEnv ( NameEnv, lookupNameEnv )
import OccName ( tcName, isDataOcc, pprNonVarNameSpace, occNameSpace,
reportIfUnused )
import Module ( Module, ModuleName )
......@@ -201,27 +200,27 @@ lookupLocatedSigOccRn = lookupLocatedBndrRn
-- disambiguate.
lookupLocatedInstDeclBndr :: Name -> Located RdrName -> RnM (Located Name)
lookupLocatedInstDeclBndr cls rdr = do
imp_avails <- getImports
wrapLocM (lookupInstDeclBndr (imp_parent imp_avails) cls) rdr
lookupLocatedInstDeclBndr cls rdr = wrapLocM (lookupInstDeclBndr cls) rdr
lookupInstDeclBndr :: NameEnv AvailInfo -> Name -> RdrName -> RnM Name
lookupInstDeclBndr :: Name -> RdrName -> RnM Name
-- This is called on the method name on the left-hand side of an
-- instance declaration binding. eg. instance Functor T where
-- fmap = ...
-- ^^^^ called on this
-- Regardless of how many unqualified fmaps are in scope, we want
-- the one that comes from the Functor class.
lookupInstDeclBndr availenv cls_name rdr_name
lookupInstDeclBndr cls_name rdr_name
| isUnqual rdr_name -- Find all the things the rdr-name maps to
= do { -- and pick the one with the right parent name
let { is_op gre = cls_name == nameParent (gre_name gre)
let { is_op gre@(GRE {gre_par = ParentIs n}) = cls_name == n
; is_op other = False
; occ = rdrNameOcc rdr_name
; lookup_fn env = filter is_op (lookupGlobalRdrEnv env occ) }
; mb_gre <- lookupGreRn_help rdr_name lookup_fn
; case mb_gre of
Just gre -> return (gre_name gre)
Nothing -> do { addErr (unknownInstBndrErr cls_name rdr_name)
; traceRn (text "lookupInstDeclBndr" <+> ppr rdr_name)
; return (mkUnboundName rdr_name) } }
| otherwise -- Occurs in derived instances, where we just
......@@ -230,12 +229,6 @@ lookupInstDeclBndr availenv cls_name rdr_name
-- NB: qualified names are rejected by the parser
lookupImportedName rdr_name
where nameParent nm
| Just (AvailTC tc subs) <- lookupNameEnv availenv nm = tc
| otherwise = nm -- might be an Avail, if the Name is
-- in scope some other way
newIPNameRn :: IPName RdrName -> TcRnIf m n (IPName Name)
newIPNameRn ip_rdr = newIPName (mapIPName rdrNameOcc ip_rdr)
......@@ -256,7 +249,7 @@ lookupFamInstDeclBndr mod lrdr_name@(L _ rdr_name)
| otherwise
= -- First look up the name in the normal environment.
lookupGreRn rdr_name `thenM` \ mb_gre ->
lookupGreRn_maybe rdr_name `thenM` \ mb_gre ->
case mb_gre of {
Just gre -> returnM (gre_name gre) ;
Nothing -> newTopSrcBinder mod lrdr_name }
......@@ -291,7 +284,7 @@ lookupGlobalOccRn rdr_name
| otherwise
= -- First look up the name in the normal environment.
lookupGreRn rdr_name `thenM` \ mb_gre ->
lookupGreRn_maybe rdr_name `thenM` \ mb_gre ->
case mb_gre of {
Just gre -> returnM (gre_name gre) ;
Nothing ->
......@@ -342,17 +335,28 @@ unboundName rdr_name
lookupSrcOcc_maybe :: RdrName -> RnM (Maybe Name)
-- No filter function; does not report an error on failure
lookupSrcOcc_maybe rdr_name
= do { mb_gre <- lookupGreRn rdr_name
= do { mb_gre <- lookupGreRn_maybe rdr_name
; case mb_gre of
Nothing -> returnM Nothing
Just gre -> returnM (Just (gre_name gre)) }
-------------------------
lookupGreRn :: RdrName -> RnM (Maybe GlobalRdrElt)
lookupGreRn_maybe :: RdrName -> RnM (Maybe GlobalRdrElt)
-- Just look up the RdrName in the GlobalRdrEnv
lookupGreRn rdr_name
lookupGreRn_maybe rdr_name
= lookupGreRn_help rdr_name (lookupGRE_RdrName rdr_name)
lookupGreRn :: RdrName -> RnM GlobalRdrElt
-- If not found, add error message, and return a fake GRE
lookupGreRn rdr_name
= do { mb_gre <- lookupGreRn_maybe rdr_name
; case mb_gre of {
Just gre -> return gre ;
Nothing -> do
{ name <- unboundName rdr_name
; return (GRE { gre_name = name, gre_par = NoParent,
gre_prov = LocalDef }) }}}
lookupGreLocalRn :: RdrName -> RnM (Maybe GlobalRdrElt)
-- Similar, but restricted to locally-defined things
lookupGreLocalRn rdr_name
......
......@@ -581,7 +581,7 @@ rnBracket (DecBr group)
; let new_occs = map nameOccName names
trimmed_rdr_env = hideSomeUnquals (tcg_rdr_env gbl_env) new_occs
; rdr_env' <- extendRdrEnvRn trimmed_rdr_env names
; rdr_env' <- extendRdrEnvRn trimmed_rdr_env avails
-- In this situation we want to *shadow* top-level bindings.
-- foo = 1
-- bar = [d| foo = 1|]
......
module RnHsDoc ( rnHsDoc, rnLHsDoc, rnMbLHsDoc, rnMbHsDoc ) where
import TcRnMonad ( RnM )
import RnEnv ( dataTcOccs, lookupGreRn )
import RnEnv ( dataTcOccs, lookupGreRn_maybe )
import HsDoc ( HsDoc(..) )
import RdrName ( RdrName, isRdrDataCon, isRdrTc, gre_name )
......@@ -49,7 +49,7 @@ rnHsDoc doc = case doc of
DocIdentifier ids -> do
let choices = concatMap dataTcOccs ids
mb_gres <- mapM lookupGreRn choices
mb_gres <- mapM lookupGreRn_maybe choices
case [gre_name gre | Just gre <- mb_gres] of
[] -> return (DocString (ids2string ids))
ids' -> return (DocIdentifier ids')
......
This diff is collapsed.
......@@ -482,7 +482,7 @@ checkHiBootIface :: TcGblEnv -> ModDetails -> TcM (LHsBinds Id)
checkHiBootIface
(TcGblEnv { tcg_insts = local_insts, tcg_fam_insts = local_fam_insts,
tcg_type_env = local_type_env, tcg_imports = imports })
tcg_type_env = local_type_env })
(ModDetails { md_insts = boot_insts, md_fam_insts = boot_fam_insts,
md_types = boot_type_env })
= do { traceTc (text "checkHiBootIface" <+> (ppr boot_type_env $$ ppr boot_insts)) ;
......@@ -497,8 +497,11 @@ checkHiBootIface
; return (unionManyBags dfun_binds) }
where
check_one boot_thing
| no_check name
= return ()
| isImplicitTyThing boot_thing = return ()
| name `elem` dfun_names = return ()
| isWiredInName name = return () -- No checking for wired-in names. In particular,
-- 'error' is handled by a rather gross hack
-- (see comments in GHC.Err.hs-boot)
| Just real_thing <- lookupTypeEnv local_type_env name
= do { let boot_decl = tyThingToIfaceDecl boot_thing
real_decl = tyThingToIfaceDecl real_thing
......@@ -511,17 +514,6 @@ checkHiBootIface
where
name = getName boot_thing
avail_env = imp_parent imports
is_implicit name = case lookupNameEnv avail_env name of
Just (AvailTC tc _) | tc /= name -> True
_otherwise -> False
no_check name = isWiredInName name -- No checking for wired-in names. In particular,
-- 'error' is handled by a rather gross hack
-- (see comments in GHC.Err.hs-boot)
|| name `elem` dfun_names
|| is_implicit name -- Has a parent, which we'll check
dfun_names = map getName boot_insts
check_inst boot_inst
......
......@@ -47,7 +47,6 @@ import OccName
import Bag
import Outputable
import UniqSupply
import UniqFM
import Unique
import DynFlags
import StaticFlags
......@@ -103,7 +102,7 @@ initTc hsc_env hsc_src mod do_this
tcg_inst_uses = dfuns_var,
tcg_th_used = th_var,
tcg_exports = [],
tcg_imports = init_imports,
tcg_imports = emptyImportAvails,
tcg_dus = emptyDUs,
tcg_rn_imports = Nothing,
tcg_rn_exports = Nothing,
......@@ -149,12 +148,6 @@ initTc hsc_env hsc_src mod do_this
return (msgs, final_res)
}
where
init_imports = emptyImportAvails {imp_env = unitUFM (moduleName mod) []}
-- Initialise tcg_imports with an empty set of bindings for
-- this module, so that if we see 'module M' in the export
-- list, and there are no bindings in M, we don't bleat
-- "unknown module M".
initTcPrintErrors -- Used from the interactive loop only
:: HscEnv
......
......@@ -15,9 +15,6 @@ module TcRnTypes(
-- Ranamer types
ErrCtxt,
ImportAvails(..), emptyImportAvails, plusImportAvails,
plusAvail, pruneAvails,
AvailEnv, emptyAvailEnv, unitAvailEnv, plusAvailEnv,
mkAvailEnv, lookupAvailEnv, lookupAvailEnv_maybe, availEnvElts, addAvail,
WhereFrom(..), mkModDeps,
-- Typechecker types
......@@ -478,22 +475,6 @@ It is used * when processing the export list
\begin{code}
data ImportAvails
= ImportAvails {
imp_env :: ModuleNameEnv [AvailInfo],
-- All the things imported *unqualified*, classified by
-- the *module qualifier* for its import
-- e.g. import List as Foo
-- would add a binding Foo |-> ...stuff from List...
-- to imp_env.
--
-- This is exactly the list of things that will be exported
-- by a 'module M' specifier in the export list.
-- (see Haskell 98 Report Section 5.2).
--
-- Warning: there may be duplciates in this list,
-- duplicates are removed at the use site (rnExports).
-- We might consider turning this into a NameEnv at
-- some point.
imp_mods :: ModuleEnv (Module, Bool, SrcSpan),
-- Domain is all directly-imported modules
-- Bool means:
......@@ -532,15 +513,9 @@ data ImportAvails
-- Orphan modules below us in the import tree (and maybe
-- including us for imported modules)
imp_finsts :: [Module],
imp_finsts :: [Module]
-- Family instance modules below us in the import tree (and
-- maybe including us for imported modules)
imp_parent :: NameEnv AvailInfo
-- for the names in scope in this module, tells us
-- the relationship between parents and children
-- (eg. a TyCon is the parent of its DataCons, a
-- class is the parent of its methods, etc.).
}
mkModDeps :: [(ModuleName, IsBootInterface)]
......@@ -550,109 +525,32 @@ mkModDeps deps = foldl add emptyUFM deps
add env elt@(m,_) = addToUFM env m elt
emptyImportAvails :: ImportAvails
emptyImportAvails = ImportAvails { imp_env = emptyUFM,
imp_mods = emptyModuleEnv,
emptyImportAvails = ImportAvails { imp_mods = emptyModuleEnv,
imp_dep_mods = emptyUFM,
imp_dep_pkgs = [],
imp_orphs = [],
imp_finsts = [],
imp_parent = emptyNameEnv }
imp_finsts = [] }
plusImportAvails :: ImportAvails -> ImportAvails -> ImportAvails
plusImportAvails
(ImportAvails { imp_env = env1, imp_mods = mods1,
(ImportAvails { imp_mods = mods1,
imp_dep_mods = dmods1, imp_dep_pkgs = dpkgs1,
imp_orphs = orphs1, imp_finsts = finsts1,
imp_parent = parent1 })
(ImportAvails { imp_env = env2, imp_mods = mods2,
imp_orphs = orphs1, imp_finsts = finsts1 })
(ImportAvails { imp_mods = mods2,
imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2,
imp_orphs = orphs2, imp_finsts = finsts2,
imp_parent = parent2 })
= ImportAvails { imp_env = plusUFM_C (++) env1 env2,
imp_mods = mods1 `plusModuleEnv` mods2,
imp_orphs = orphs2, imp_finsts = finsts2 })
= ImportAvails { imp_mods = mods1 `plusModuleEnv` mods2,
imp_dep_mods = plusUFM_C plus_mod_dep dmods1 dmods2,
imp_dep_pkgs = dpkgs1 `unionLists` dpkgs2,
imp_orphs = orphs1 `unionLists` orphs2,
imp_finsts = finsts1 `unionLists` finsts2,
imp_parent = plusNameEnv_C plus_avails parent1 parent2 }
imp_finsts = finsts1 `unionLists` finsts2 }
where
plus_avails (AvailTC tc subs1) (AvailTC _ subs2)
= AvailTC tc (nub (subs1 ++ subs2))
plus_avails avail _ = avail
plus_mod_dep (m1, boot1) (m2, boot2)
= WARN( not (m1 == m2), (ppr m1 <+> ppr m2) $$ (ppr boot1 <+> ppr boot2) )
-- Check mod-names match
(m1, boot1 && boot2) -- If either side can "see" a non-hi-boot interface, use that
\end{code}
%************************************************************************
%* *
Avails, AvailEnv, etc
%* *
v%************************************************************************
\begin{code}
plusAvail (Avail n1) (Avail n2) = Avail n1
plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n2 (ns1 `unionLists` ns2)
-- Added SOF 4/97
#ifdef DEBUG
plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2])
#endif
-------------------------
pruneAvails :: (Name -> Bool) -- Keep if this is True
-> [AvailInfo]
-> [AvailInfo]
pruneAvails keep avails
= mapMaybe del avails
where
del :: AvailInfo -> Maybe AvailInfo -- Nothing => nothing left!
del (Avail n) | keep n = Just (Avail n)
| otherwise = Nothing
del (AvailTC n ns) | null ns' = Nothing
| otherwise = Just (AvailTC n ns')
where
ns' = filter keep ns
\end{code}
---------------------------------------
AvailEnv and friends
---------------------------------------
\begin{code}
type AvailEnv = NameEnv AvailInfo -- Maps a Name to the AvailInfo that contains it
emptyAvailEnv :: AvailEnv
emptyAvailEnv = emptyNameEnv
unitAvailEnv :: AvailInfo -> AvailEnv
unitAvailEnv a = unitNameEnv (availName a) a
plusAvailEnv :: AvailEnv -> AvailEnv -> AvailEnv
plusAvailEnv = plusNameEnv_C plusAvail
lookupAvailEnv_maybe :: AvailEnv -> Name -> Maybe AvailInfo
lookupAvailEnv_maybe = lookupNameEnv
lookupAvailEnv :: AvailEnv -> Name -> AvailInfo
lookupAvailEnv env n = case lookupNameEnv env n of
Just avail -> avail
Nothing -> pprPanic "lookupAvailEnv" (ppr n)
availEnvElts = nameEnvElts
addAvail :: AvailEnv -> AvailInfo -> AvailEnv
addAvail avails avail = extendNameEnv_C plusAvail avails (availName avail) avail
mkAvailEnv :: [AvailInfo] -> AvailEnv
-- 'avails' may have several items with the same availName
-- E.g import Ix( Ix(..), index )
-- will give Ix(Ix,index,range) and Ix(index)
-- We want to combine these; addAvail does that
mkAvailEnv avails = foldl addAvail emptyAvailEnv avails
\end{code}
%************************************************************************
%* *
\subsection{Where from}
......
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