X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FbasicTypes%2FRdrName.lhs;h=8729f4748b2b3d84e89207de7d3e7ac5bfc0e7ab;hp=79654491102ee5bcaf970d5e0a16b03eb2436198;hb=9da4639011348fb6c318e3cba4b08622f811d9c4;hpb=658e99a85870d02c734d78e488e963da107133ff diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs index 7965449..8729f47 100644 --- a/compiler/basicTypes/RdrName.lhs +++ b/compiler/basicTypes/RdrName.lhs @@ -15,8 +15,8 @@ module RdrName ( mkDerivedRdrName, -- Destruction - rdrNameModule, rdrNameOcc, setRdrNameSpace, - isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isUnqual, + rdrNameOcc, setRdrNameSpace, + isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isQual_maybe, isUnqual, isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName, -- Printing; instance Outputable RdrName @@ -29,7 +29,7 @@ module RdrName ( GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv, lookupGlobalRdrEnv, extendGlobalRdrEnv, pprGlobalRdrEnv, globalRdrEnvElts, - lookupGRE_RdrName, lookupGRE_Name, + lookupGRE_RdrName, lookupGRE_Name, hideSomeUnquals, -- GlobalRdrElt, Provenance, ImportSpec GlobalRdrElt(..), isLocalGRE, unQualOK, @@ -41,11 +41,11 @@ module RdrName ( #include "HsVersions.h" import OccName -import Module ( Module, mkModuleFS ) +import Module ( ModuleName, mkModuleNameFS, Module, moduleName ) import Name ( Name, NamedThing(getName), nameModule, nameParent_maybe, nameOccName, isExternalName, nameSrcLoc ) import Maybes ( mapCatMaybes ) -import SrcLoc ( isGoodSrcLoc, SrcSpan ) +import SrcLoc ( isGoodSrcLoc, isGoodSrcSpan, srcLocSpan, SrcSpan ) import FastString ( FastString ) import Outputable import Util ( thenCmp ) @@ -62,7 +62,7 @@ data RdrName = Unqual OccName -- Used for ordinary, unqualified occurrences - | Qual Module OccName + | Qual ModuleName OccName -- A qualified name written by the user in -- *source* code. The module isn't necessarily -- the module where the thing is defined; @@ -92,12 +92,6 @@ data RdrName %************************************************************************ \begin{code} -rdrNameModule :: RdrName -> Module -rdrNameModule (Qual m _) = m -rdrNameModule (Orig m _) = m -rdrNameModule (Exact n) = nameModule n -rdrNameModule (Unqual n) = pprPanic "rdrNameModule" (ppr n) - rdrNameOcc :: RdrName -> OccName rdrNameOcc (Qual _ occ) = occ rdrNameOcc (Unqual occ) = occ @@ -125,7 +119,7 @@ setRdrNameSpace (Exact n) ns = Orig (nameModule n) mkRdrUnqual :: OccName -> RdrName mkRdrUnqual occ = Unqual occ -mkRdrQual :: Module -> OccName -> RdrName +mkRdrQual :: ModuleName -> OccName -> RdrName mkRdrQual mod occ = Qual mod occ mkOrig :: Module -> OccName -> RdrName @@ -146,7 +140,7 @@ mkVarUnqual :: FastString -> RdrName mkVarUnqual n = Unqual (mkVarOccFS n) mkQual :: NameSpace -> (FastString, FastString) -> RdrName -mkQual sp (m, n) = Qual (mkModuleFS m) (mkOccNameFS sp n) +mkQual sp (m, n) = Qual (mkModuleNameFS m) (mkOccNameFS sp n) getRdrName :: NamedThing thing => thing -> RdrName getRdrName name = nameRdrName (getName name) @@ -178,6 +172,9 @@ isUnqual other = False isQual (Qual _ _) = True isQual _ = False +isQual_maybe (Qual m n) = Just (m,n) +isQual_maybe _ = Nothing + isOrig (Orig _ _) = True isOrig _ = False @@ -372,24 +369,31 @@ pickGREs :: RdrName -> [GlobalRdrElt] -> [GlobalRdrElt] pickGREs rdr_name gres = mapCatMaybes pick gres where - is_unqual = isUnqual rdr_name - mod = rdrNameModule rdr_name + rdr_is_unqual = isUnqual rdr_name + rdr_is_qual = isQual_maybe rdr_name pick :: GlobalRdrElt -> Maybe GlobalRdrElt pick gre@(GRE {gre_prov = LocalDef, gre_name = n}) -- Local def - | is_unqual || nameModule n == mod = Just gre - | otherwise = Nothing + | rdr_is_unqual = Just gre + | Just (mod,_) <- rdr_is_qual, + mod == moduleName (nameModule n) = Just gre + | otherwise = Nothing pick gre@(GRE {gre_prov = Imported [is]}) -- Single import (efficiency) - | is_unqual = if not (is_qual (is_decl is)) then Just gre - else Nothing - | otherwise = if mod == is_as (is_decl is) then Just gre - else Nothing + | rdr_is_unqual, + not (is_qual (is_decl is)) = Just gre + | Just (mod,_) <- rdr_is_qual, + mod == is_as (is_decl is) = Just gre + | otherwise = Nothing pick gre@(GRE {gre_prov = Imported is}) -- Multiple import | null filtered_is = Nothing | otherwise = Just (gre {gre_prov = Imported filtered_is}) where - filtered_is | is_unqual = filter (not . is_qual . is_decl) is - | otherwise = filter ((== mod) . is_as . is_decl) is + filtered_is | rdr_is_unqual + = filter (not . is_qual . is_decl) is + | Just (mod,_) <- rdr_is_qual + = filter ((== mod) . is_as . is_decl) is + | otherwise + = [] isLocalGRE :: GlobalRdrElt -> Bool isLocalGRE (GRE {gre_prov = LocalDef}) = True @@ -424,6 +428,35 @@ plusGRE :: GlobalRdrElt -> GlobalRdrElt -> GlobalRdrElt plusGRE g1 g2 = GRE { gre_name = gre_name g1, gre_prov = gre_prov g1 `plusProv` gre_prov g2 } + +hideSomeUnquals :: GlobalRdrEnv -> [OccName] -> GlobalRdrEnv +-- Hide any unqualified bindings for the specified OccNames +-- This is used in TH, when renaming a declaration bracket +-- [d| foo = ... |] +-- We want unqualified 'foo' in "..." to mean this foo, not +-- the one from the enclosing module. But the *qualified* name +-- from the enclosing moudule must certainly still be avaialable +-- Seems like 5 times as much work as it deserves! +hideSomeUnquals rdr_env occs + = foldr hide rdr_env occs + where + hide occ env + | 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] } + where -- Local defs get transfomed to (fake) imported things + mod = 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, + 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} @@ -449,10 +482,12 @@ data ImportSpec = ImpSpec { is_decl :: ImpDeclSpec, data ImpDeclSpec -- Describes a particular import declaration -- Shared among all the Provenaces for that decl = ImpDeclSpec { - is_mod :: Module, -- 'import Muggle' + is_mod :: ModuleName, -- 'import Muggle' -- Note the Muggle may well not be -- the defining module for this thing! - is_as :: Module, -- 'as M' (or 'Muggle' if there is no 'as' clause) + -- TODO: either should be Module, or there + -- should be a Maybe PackageId here too. + is_as :: ModuleName, -- 'as M' (or 'Muggle' if there is no 'as' clause) is_qual :: Bool, -- True <=> qualified (only) is_dloc :: SrcSpan -- Location of import declaration } @@ -476,7 +511,7 @@ importSpecLoc :: ImportSpec -> SrcSpan importSpecLoc (ImpSpec decl ImpAll) = is_dloc decl importSpecLoc (ImpSpec _ item) = is_iloc item -importSpecModule :: ImportSpec -> Module +importSpecModule :: ImportSpec -> ModuleName importSpecModule is = is_mod (is_decl is) -- Note [Comparing provenance] @@ -523,8 +558,10 @@ pprNameProvenance :: GlobalRdrElt -> SDoc -- Print out the place where the name was imported pprNameProvenance (GRE {gre_name = name, gre_prov = LocalDef}) = ptext SLIT("defined at") <+> ppr (nameSrcLoc name) -pprNameProvenance (GRE {gre_name = name, gre_prov = Imported (why:whys)}) - = sep [ppr why, nest 2 (ppr_defn (nameSrcLoc name))] +pprNameProvenance (GRE {gre_name = name, gre_prov = Imported whys}) + = case whys of + (why:whys) -> sep [ppr why, nest 2 (ppr_defn (nameSrcLoc name))] + [] -> panic "pprNameProvenance" -- If we know the exact definition point (which we may do with GHCi) -- then show that too. But not if it's just "imported from X". @@ -532,7 +569,10 @@ ppr_defn loc | isGoodSrcLoc loc = parens (ptext SLIT("defined at") <+> ppr loc) | otherwise = empty instance Outputable ImportSpec where - ppr imp_spec@(ImpSpec imp_decl _) - = ptext SLIT("imported from") <+> ppr (is_mod imp_decl) - <+> ptext SLIT("at") <+> ppr (importSpecLoc imp_spec) + ppr imp_spec + = ptext SLIT("imported from") <+> ppr (importSpecModule imp_spec) + <+> if isGoodSrcSpan loc then ptext SLIT("at") <+> ppr loc + else empty + where + loc = importSpecLoc imp_spec \end{code}