-{-% DrIFT (Automatic class derivations for Haskell) v1.1 %-}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\begin{code}
module RdrName (
- RdrName,
+ RdrName(..), -- Constructors exported only to BinIface
-- Construction
mkRdrUnqual, mkRdrQual,
- mkUnqual, mkQual, mkOrig, mkIfaceOrig,
+ mkUnqual, mkVarUnqual, mkQual, mkOrig,
nameRdrName, getRdrName,
- qualifyRdrName, unqualifyRdrName, mkRdrNameWkr,
- dummyRdrVarName, dummyRdrTcName,
+ mkDerivedRdrName,
-- Destruction
rdrNameModule, rdrNameOcc, setRdrNameSpace,
isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isUnqual,
- isOrig, isExact, isExact_maybe,
-
- -- Environment
- RdrNameEnv,
- emptyRdrEnv, lookupRdrEnv, addListToRdrEnv, rdrEnvElts,
- extendRdrEnv, rdrEnvToList, elemRdrEnv, foldRdrEnv,
+ 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,
+import OccName ( NameSpace, tcName, varName,
OccName, UserFS, EncodedFS,
mkSysOccFS, setOccNameSpace,
mkOccFS, mkVarOcc, occNameFlavour,
- isDataOcc, isTvOcc, isTcOcc, mkWorkerOcc
+ isDataOcc, isTvOcc, isTcOcc,
+ OccEnv, emptyOccEnv, extendOccEnvList, lookupOccEnv,
+ elemOccEnv, plusOccEnv_C, extendOccEnv_C, foldOccEnv,
+ occEnvElts
)
-import Module ( ModuleName,
- mkSysModuleNameFS, mkModuleNameFS
- )
-import Name ( Name, NamedThing(getName), nameModule, nameOccName )
-import Module ( moduleName )
-import FiniteMap
+import Module ( ModuleName, mkSysModuleNameFS, mkModuleNameFS )
+import Name ( Name, NamedThing(getName), nameModuleName, nameParent_maybe,
+ nameOccName, isExternalName, nameSrcLoc )
+import Maybes ( seqMaybe )
+import SrcLoc ( SrcLoc, isGoodSrcLoc, SrcSpan )
+import BasicTypes( DeprecTxt )
import Outputable
-import Binary
import Util ( thenCmp )
\end{code}
-- 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) possibly, by the meta-programming stuff
+ -- (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
\end{code}
rdrNameModule :: RdrName -> ModuleName
rdrNameModule (Qual m _) = m
rdrNameModule (Orig m _) = m
-rdrNameModule (Exact n) = moduleName (nameModule n)
+rdrNameModule (Exact n) = nameModuleName n
rdrNameModule (Unqual n) = pprPanic "rdrNameModule" (ppr n)
rdrNameOcc :: RdrName -> OccName
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 = Unqual (setOccNameSpace ns (nameOccName n))
+setRdrNameSpace (Exact n) ns = Orig (nameModuleName n)
+ (setOccNameSpace ns (nameOccName n))
\end{code}
\begin{code}
mkOrig :: ModuleName -> 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))
+---------------
-- 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)
+mkVarUnqual :: UserFS -> RdrName
+mkVarUnqual n = Unqual (mkOccFS varName n)
+
mkQual :: NameSpace -> (UserFS, UserFS) -> RdrName
mkQual sp (m, n) = Qual (mkModuleNameFS m) (mkOccFS sp n)
getRdrName :: NamedThing thing => thing -> RdrName
-getRdrName name = Exact (getName name)
+getRdrName name = nameRdrName (getName name)
nameRdrName :: Name -> RdrName
nameRdrName name = Exact name
-
-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)
-
-mkRdrNameWkr :: RdrName -> RdrName -- Worker-ify it
-mkRdrNameWkr rdr_name = Qual (rdrNameModule rdr_name)
- (mkWorkerOcc (rdrNameOcc rdr_name))
-
-origFromName :: Name -> RdrName
-origFromName n = Orig (moduleName (nameModule n)) (nameOccName n)
+-- 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)
+
+nukeExact :: Name -> RdrName
+nukeExact n
+ | isExternalName n = Orig (nameModuleName 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)
+isSrcRdrName (Unqual _) = True
+isSrcRdrName (Qual _ _) = True
+isSrcRdrName _ = False
+
isUnqual (Unqual _) = True
isUnqual other = False
isOrig (Orig _ _) = True
isOrig _ = False
+isOrig_maybe (Orig m n) = Just (m,n)
+isOrig_maybe _ = Nothing
+
isExact (Exact _) = True
isExact other = False
| isTvOcc (rdrNameOcc n) = char '@' <+> ppr n
| otherwise = ppr n
-pprUnqualRdrName rdr_name = ppr (rdrNameOcc rdr_name)
-
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 }
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 < Exact
- compare (Exact n1) (Exact n2) = n1 `compare` n2
+ -- 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)
compare (Unqual o1) (Unqual o2) = o1 `compare` o2
- -- Convert Exact to Orig
- compare (Exact n1) n2 = origFromName n1 `compare` n2
- compare n1 (Exact n2) = n1 `compare` origFromName n2
-
compare (Unqual _) _ = LT
compare (Qual _ _) (Orig _ _) = LT
compare _ _ = GT
%************************************************************************
%* *
-\subsection{Environment}
+ 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
+ gre_deprec :: Maybe DeprecTxt -- Whether this name is deprecated
+ }
+
+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 :: 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
+
+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,
+ 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.
+\end{code}
+
+
+%************************************************************************
+%* *
+ Provenance
+%* *
+%************************************************************************
+
+The "provenance" of something says how it came to be in scope.
+
\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
+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 :: 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}
-instance Binary RdrName where
- put_ bh (Unqual aa) = do
- putByte bh 0
- put_ bh aa
-
- put_ bh (Qual aa ab) = do
- putByte bh 1
- put_ bh aa
- put_ bh ab
-
- put_ bh (Orig aa ab) = do
- putByte bh 2
- put_ bh aa
- put_ bh ab
-
- put_ bh (Exact n) = pprPanic "No Binary instance for RdrName.Exact" (ppr n)
-
- get bh = do
- h <- getByte bh
- case h of
- 0 -> do aa <- get bh
- return (Unqual aa)
- 1 -> do aa <- get bh
- ab <- get bh
- return (Qual aa ab)
- _ -> do aa <- get bh
- ab <- get bh
- return (Orig aa ab)
+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))]
+
+instance Outputable ImportSpec where
+ ppr imp_spec
+ = ptext SLIT("imported from") <+> ppr (is_mod imp_spec)
+ <+> ptext SLIT("at") <+> ppr (is_loc imp_spec)
+
+ppr_defn loc | isGoodSrcLoc loc = parens (ptext SLIT("defined at") <+> ppr loc)
+ | otherwise = empty
\end{code}
projects / ghc-hetmet.git / blobdiff