X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FRdrName.lhs;h=030aa1f609aa83d31d32811f110be05d66dd4fe3;hb=9d7da331989abcd1844e9d03b8d1e4163796fa85;hp=cc58eb138a64a9ee39ce2895a6bd11e28282694d;hpb=c27ec458271ebbd88ff72a7ae7ad026dd6dcc76e;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/RdrName.lhs b/ghc/compiler/basicTypes/RdrName.lhs index cc58eb1..030aa1f 100644 --- a/ghc/compiler/basicTypes/RdrName.lhs +++ b/ghc/compiler/basicTypes/RdrName.lhs @@ -10,11 +10,9 @@ module RdrName ( -- Construction mkRdrUnqual, mkRdrQual, - mkUnqual, mkVarUnqual, mkQual, mkOrig, mkIfaceOrig, + mkUnqual, mkVarUnqual, mkQual, mkOrig, nameRdrName, getRdrName, - qualifyRdrName, unqualifyRdrName, mkDerivedRdrName, - dummyRdrVarName, dummyRdrTcName, -- Destruction rdrNameModule, rdrNameOcc, setRdrNameSpace, @@ -22,7 +20,6 @@ module RdrName ( isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName, -- Printing; instance Outputable RdrName - pprUnqualRdrName, -- LocalRdrEnv LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, @@ -30,37 +27,30 @@ module RdrName ( -- GlobalRdrEnv GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv, - lookupGlobalRdrEnv, pprGlobalRdrEnv, globalRdrEnvElts, + lookupGlobalRdrEnv, extendGlobalRdrEnv, + pprGlobalRdrEnv, globalRdrEnvElts, lookupGRE_RdrName, lookupGRE_Name, -- GlobalRdrElt, Provenance, ImportSpec - GlobalRdrElt(..), Provenance(..), ImportSpec(..), - isLocalGRE, unQualOK, hasQual, - pprNameProvenance + GlobalRdrElt(..), isLocalGRE, unQualOK, + Provenance(..), pprNameProvenance, + ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..), + importSpecLoc, importSpecModule ) where #include "HsVersions.h" -import OccName ( NameSpace, tcName, varName, - OccName, UserFS, EncodedFS, - mkSysOccFS, setOccNameSpace, - mkOccFS, mkVarOcc, occNameFlavour, - isDataOcc, isTvOcc, isTcOcc, - OccEnv, emptyOccEnv, extendOccEnvList, lookupOccEnv, - elemOccEnv, plusOccEnv_C, extendOccEnv_C, foldOccEnv, - occEnvElts - ) -import Module ( ModuleName, mkSysModuleNameFS, mkModuleNameFS ) -import Name ( Name, NamedThing(getName), nameModuleName, nameParent_maybe, +import OccName +import Module ( Module, mkModuleFS ) +import Name ( Name, NamedThing(getName), nameModule, nameParent_maybe, nameOccName, isExternalName, nameSrcLoc ) -import Maybes ( seqMaybe ) -import SrcLoc ( SrcLoc, isGoodSrcLoc ) -import BasicTypes( DeprecTxt ) +import Maybes ( mapCatMaybes ) +import SrcLoc ( isGoodSrcLoc, SrcSpan ) +import FastString ( FastString ) import Outputable import Util ( thenCmp ) \end{code} - %************************************************************************ %* * \subsection{The main data type} @@ -72,13 +62,13 @@ data RdrName = Unqual OccName -- Used for ordinary, unqualified occurrences - | Qual ModuleName OccName + | Qual Module OccName -- A qualified name written by the user in - -- *source* code. The module isn't necessarily + -- *source* code. The module isn't necessarily -- the module where the thing is defined; -- just the one from which it is imported - | Orig ModuleName OccName + | Orig Module OccName -- An original name; the module is the *defining* module. -- This is used when GHC generates code that will be fed -- into the renamer (e.g. from deriving clauses), but where @@ -91,7 +81,7 @@ data RdrName -- (b) when converting names to the RdrNames in IfaceTypes -- Here an Exact RdrName always contains an External Name -- (Internal Names are converted to simple Unquals) - -- (c) possibly, by the meta-programming stuff + -- (c) by Template Haskell, when TH has generated a unique name \end{code} @@ -102,10 +92,10 @@ data RdrName %************************************************************************ \begin{code} -rdrNameModule :: RdrName -> ModuleName +rdrNameModule :: RdrName -> Module rdrNameModule (Qual m _) = m rdrNameModule (Orig m _) = m -rdrNameModule (Exact n) = nameModuleName n +rdrNameModule (Exact n) = nameModule n rdrNameModule (Unqual n) = pprPanic "rdrNameModule" (ppr n) rdrNameOcc :: RdrName -> OccName @@ -126,7 +116,7 @@ setRdrNameSpace :: RdrName -> NameSpace -> RdrName setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ) setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ) setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ) -setRdrNameSpace (Exact n) ns = Orig (nameModuleName n) +setRdrNameSpace (Exact n) ns = Orig (nameModule n) (setOccNameSpace ns (nameOccName n)) \end{code} @@ -135,31 +125,28 @@ setRdrNameSpace (Exact n) ns = Orig (nameModuleName n) mkRdrUnqual :: OccName -> RdrName mkRdrUnqual occ = Unqual occ -mkRdrQual :: ModuleName -> OccName -> RdrName +mkRdrQual :: Module -> OccName -> RdrName mkRdrQual mod occ = Qual mod occ -mkOrig :: ModuleName -> OccName -> RdrName +mkOrig :: Module -> OccName -> RdrName mkOrig mod occ = Orig mod occ -mkIfaceOrig :: NameSpace -> EncodedFS -> EncodedFS -> RdrName -mkIfaceOrig ns m n = Orig (mkSysModuleNameFS m) (mkSysOccFS ns n) - --------------- mkDerivedRdrName :: Name -> (OccName -> OccName) -> (RdrName) mkDerivedRdrName parent mk_occ - = mkOrig (nameModuleName parent) (mk_occ (nameOccName parent)) + = mkOrig (nameModule parent) (mk_occ (nameOccName parent)) --------------- -- These two are used when parsing source files -- They do encode the module and occurrence names -mkUnqual :: NameSpace -> UserFS -> RdrName -mkUnqual sp n = Unqual (mkOccFS sp n) +mkUnqual :: NameSpace -> FastString -> RdrName +mkUnqual sp n = Unqual (mkOccNameFS sp n) -mkVarUnqual :: UserFS -> RdrName -mkVarUnqual n = Unqual (mkOccFS varName n) +mkVarUnqual :: FastString -> RdrName +mkVarUnqual n = Unqual (mkVarOccFS n) -mkQual :: NameSpace -> (UserFS, UserFS) -> RdrName -mkQual sp (m, n) = Qual (mkModuleNameFS m) (mkOccFS sp n) +mkQual :: NameSpace -> (FastString, FastString) -> RdrName +mkQual sp (m, n) = Qual (mkModuleFS m) (mkOccNameFS sp n) getRdrName :: NamedThing thing => thing -> RdrName getRdrName name = nameRdrName (getName name) @@ -170,31 +157,13 @@ nameRdrName name = Exact name -- unique is still there for debug printing, particularly -- of Types (which are converted to IfaceTypes before printing) -qualifyRdrName :: ModuleName -> RdrName -> RdrName - -- Sets the module name of a RdrName, even if it has one already -qualifyRdrName mod rn = Qual mod (rdrNameOcc rn) - -unqualifyRdrName :: RdrName -> RdrName -unqualifyRdrName rdr_name = Unqual (rdrNameOcc rdr_name) - nukeExact :: Name -> RdrName nukeExact n - | isExternalName n = Orig (nameModuleName n) (nameOccName n) + | isExternalName n = Orig (nameModule n) (nameOccName n) | otherwise = Unqual (nameOccName n) \end{code} \begin{code} - -- This guy is used by the reader when HsSyn has a slot for - -- an implicit name that's going to be filled in by - -- the renamer. We can't just put "error..." because - -- we sometimes want to print out stuff after reading but - -- before renaming -dummyRdrVarName = Unqual (mkVarOcc FSLIT("V-DUMMY")) -dummyRdrTcName = Unqual (mkOccFS tcName FSLIT("TC-DUMMY")) -\end{code} - - -\begin{code} isRdrDataCon rn = isDataOcc (rdrNameOcc rn) isRdrTyVar rn = isTvOcc (rdrNameOcc rn) isRdrTc rn = isTcOcc (rdrNameOcc rn) @@ -236,15 +205,13 @@ instance Outputable RdrName where ppr (Qual mod occ) = ppr mod <> dot <> ppr occ <+> ppr_name_space occ ppr (Orig mod occ) = ppr mod <> dot <> ppr occ <+> ppr_name_space occ -ppr_name_space occ = ifPprDebug (parens (text (occNameFlavour occ))) +ppr_name_space occ = ifPprDebug (parens (pprNonVarNameSpace (occNameSpace occ))) instance OutputableBndr RdrName where pprBndr _ n | isTvOcc (rdrNameOcc n) = char '@' <+> ppr n | otherwise = ppr n -pprUnqualRdrName rdr_name = ppr (rdrNameOcc rdr_name) - instance Eq RdrName where (Exact n1) == (Exact n2) = n1==n2 -- Convert exact to orig @@ -262,21 +229,28 @@ instance Ord RdrName where a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } - -- Unqual < Qual < Orig - -- We always convert Exact to Orig before comparing - compare (Exact n1) (Exact n2) | n1==n2 = EQ -- Short cut - | otherwise = nukeExact n1 `compare` nukeExact n2 - compare (Exact n1) n2 = nukeExact n1 `compare` n2 - compare n1 (Exact n2) = n1 `compare` nukeExact n2 - - - compare (Qual m1 o1) (Qual m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2) - compare (Orig m1 o1) (Orig m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2) + -- Exact < Unqual < Qual < Orig + -- [Note: Apr 2004] We used to use nukeExact to convert Exact to Orig + -- before comparing so that Prelude.map == the exact Prelude.map, but + -- that meant that we reported duplicates when renaming bindings + -- generated by Template Haskell; e.g + -- do { n1 <- newName "foo"; n2 <- newName "foo"; + -- } + -- I think we can do without this conversion + compare (Exact n1) (Exact n2) = n1 `compare` n2 + compare (Exact n1) n2 = LT + + compare (Unqual _) (Exact _) = GT compare (Unqual o1) (Unqual o2) = o1 `compare` o2 - compare (Unqual _) _ = LT + + compare (Qual _ _) (Exact _) = GT + compare (Qual _ _) (Unqual _) = GT + compare (Qual m1 o1) (Qual m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2) compare (Qual _ _) (Orig _ _) = LT - compare _ _ = GT + + compare (Orig m1 o1) (Orig m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2) + compare (Orig _ _) _ = GT \end{code} @@ -300,9 +274,9 @@ extendLocalRdrEnv env names = extendOccEnvList env [(nameOccName n, n) | n <- names] lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name -lookupLocalRdrEnv env rdr_name - | isUnqual rdr_name = lookupOccEnv env (rdrNameOcc rdr_name) - | otherwise = Nothing +lookupLocalRdrEnv env (Exact name) = Just name +lookupLocalRdrEnv env (Unqual occ) = lookupOccEnv env occ +lookupLocalRdrEnv env other = Nothing elemLocalRdrEnv :: RdrName -> LocalRdrEnv -> Bool elemLocalRdrEnv rdr_name env @@ -338,8 +312,7 @@ globalRdrEnvElts env = foldOccEnv (++) [] env data GlobalRdrElt = GRE { gre_name :: Name, - gre_prov :: Provenance, -- Why it's in scope - gre_deprec :: Maybe DeprecTxt -- Whether this name is deprecated + gre_prov :: Provenance -- Why it's in scope } instance Outputable GlobalRdrElt where @@ -365,15 +338,17 @@ lookupGlobalRdrEnv env rdr_name = case lookupOccEnv env rdr_name of Nothing -> [] Just gres -> gres +extendGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrElt -> GlobalRdrEnv +extendGlobalRdrEnv env gre = extendOccEnv_C add env occ [gre] + where + occ = nameOccName (gre_name gre) + add gres _ = gre:gres + lookupGRE_RdrName :: RdrName -> GlobalRdrEnv -> [GlobalRdrElt] lookupGRE_RdrName rdr_name env - = case lookupOccEnv env occ of - Nothing -> [] - Just gres | isUnqual rdr_name -> filter unQualOK gres - | otherwise -> filter (hasQual mod) gres - where - mod = rdrNameModule rdr_name - occ = rdrNameOcc rdr_name + = case lookupOccEnv env (rdrNameOcc rdr_name) of + Nothing -> [] + Just gres -> pickGREs rdr_name gres lookupGRE_Name :: GlobalRdrEnv -> Name -> [GlobalRdrElt] lookupGRE_Name env name @@ -381,19 +356,51 @@ lookupGRE_Name env name gre_name gre == name ] +pickGREs :: RdrName -> [GlobalRdrElt] -> [GlobalRdrElt] +-- Take a list of GREs which have the right OccName +-- Pick those GREs that are suitable for this RdrName +-- And for those, keep only only the Provenances that are suitable +-- +-- Consider +-- module A ( f ) where +-- import qualified Foo( f ) +-- import Baz( f ) +-- f = undefined +-- Let's suppose that Foo.f and Baz.f are the same entity really. +-- The export of f is ambiguous because it's in scope from the local def +-- and the import. The lookup of (Unqual f) should return a GRE for +-- 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 + = mapCatMaybes pick gres + where + is_unqual = isUnqual rdr_name + mod = rdrNameModule 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 + 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 + 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 + isLocalGRE :: GlobalRdrElt -> Bool -isLocalGRE (GRE {gre_prov = LocalDef _}) = True -isLocalGRE other = False +isLocalGRE (GRE {gre_prov = LocalDef}) = True +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) - -hasQual :: ModuleName -> GlobalRdrElt -> Bool --- A qualified version of this thing is in scope -hasQual mod (GRE {gre_prov = LocalDef m}) = m == mod -hasQual mod (GRE {gre_prov = Imported is _}) = any ((== mod) . is_as) is +unQualOK (GRE {gre_prov = LocalDef}) = True +unQualOK (GRE {gre_prov = Imported is}) = not (all (is_qual . is_decl) is) plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv plusGlobalRdrEnv env1 env2 = plusOccEnv_C (foldr insertGRE) env1 env2 @@ -417,11 +424,8 @@ insertGRE new_g (old_g : old_gs) 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_deprec = gre_deprec g1 `seqMaybe` gre_deprec g2 } - -- Could the deprecs be different? If we re-export - -- something deprecated, is it propagated? I forget. + = GRE { gre_name = gre_name g1, + gre_prov = gre_prov g1 `plusProv` gre_prov g2 } \end{code} @@ -432,52 +436,76 @@ plusGRE g1 g2 %************************************************************************ The "provenance" of something says how it came to be in scope. +It's quite elaborate so that we can give accurate unused-name warnings. \begin{code} data Provenance = LocalDef -- Defined locally - ModuleName - | Imported -- Imported [ImportSpec] -- INVARIANT: non-empty - Bool -- True iff the thing was named *explicitly* - -- in *any* of the import specs rather than being - -- imported as part of a group; - -- e.g. - -- import B - -- import C( T(..) ) - -- Here, everything imported by B, and the constructors of T - -- are not named explicitly; only T is named explicitly. - -- This info is used when warning of unused names. - -data ImportSpec -- Describes a particular import declaration - -- Shared among all the Provenaces for a particular - -- import declaration - = ImportSpec { - is_mod :: ModuleName, -- 'import Muggle' - -- Note the Muggle may well not be - -- the defining module for this thing! - is_as :: ModuleName, -- 'as M' (or 'Muggle' if there is no 'as' clause) - is_qual :: Bool, -- True <=> qualified (only) - is_loc :: SrcLoc } -- Location of import statment +data ImportSpec = ImpSpec { is_decl :: ImpDeclSpec, + is_item :: ImpItemSpec } + deriving( Eq, Ord ) + +data ImpDeclSpec -- Describes a particular import declaration + -- Shared among all the Provenaces for that decl + = ImpDeclSpec { + is_mod :: Module, -- '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) + is_qual :: Bool, -- True <=> qualified (only) + is_dloc :: SrcSpan -- Location of import declaration + } + +data ImpItemSpec -- Describes import info a particular Name + = ImpAll -- The import had no import list, + -- or had a hiding list + + | ImpSome { -- The import had an import list + is_explicit :: Bool, + is_iloc :: SrcSpan -- Location of the import item + } + -- The is_explicit field is True iff the thing was named + -- *explicitly* in the import specs rather + -- than being imported as part of a "..." group + -- e.g. import C( T(..) ) + -- Here the constructors of T are not named explicitly; + -- only T is named explicitly. + +importSpecLoc :: ImportSpec -> SrcSpan +importSpecLoc (ImpSpec decl ImpAll) = is_dloc decl +importSpecLoc (ImpSpec _ item) = is_iloc item + +importSpecModule :: ImportSpec -> Module +importSpecModule is = is_mod (is_decl is) + +-- Note [Comparing provenance] -- Comparison of provenance is just used for grouping -- error messages (in RnEnv.warnUnusedBinds) instance Eq Provenance where p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False -instance Eq ImportSpec where +instance Eq ImpDeclSpec where + p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False + +instance Eq ImpItemSpec where p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False instance Ord Provenance where - compare (LocalDef _) (LocalDef _) = EQ - compare (LocalDef _) (Imported _ _) = LT - compare (Imported _ _) (LocalDef _) = GT - compare (Imported is1 _) (Imported is2 _) = compare (head is1) (head is2) + compare LocalDef LocalDef = EQ + compare LocalDef (Imported _) = LT + compare (Imported _ ) LocalDef = GT + compare (Imported is1) (Imported is2) = compare (head is1) + {- See Note [Comparing provenance] -} (head is2) -instance Ord ImportSpec where +instance Ord ImpDeclSpec where compare is1 is2 = (is_mod is1 `compare` is_mod is2) `thenCmp` - (is_loc is1 `compare` is_loc is2) + (is_dloc is1 `compare` is_dloc is2) + +instance Ord ImpItemSpec where + compare is1 is2 = is_iloc is1 `compare` is_iloc is2 \end{code} \begin{code} @@ -488,23 +516,25 @@ plusProv :: Provenance -> Provenance -> Provenance -- defined, and one might refer to it with a qualified name from -- the import -- but I'm going to ignore that because it makes -- the isLocalGRE predicate so much nicer this way -plusProv (LocalDef m1) (LocalDef m2) - = pprPanic "plusProv" (ppr m1 <+> ppr m2) -plusProv p1@(LocalDef _) p2 = p1 -plusProv p1 p2@(LocalDef _) = p2 -plusProv (Imported is1 ex1) (Imported is2 ex2) - = Imported (is1++is2) (ex1 || ex2) +plusProv LocalDef LocalDef = panic "plusProv" +plusProv LocalDef p2 = LocalDef +plusProv p1 LocalDef = LocalDef +plusProv (Imported is1) (Imported is2) = Imported (is1++is2) pprNameProvenance :: GlobalRdrElt -> SDoc -pprNameProvenance (GRE {gre_name = name, gre_prov = LocalDef _}) +-- 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_reason why, nest 2 (ppr_defn (nameSrcLoc name))] - -ppr_reason imp_spec - = ptext SLIT("imported from") <+> ppr (is_mod imp_spec) - <+> ptext SLIT("at") <+> ppr (is_loc imp_spec) +pprNameProvenance (GRE {gre_name = name, gre_prov = Imported (why:whys)}) + = sep [ppr why, nest 2 (ppr_defn (nameSrcLoc name))] +-- 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". 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) \end{code}