X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FRdrName.lhs;h=c4d71caa32655c58918c1ba79c982a526f7c9478;hb=ef5b4b146aa172d8ac10f39b5eb3d7a0f948d8f1;hp=7ad104e958fdbe168c74a98020bd437073b05031;hpb=6d1815b09469c68c9d15b253745876403c7fb084;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/RdrName.lhs b/ghc/compiler/basicTypes/RdrName.lhs index 7ad104e..c4d71ca 100644 --- a/ghc/compiler/basicTypes/RdrName.lhs +++ b/ghc/compiler/basicTypes/RdrName.lhs @@ -6,39 +6,51 @@ \begin{code} module RdrName ( - RdrName, + RdrName(..), -- Constructors exported only to BinIface -- Construction - mkRdrUnqual, mkRdrQual, mkRdrOrig, mkRdrUnqual, - mkUnqual, mkQual, mkIfaceOrig, mkOrig, - qualifyRdrName, unqualifyRdrName, mkRdrNameWkr, - dummyRdrVarName, dummyRdrTcName, + mkRdrUnqual, mkRdrQual, + mkUnqual, mkVarUnqual, mkQual, mkOrig, + nameRdrName, getRdrName, + mkDerivedRdrName, -- Destruction - rdrNameModule, rdrNameOcc, setRdrNameOcc, - isRdrDataCon, isRdrTyVar, isQual, isUnqual, isOrig, - - -- Environment - RdrNameEnv, - emptyRdrEnv, lookupRdrEnv, addListToRdrEnv, rdrEnvElts, - extendRdrEnv, rdrEnvToList, elemRdrEnv, foldRdrEnv, + rdrNameModule, rdrNameOcc, setRdrNameSpace, + isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isUnqual, + isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName, -- Printing; instance Outputable RdrName - pprUnqualRdrName + + -- LocalRdrEnv + LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, + lookupLocalRdrEnv, elemLocalRdrEnv, + + -- GlobalRdrEnv + GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv, + lookupGlobalRdrEnv, pprGlobalRdrEnv, globalRdrEnvElts, + lookupGRE_RdrName, lookupGRE_Name, + + -- GlobalRdrElt, Provenance, ImportSpec + GlobalRdrElt(..), Provenance(..), ImportSpec(..), + isLocalGRE, unQualOK, + pprNameProvenance ) where #include "HsVersions.h" -import OccName ( NameSpace, tcName, - OccName, UserFS, EncodedFS, - mkSysOccFS, - mkOccFS, mkVarOcc, - isDataOcc, isTvOcc, mkWorkerOcc - ) -import Module ( ModuleName, - mkSysModuleNameFS, mkModuleNameFS +import OccName ( NameSpace, varName, + OccName, UserFS, + setOccNameSpace, + mkOccFS, occNameFlavour, + isDataOcc, isTvOcc, isTcOcc, + OccEnv, emptyOccEnv, extendOccEnvList, lookupOccEnv, + elemOccEnv, plusOccEnv_C, extendOccEnv_C, foldOccEnv, + occEnvElts ) -import FiniteMap +import Module ( Module, mkModuleFS ) +import Name ( Name, NamedThing(getName), nameModule, nameParent_maybe, + nameOccName, isExternalName, nameSrcLoc ) +import SrcLoc ( isGoodSrcLoc, SrcSpan ) import Outputable import Util ( thenCmp ) \end{code} @@ -51,17 +63,30 @@ import Util ( thenCmp ) %************************************************************************ \begin{code} -data RdrName = RdrName Qual OccName - -data Qual = Unqual - - | Qual ModuleName -- A qualified name written by the user in source code - -- The module isn't necessarily the module where - -- the thing is defined; just the one from which it - -- is imported - - | Orig ModuleName -- This is an *original* name; the module is the place - -- where the thing was defined +data RdrName + = Unqual OccName + -- Used for ordinary, unqualified occurrences + + | Qual Module OccName + -- A qualified name written by the user in + -- *source* code. The module isn't necessarily + -- the module where the thing is defined; + -- just the one from which it is imported + + | 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 + -- we want to say "Use Prelude.map dammit". + + | Exact Name + -- We know exactly the Name. This is used + -- (a) when the parser parses built-in syntax like "[]" + -- and "(,)", but wants a RdrName from it + -- (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) by Template Haskell, when TH has generated a unique name \end{code} @@ -72,77 +97,103 @@ data Qual = Unqual %************************************************************************ \begin{code} -rdrNameModule :: RdrName -> ModuleName -rdrNameModule (RdrName (Qual m) _) = m -rdrNameModule (RdrName (Orig m) _) = m +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 (RdrName _ occ) = occ - -setRdrNameOcc :: RdrName -> OccName -> RdrName -setRdrNameOcc (RdrName q _) occ = RdrName q occ +rdrNameOcc (Qual _ occ) = occ +rdrNameOcc (Unqual occ) = occ +rdrNameOcc (Orig _ occ) = occ +rdrNameOcc (Exact name) = nameOccName name + +setRdrNameSpace :: RdrName -> NameSpace -> RdrName +-- This rather gruesome function is used mainly by the parser +-- When parsing data T a = T | T1 Int +-- we parse the data constructors as *types* because of parser ambiguities, +-- so then we need to change the *type constr* to a *data constr* +-- +-- The original-name case *can* occur when parsing +-- data [] a = [] | a : [a] +-- For the orig-name case we return an unqualified name. +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 (nameModule n) + (setOccNameSpace ns (nameOccName n)) \end{code} \begin{code} -- These two are the basic constructors mkRdrUnqual :: OccName -> RdrName -mkRdrUnqual occ = RdrName Unqual occ +mkRdrUnqual occ = Unqual occ -mkRdrQual :: ModuleName -> OccName -> RdrName -mkRdrQual mod occ = RdrName (Qual mod) occ +mkRdrQual :: Module -> OccName -> RdrName +mkRdrQual mod occ = Qual mod occ -mkRdrOrig :: ModuleName -> OccName -> RdrName -mkRdrOrig mod occ = RdrName (Orig mod) occ - -mkIfaceOrig :: NameSpace -> (EncodedFS, EncodedFS) -> RdrName -mkIfaceOrig ns (m,n) = RdrName (Orig (mkSysModuleNameFS m)) (mkSysOccFS ns n) +mkOrig :: Module -> OccName -> RdrName +mkOrig mod occ = Orig mod occ +--------------- +mkDerivedRdrName :: Name -> (OccName -> OccName) -> (RdrName) +mkDerivedRdrName parent mk_occ + = 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 = RdrName Unqual (mkOccFS sp n) +mkUnqual sp n = Unqual (mkOccFS sp n) -mkQual :: NameSpace -> (UserFS, UserFS) -> RdrName -mkQual sp (m, n) = RdrName (Qual (mkModuleNameFS m)) (mkOccFS sp n) +mkVarUnqual :: UserFS -> RdrName +mkVarUnqual n = Unqual (mkOccFS varName n) -mkOrig :: NameSpace -> ModuleName -> UserFS -> RdrName -mkOrig sp mod n = RdrName (Orig mod) (mkOccFS sp n) +mkQual :: NameSpace -> (UserFS, UserFS) -> RdrName +mkQual sp (m, n) = Qual (mkModuleFS m) (mkOccFS sp n) -qualifyRdrName :: ModuleName -> RdrName -> RdrName - -- Sets the module name of a RdrName, even if it has one already -qualifyRdrName mod (RdrName _ occ) = RdrName (Qual mod) occ +getRdrName :: NamedThing thing => thing -> RdrName +getRdrName name = nameRdrName (getName name) -unqualifyRdrName :: RdrName -> RdrName -unqualifyRdrName (RdrName _ occ) = RdrName Unqual occ +nameRdrName :: Name -> RdrName +nameRdrName name = Exact name +-- Keep the Name even for Internal names, so that the +-- unique is still there for debug printing, particularly +-- of Types (which are converted to IfaceTypes before printing) -mkRdrNameWkr :: RdrName -> RdrName -- Worker-ify it -mkRdrNameWkr (RdrName qual occ) = RdrName qual (mkWorkerOcc occ) +nukeExact :: Name -> RdrName +nukeExact 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 = RdrName Unqual (mkVarOcc SLIT("V-DUMMY")) -dummyRdrTcName = RdrName Unqual (mkOccFS tcName SLIT("TC-DUMMY")) -\end{code} +isRdrDataCon rn = isDataOcc (rdrNameOcc rn) +isRdrTyVar rn = isTvOcc (rdrNameOcc rn) +isRdrTc rn = isTcOcc (rdrNameOcc rn) +isSrcRdrName (Unqual _) = True +isSrcRdrName (Qual _ _) = True +isSrcRdrName _ = False -\begin{code} -isRdrDataCon (RdrName _ occ) = isDataOcc occ -isRdrTyVar (RdrName _ occ) = isTvOcc occ +isUnqual (Unqual _) = True +isUnqual other = False + +isQual (Qual _ _) = True +isQual _ = False -isUnqual (RdrName Unqual _) = True -isUnqual other = False +isOrig (Orig _ _) = True +isOrig _ = False -isQual (RdrName (Qual _) _) = True -isQual _ = False +isOrig_maybe (Orig m n) = Just (m,n) +isOrig_maybe _ = Nothing -isOrig (RdrName (Orig _) _) = True -isOrig other = False +isExact (Exact _) = True +isExact other = False + +isExact_maybe (Exact n) = Just n +isExact_maybe other = Nothing \end{code} @@ -154,17 +205,28 @@ isOrig other = False \begin{code} instance Outputable RdrName where - ppr (RdrName qual occ) = pp_qual qual <> ppr occ - where - pp_qual Unqual = empty - pp_qual (Qual mod) = ppr mod <> dot - pp_qual (Orig mod) = ppr mod <> dot + ppr (Exact name) = ppr name + ppr (Unqual occ) = ppr occ <+> ppr_name_space occ + 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 (occNameFlavour occ)) -pprUnqualRdrName (RdrName qual occ) = ppr occ +instance OutputableBndr RdrName where + pprBndr _ n + | isTvOcc (rdrNameOcc n) = char '@' <+> ppr n + | otherwise = ppr n instance Eq RdrName where - a == b = case (a `compare` b) of { EQ -> True; _ -> False } - a /= b = case (a `compare` b) of { EQ -> False; _ -> True } + (Exact n1) == (Exact n2) = n1==n2 + -- Convert exact to orig + (Exact n1) == r2@(Orig _ _) = nukeExact n1 == r2 + r1@(Orig _ _) == (Exact n2) = r1 == nukeExact n2 + + (Orig m1 o1) == (Orig m2 o2) = m1==m2 && o1==o2 + (Qual m1 o1) == (Qual m2 o2) = m1==m2 && o1==o2 + (Unqual o1) == (Unqual o2) = o1==o2 + r1 == r2 = False instance Ord RdrName where a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } @@ -172,44 +234,255 @@ 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 } - compare (RdrName q1 o1) (RdrName q2 o2) - = (o1 `compare` o2) `thenCmp` - (q1 `cmpQual` q2) + -- 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 (Orig m1 o1) (Orig m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2) + compare (Orig _ _) _ = GT +\end{code} + + -cmpQual Unqual Unqual = EQ -cmpQual (Qual m1) (Qual m2) = m1 `compare` m2 -cmpQual (Orig m1) (Orig m2) = m1 `compare` m2 -cmpQual Unqual _ = LT -cmpQual (Qual _) (Orig _) = LT -cmpQual _ _ = GT +%************************************************************************ +%* * + LocalRdrEnv +%* * +%************************************************************************ + +A LocalRdrEnv is used for local bindings (let, where, lambda, case) +It is keyed by OccName, because we never use it for qualified names. + +\begin{code} +type LocalRdrEnv = OccEnv Name + +emptyLocalRdrEnv = emptyOccEnv + +extendLocalRdrEnv :: LocalRdrEnv -> [Name] -> LocalRdrEnv +extendLocalRdrEnv env names + = extendOccEnvList env [(nameOccName n, n) | n <- names] + +lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name +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 + | isUnqual rdr_name = rdrNameOcc rdr_name `elemOccEnv` env + | otherwise = False \end{code} +%************************************************************************ +%* * + GlobalRdrEnv +%* * +%************************************************************************ + +\begin{code} +type GlobalRdrEnv = OccEnv [GlobalRdrElt] + -- Keyed by OccName; when looking up a qualified name + -- we look up the OccName part, and then check the Provenance + -- to see if the appropriate qualification is valid. This + -- saves routinely doubling the size of the env by adding both + -- qualified and unqualified names to the domain. + -- + -- The list in the range is reqd because there may be name clashes + -- These only get reported on lookup, not on construction + + -- INVARIANT: All the members of the list have distinct + -- gre_name fields; that is, no duplicate Names + +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 <+> pp_parent (nameParent_maybe name) + <+> parens (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 + = vcat (map pp (occEnvElts env)) + where + pp gres = ppr (nameOccName (gre_name (head gres))) <> colon <+> + vcat [ ppr (gre_name gre) <+> pprNameProvenance gre + | gre <- gres] +\end{code} + +\begin{code} +lookupGlobalRdrEnv :: GlobalRdrEnv -> OccName -> [GlobalRdrElt] +lookupGlobalRdrEnv env rdr_name = case lookupOccEnv env rdr_name of + Nothing -> [] + Just gres -> 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 + +lookupGRE_Name :: GlobalRdrEnv -> Name -> [GlobalRdrElt] +lookupGRE_Name env name + = [ gre | gre <- lookupGlobalRdrEnv env (nameOccName name), + gre_name gre == name ] + + +isLocalGRE :: GlobalRdrElt -> Bool +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 :: Module -> 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 + +plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv +plusGlobalRdrEnv env1 env2 = plusOccEnv_C (foldr insertGRE) env1 env2 + +mkGlobalRdrEnv :: [GlobalRdrElt] -> GlobalRdrEnv +mkGlobalRdrEnv gres + = foldr add emptyGlobalRdrEnv gres + where + add gre env = extendOccEnv_C (foldr insertGRE) env + (nameOccName (gre_name gre)) + [gre] + +insertGRE :: GlobalRdrElt -> [GlobalRdrElt] -> [GlobalRdrElt] +insertGRE new_g [] = [new_g] +insertGRE new_g (old_g : old_gs) + | gre_name new_g == gre_name old_g + = new_g `plusGRE` old_g : old_gs + | otherwise + = old_g : insertGRE new_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 } +\end{code} + %************************************************************************ %* * -\subsection{Environment} + Provenance %* * %************************************************************************ +The "provenance" of something says how it came to be in scope. + +\begin{code} +data Provenance + = LocalDef -- Defined locally + Module + + | 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 :: 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_loc :: SrcSpan } -- Location of import statment + +-- 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 + 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) + +instance Ord ImportSpec where + compare is1 is2 = (is_mod is1 `compare` is_mod is2) `thenCmp` + (is_loc is1 `compare` is_loc is2) +\end{code} + \begin{code} -type RdrNameEnv a = FiniteMap RdrName a - -emptyRdrEnv :: RdrNameEnv a -lookupRdrEnv :: RdrNameEnv a -> RdrName -> Maybe a -addListToRdrEnv :: RdrNameEnv a -> [(RdrName,a)] -> RdrNameEnv a -extendRdrEnv :: RdrNameEnv a -> RdrName -> a -> RdrNameEnv a -rdrEnvToList :: RdrNameEnv a -> [(RdrName, a)] -rdrEnvElts :: RdrNameEnv a -> [a] -elemRdrEnv :: RdrName -> RdrNameEnv a -> Bool -foldRdrEnv :: (RdrName -> a -> b -> b) -> b -> RdrNameEnv a -> b - -emptyRdrEnv = emptyFM -lookupRdrEnv = lookupFM -addListToRdrEnv = addListToFM -rdrEnvElts = eltsFM -extendRdrEnv = addToFM -rdrEnvToList = fmToList -elemRdrEnv = elemFM -foldRdrEnv = foldFM +plusProv :: Provenance -> Provenance -> Provenance +-- Choose LocalDef over Imported +-- There is an obscure bug lurking here; in the presence +-- of recursive modules, something can be imported *and* locally +-- 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) + +pprNameProvenance :: GlobalRdrElt -> SDoc +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))] + +-- 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 + = ptext SLIT("imported from") <+> ppr (is_mod imp_spec) + <+> ptext SLIT("at") <+> ppr (is_loc imp_spec) \end{code}