%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\begin{code}
module RdrName (
RdrName(..),
mkRdrUnqual, mkRdrQual,
mkUnqual, mkVarUnqual, mkQual, mkOrig,
nameRdrName, getRdrName,
rdrNameOcc, rdrNameSpace, setRdrNameSpace, demoteRdrName,
isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isQual_maybe, isUnqual,
isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName,
showRdrName,
LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, extendLocalRdrEnvList,
lookupLocalRdrEnv, lookupLocalRdrOcc, elemLocalRdrEnv, inLocalRdrEnvScope,
localRdrEnvElts, delLocalRdrEnvList,
GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv,
lookupGlobalRdrEnv, extendGlobalRdrEnv,
pprGlobalRdrEnv, globalRdrEnvElts,
lookupGRE_RdrName, lookupGRE_Name, getGRE_NameQualifier_maybes,
transformGREs, findLocalDupsRdrEnv, pickGREs,
GlobalRdrElt(..), isLocalGRE, unQualOK, qualSpecOK, unQualSpecOK,
Provenance(..), pprNameProvenance,
Parent(..),
ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..),
importSpecLoc, importSpecModule, isExplicitItem
) where
#include "HsVersions.h"
import Module
import Name
import NameSet
import Maybes
import SrcLoc
import FastString
import Outputable
import Unique
import Util
import StaticFlags( opt_PprStyle_Debug )
import Data.Data
\end{code}
%************************************************************************
%* *
\subsection{The main data type}
%* *
%************************************************************************
\begin{code}
data RdrName
= Unqual OccName
| Qual ModuleName OccName
| Orig Module OccName
| Exact Name
deriving (Data, Typeable)
\end{code}
%************************************************************************
%* *
\subsection{Simple functions}
%* *
%************************************************************************
\begin{code}
rdrNameOcc :: RdrName -> OccName
rdrNameOcc (Qual _ occ) = occ
rdrNameOcc (Unqual occ) = occ
rdrNameOcc (Orig _ occ) = occ
rdrNameOcc (Exact name) = nameOccName name
rdrNameSpace :: RdrName -> NameSpace
rdrNameSpace = occNameSpace . rdrNameOcc
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 = ASSERT( isExternalName n )
Orig (nameModule n)
(setOccNameSpace ns (nameOccName n))
demoteRdrName :: RdrName -> Maybe RdrName
demoteRdrName (Unqual occ) = fmap Unqual (demoteOccName occ)
demoteRdrName (Qual m occ) = fmap (Qual m) (demoteOccName occ)
demoteRdrName (Orig _ _) = panic "demoteRdrName"
demoteRdrName (Exact _) = panic "demoteRdrName"
\end{code}
\begin{code}
mkRdrUnqual :: OccName -> RdrName
mkRdrUnqual occ = Unqual occ
mkRdrQual :: ModuleName -> OccName -> RdrName
mkRdrQual mod occ = Qual mod occ
mkOrig :: Module -> OccName -> RdrName
mkOrig mod occ = Orig mod occ
mkUnqual :: NameSpace -> FastString -> RdrName
mkUnqual sp n = Unqual (mkOccNameFS sp n)
mkVarUnqual :: FastString -> RdrName
mkVarUnqual n = Unqual (mkVarOccFS n)
mkQual :: NameSpace -> (FastString, FastString) -> RdrName
mkQual sp (m, n) = Qual (mkModuleNameFS m) (mkOccNameFS sp n)
getRdrName :: NamedThing thing => thing -> RdrName
getRdrName name = nameRdrName (getName name)
nameRdrName :: Name -> RdrName
nameRdrName name = Exact name
nukeExact :: Name -> RdrName
nukeExact n
| isExternalName n = Orig (nameModule n) (nameOccName n)
| otherwise = Unqual (nameOccName n)
\end{code}
\begin{code}
isRdrDataCon :: RdrName -> Bool
isRdrTyVar :: RdrName -> Bool
isRdrTc :: RdrName -> Bool
isRdrDataCon rn = isDataOcc (rdrNameOcc rn)
isRdrTyVar rn = isTvOcc (rdrNameOcc rn)
isRdrTc rn = isTcOcc (rdrNameOcc rn)
isSrcRdrName :: RdrName -> Bool
isSrcRdrName (Unqual _) = True
isSrcRdrName (Qual _ _) = True
isSrcRdrName _ = False
isUnqual :: RdrName -> Bool
isUnqual (Unqual _) = True
isUnqual _ = False
isQual :: RdrName -> Bool
isQual (Qual _ _) = True
isQual _ = False
isQual_maybe :: RdrName -> Maybe (ModuleName, OccName)
isQual_maybe (Qual m n) = Just (m,n)
isQual_maybe _ = Nothing
isOrig :: RdrName -> Bool
isOrig (Orig _ _) = True
isOrig _ = False
isOrig_maybe :: RdrName -> Maybe (Module, OccName)
isOrig_maybe (Orig m n) = Just (m,n)
isOrig_maybe _ = Nothing
isExact :: RdrName -> Bool
isExact (Exact _) = True
isExact _ = False
isExact_maybe :: RdrName -> Maybe Name
isExact_maybe (Exact n) = Just n
isExact_maybe _ = Nothing
\end{code}
%************************************************************************
%* *
\subsection{Instances}
%* *
%************************************************************************
\begin{code}
instance Outputable RdrName where
ppr (Exact name) = ppr name
ppr (Unqual occ) = ppr occ
ppr (Qual mod occ) = ppr mod <> dot <> ppr occ
ppr (Orig mod occ) = getPprStyle (\sty -> pprModulePrefix sty mod name <> ppr occ)
where name = mkExternalName (mkUniqueGrimily 0) mod occ noSrcSpan
instance OutputableBndr RdrName where
pprBndr _ n
| isTvOcc (rdrNameOcc n) = char '@' <+> ppr n
| otherwise = ppr n
pprInfixOcc rdr = pprInfixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr)
pprPrefixOcc rdr = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr)
showRdrName :: RdrName -> String
showRdrName r = showSDoc (ppr r)
instance Eq RdrName where
(Exact n1) == (Exact n2) = n1==n2
(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
_ == _ = 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 -> True; EQ -> False; 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 }
compare (Exact n1) (Exact n2) = n1 `compare` n2
compare (Exact _) _ = 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}
%************************************************************************
%* *
LocalRdrEnv
%* *
%************************************************************************
\begin{code}
type LocalRdrEnv = (OccEnv Name, NameSet)
emptyLocalRdrEnv :: LocalRdrEnv
emptyLocalRdrEnv = (emptyOccEnv, emptyNameSet)
extendLocalRdrEnv :: LocalRdrEnv -> Name -> LocalRdrEnv
extendLocalRdrEnv (env, ns) name
= (extendOccEnv env (nameOccName name) name, addOneToNameSet ns name)
extendLocalRdrEnvList :: LocalRdrEnv -> [Name] -> LocalRdrEnv
extendLocalRdrEnvList (env, ns) names
= (extendOccEnvList env [(nameOccName n, n) | n <- names], addListToNameSet ns names)
lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name
lookupLocalRdrEnv (env, _) (Unqual occ) = lookupOccEnv env occ
lookupLocalRdrEnv _ _ = Nothing
lookupLocalRdrOcc :: LocalRdrEnv -> OccName -> Maybe Name
lookupLocalRdrOcc (env, _) occ = lookupOccEnv env occ
elemLocalRdrEnv :: RdrName -> LocalRdrEnv -> Bool
elemLocalRdrEnv rdr_name (env, _)
| isUnqual rdr_name = rdrNameOcc rdr_name `elemOccEnv` env
| otherwise = False
localRdrEnvElts :: LocalRdrEnv -> [Name]
localRdrEnvElts (env, _) = occEnvElts env
inLocalRdrEnvScope :: Name -> LocalRdrEnv -> Bool
inLocalRdrEnvScope name (_, ns) = name `elemNameSet` ns
delLocalRdrEnvList :: LocalRdrEnv -> [OccName] -> LocalRdrEnv
delLocalRdrEnvList (env, ns) occs = (delListFromOccEnv env occs, ns)
\end{code}
%************************************************************************
%* *
GlobalRdrEnv
%* *
%************************************************************************
\begin{code}
type GlobalRdrEnv = OccEnv [GlobalRdrElt]
data GlobalRdrElt
= GRE { gre_name :: Name,
gre_par :: Parent,
gre_prov :: Provenance
}
data Parent = NoParent | ParentIs Name
deriving (Eq)
instance Outputable Parent where
ppr NoParent = empty
ppr (ParentIs n) = ptext (sLit "parent:") <> ppr n
plusParent :: Parent -> Parent -> Parent
plusParent (ParentIs n) p2 = hasParent n p2
plusParent p1 (ParentIs n) = hasParent n p1
plusParent _ _ = NoParent
hasParent :: Name -> Parent -> Parent
#ifdef DEBUG
hasParent n (ParentIs n')
| n /= n' = pprPanic "hasParent" (ppr n <+> ppr n')
#endif
hasParent n _ = ParentIs n
emptyGlobalRdrEnv :: GlobalRdrEnv
emptyGlobalRdrEnv = emptyOccEnv
globalRdrEnvElts :: GlobalRdrEnv -> [GlobalRdrElt]
globalRdrEnvElts env = foldOccEnv (++) [] env
instance Outputable GlobalRdrElt where
ppr gre = hang (ppr (gre_name gre) <+> ppr (gre_par gre))
2 (pprNameProvenance gre)
pprGlobalRdrEnv :: GlobalRdrEnv -> SDoc
pprGlobalRdrEnv env
= vcat (map pp (occEnvElts env))
where
pp gres = ppr (nameOccName (gre_name (head gres))) <> colon <+>
vcat (map ppr gres)
\end{code}
\begin{code}
lookupGlobalRdrEnv :: GlobalRdrEnv -> OccName -> [GlobalRdrElt]
lookupGlobalRdrEnv env occ_name = case lookupOccEnv env occ_name of
Nothing -> []
Just gres -> gres
extendGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrElt -> GlobalRdrEnv
extendGlobalRdrEnv env gre = extendOccEnv_Acc (:) singleton env occ gre
where
occ = nameOccName (gre_name gre)
lookupGRE_RdrName :: RdrName -> GlobalRdrEnv -> [GlobalRdrElt]
lookupGRE_RdrName rdr_name env
= case lookupOccEnv env (rdrNameOcc rdr_name) of
Nothing -> []
Just gres -> pickGREs rdr_name gres
lookupGRE_Name :: GlobalRdrEnv -> Name -> [GlobalRdrElt]
lookupGRE_Name env name
= [ gre | gre <- lookupGlobalRdrEnv env (nameOccName name),
gre_name gre == name ]
getGRE_NameQualifier_maybes :: GlobalRdrEnv -> Name -> [Maybe [ModuleName]]
getGRE_NameQualifier_maybes env
= map (qualifier_maybe . gre_prov) . lookupGRE_Name env
where
qualifier_maybe LocalDef = Nothing
qualifier_maybe (Imported iss) = Just $ map (is_as . is_decl) iss
pickGREs :: RdrName -> [GlobalRdrElt] -> [GlobalRdrElt]
pickGREs rdr_name gres
= mapCatMaybes pick gres
where
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})
| rdr_is_unqual = Just gre
| Just (mod,_) <- rdr_is_qual
, Just n_mod <- nameModule_maybe n
, mod == moduleName n_mod = Just gre
| otherwise = Nothing
pick gre@(GRE {gre_prov = Imported [is]})
| 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})
| null filtered_is = Nothing
| otherwise = Just (gre {gre_prov = Imported filtered_is})
where
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
isLocalGRE _ = False
unQualOK :: GlobalRdrElt -> Bool
unQualOK (GRE {gre_prov = LocalDef}) = True
unQualOK (GRE {gre_prov = Imported is}) = any unQualSpecOK 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_Acc insertGRE singleton env
(nameOccName (gre_name gre))
gre
findLocalDupsRdrEnv :: GlobalRdrEnv -> [OccName] -> (GlobalRdrEnv, [[Name]])
findLocalDupsRdrEnv rdr_env occs
= go rdr_env [] occs
where
go rdr_env dups [] = (rdr_env, dups)
go rdr_env dups (occ:occs)
= case filter isLocalGRE gres of
[] -> WARN( True, ppr occ <+> ppr rdr_env )
go rdr_env dups occs
[_] -> go rdr_env dups occs
dup_gres -> go (extendOccEnv rdr_env occ (head dup_gres : nonlocal_gres))
(map gre_name dup_gres : dups)
occs
where
gres = lookupOccEnv rdr_env occ `orElse` []
nonlocal_gres = filterOut isLocalGRE gres
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
plusGRE g1 g2
= GRE { gre_name = gre_name g1,
gre_prov = gre_prov g1 `plusProv` gre_prov g2,
gre_par = gre_par g1 `plusParent` gre_par g2 }
transformGREs :: (GlobalRdrElt -> GlobalRdrElt)
-> [OccName]
-> GlobalRdrEnv -> GlobalRdrEnv
transformGREs trans_gre occs rdr_env
= foldr trans rdr_env occs
where
trans occ env
= case lookupOccEnv env occ of
Just gres -> extendOccEnv env occ (map trans_gre gres)
Nothing -> env
\end{code}
%************************************************************************
%* *
Provenance
%* *
%************************************************************************
\begin{code}
data Provenance
= LocalDef
| Imported
[ImportSpec]
data ImportSpec = ImpSpec { is_decl :: ImpDeclSpec,
is_item :: ImpItemSpec }
deriving( Eq, Ord )
data ImpDeclSpec
= ImpDeclSpec {
is_mod :: ModuleName,
is_as :: ModuleName,
is_qual :: Bool,
is_dloc :: SrcSpan
}
data ImpItemSpec
= ImpAll
| ImpSome {
is_explicit :: Bool,
is_iloc :: SrcSpan
}
unQualSpecOK :: ImportSpec -> Bool
unQualSpecOK is = not (is_qual (is_decl is))
qualSpecOK :: ModuleName -> ImportSpec -> Bool
qualSpecOK mod is = mod == is_as (is_decl is)
importSpecLoc :: ImportSpec -> SrcSpan
importSpecLoc (ImpSpec decl ImpAll) = is_dloc decl
importSpecLoc (ImpSpec _ item) = is_iloc item
importSpecModule :: ImportSpec -> ModuleName
importSpecModule is = is_mod (is_decl is)
isExplicitItem :: ImpItemSpec -> Bool
isExplicitItem ImpAll = False
isExplicitItem (ImpSome {is_explicit = exp}) = exp
instance Eq Provenance where
p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False
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)
instance Ord ImpDeclSpec where
compare is1 is2 = (is_mod is1 `compare` is_mod is2) `thenCmp`
(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}
plusProv :: Provenance -> Provenance -> Provenance
plusProv LocalDef LocalDef = panic "plusProv"
plusProv LocalDef _ = LocalDef
plusProv _ LocalDef = LocalDef
plusProv (Imported is1) (Imported is2) = Imported (is1++is2)
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 whys})
= case whys of
(why:_) | opt_PprStyle_Debug -> vcat (map pp_why whys)
| otherwise -> pp_why why
[] -> panic "pprNameProvenance"
where
pp_why why = sep [ppr why, ppr_defn_site why name]
ppr_defn_site :: ImportSpec -> Name -> SDoc
ppr_defn_site imp_spec name
| same_module && not (isGoodSrcSpan loc)
= empty
| otherwise
= parens $ hang (ptext (sLit "and originally defined") <+> pp_mod)
2 (pprLoc loc)
where
loc = nameSrcSpan name
defining_mod = nameModule name
same_module = importSpecModule imp_spec == moduleName defining_mod
pp_mod | same_module = empty
| otherwise = ptext (sLit "in") <+> quotes (ppr defining_mod)
instance Outputable ImportSpec where
ppr imp_spec
= ptext (sLit "imported") <+> qual
<+> ptext (sLit "from") <+> quotes (ppr (importSpecModule imp_spec))
<+> pprLoc (importSpecLoc imp_spec)
where
qual | is_qual (is_decl imp_spec) = ptext (sLit "qualified")
| otherwise = empty
pprLoc :: SrcSpan -> SDoc
pprLoc (RealSrcSpan s) = ptext (sLit "at") <+> ppr s
pprLoc (UnhelpfulSpan {}) = empty
\end{code}