{-# LANGUAGE CPP, DeriveDataTypeable #-}
module RdrName (
RdrName(..),
mkRdrUnqual, mkRdrQual,
mkUnqual, mkVarUnqual, mkQual, mkOrig,
nameRdrName, getRdrName,
rdrNameOcc, rdrNameSpace, demoteRdrName,
isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isQual_maybe, isUnqual,
isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName, isStar,
isUniStar,
LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, extendLocalRdrEnvList,
lookupLocalRdrEnv, lookupLocalRdrOcc,
elemLocalRdrEnv, inLocalRdrEnvScope,
localRdrEnvElts, delLocalRdrEnvList,
GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv,
lookupGlobalRdrEnv, extendGlobalRdrEnv, greOccName, shadowNames,
pprGlobalRdrEnv, globalRdrEnvElts,
lookupGRE_RdrName, lookupGRE_Name, lookupGRE_FieldLabel,
getGRE_NameQualifier_maybes,
transformGREs, pickGREs, pickGREsModExp,
gresFromAvails, gresFromAvail, localGREsFromAvail, availFromGRE,
greUsedRdrName, greRdrNames, greSrcSpan, greQualModName,
gresToAvailInfo,
GlobalRdrElt(..), isLocalGRE, isRecFldGRE, greLabel,
unQualOK, qualSpecOK, unQualSpecOK,
pprNameProvenance,
Parent(..),
ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..),
importSpecLoc, importSpecModule, isExplicitItem, bestImport
) where
#include "HsVersions.h"
import GhcPrelude
import Module
import Name
import Avail
import NameSet
import Maybes
import SrcLoc
import FastString
import FieldLabel
import Outputable
import Unique
import UniqFM
import UniqSet
import Util
import NameEnv
import Data.Data
import Data.List( sortBy, foldl', nub )
data RdrName
= Unqual OccName
| Qual ModuleName OccName
| Orig Module OccName
| Exact Name
deriving Data
instance HasOccName RdrName where
occName = rdrNameOcc
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
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"
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)
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
isStar, isUniStar :: RdrName -> Bool
isStar = (fsLit "*" ==) . occNameFS . rdrNameOcc
isUniStar = (fsLit "★" ==) . occNameFS . rdrNameOcc
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 occ <> ppr occ)
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
| Just name <- isExact_maybe rdr = pprPrefixName name
| otherwise = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr)
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
data LocalRdrEnv = LRE { lre_env :: OccEnv Name
, lre_in_scope :: NameSet }
instance Outputable LocalRdrEnv where
ppr (LRE {lre_env = env, lre_in_scope = ns})
= hang (text "LocalRdrEnv {")
2 (vcat [ text "env =" <+> pprOccEnv ppr_elt env
, text "in_scope ="
<+> pprUFM (getUniqSet ns) (braces . pprWithCommas ppr)
] <+> char '}')
where
ppr_elt name = parens (ppr (getUnique (nameOccName name))) <+> ppr name
emptyLocalRdrEnv :: LocalRdrEnv
emptyLocalRdrEnv = LRE { lre_env = emptyOccEnv
, lre_in_scope = emptyNameSet }
extendLocalRdrEnv :: LocalRdrEnv -> Name -> LocalRdrEnv
extendLocalRdrEnv lre@(LRE { lre_env = env, lre_in_scope = ns }) name
= WARN( isExternalName name, ppr name )
lre { lre_env = extendOccEnv env (nameOccName name) name
, lre_in_scope = extendNameSet ns name }
extendLocalRdrEnvList :: LocalRdrEnv -> [Name] -> LocalRdrEnv
extendLocalRdrEnvList lre@(LRE { lre_env = env, lre_in_scope = ns }) names
= WARN( any isExternalName names, ppr names )
lre { lre_env = extendOccEnvList env [(nameOccName n, n) | n <- names]
, lre_in_scope = extendNameSetList ns names }
lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name
lookupLocalRdrEnv (LRE { lre_env = env, lre_in_scope = ns }) rdr
| Unqual occ <- rdr
= lookupOccEnv env occ
| Exact name <- rdr
, name `elemNameSet` ns
= Just name
| otherwise
= Nothing
lookupLocalRdrOcc :: LocalRdrEnv -> OccName -> Maybe Name
lookupLocalRdrOcc (LRE { lre_env = env }) occ = lookupOccEnv env occ
elemLocalRdrEnv :: RdrName -> LocalRdrEnv -> Bool
elemLocalRdrEnv rdr_name (LRE { lre_env = env, lre_in_scope = ns })
= case rdr_name of
Unqual occ -> occ `elemOccEnv` env
Exact name -> name `elemNameSet` ns
Qual {} -> False
Orig {} -> False
localRdrEnvElts :: LocalRdrEnv -> [Name]
localRdrEnvElts (LRE { lre_env = env }) = occEnvElts env
inLocalRdrEnvScope :: Name -> LocalRdrEnv -> Bool
inLocalRdrEnvScope name (LRE { lre_in_scope = ns }) = name `elemNameSet` ns
delLocalRdrEnvList :: LocalRdrEnv -> [OccName] -> LocalRdrEnv
delLocalRdrEnvList lre@(LRE { lre_env = env }) occs
= lre { lre_env = delListFromOccEnv env occs }
type GlobalRdrEnv = OccEnv [GlobalRdrElt]
data GlobalRdrElt
= GRE { gre_name :: Name
, gre_par :: Parent
, gre_lcl :: Bool
, gre_imp :: [ImportSpec]
} deriving (Data, Eq)
data Parent = NoParent
| ParentIs { par_is :: Name }
| FldParent { par_is :: Name, par_lbl :: Maybe FieldLabelString }
deriving (Eq, Data, Typeable)
instance Outputable Parent where
ppr NoParent = empty
ppr (ParentIs n) = text "parent:" <> ppr n
ppr (FldParent n f) = text "fldparent:"
<> ppr n <> colon <> ppr f
plusParent :: Parent -> Parent -> Parent
plusParent p1@(ParentIs _) p2 = hasParent p1 p2
plusParent p1@(FldParent _ _) p2 = hasParent p1 p2
plusParent p1 p2@(ParentIs _) = hasParent p2 p1
plusParent p1 p2@(FldParent _ _) = hasParent p2 p1
plusParent _ _ = NoParent
hasParent :: Parent -> Parent -> Parent
#if defined(DEBUG)
hasParent p NoParent = p
hasParent p p'
| p /= p' = pprPanic "hasParent" (ppr p <+> ppr p')
#endif
hasParent p _ = p
gresFromAvails :: Maybe ImportSpec -> [AvailInfo] -> [GlobalRdrElt]
gresFromAvails prov avails
= concatMap (gresFromAvail (const prov)) avails
localGREsFromAvail :: AvailInfo -> [GlobalRdrElt]
localGREsFromAvail = gresFromAvail (const Nothing)
gresFromAvail :: (Name -> Maybe ImportSpec) -> AvailInfo -> [GlobalRdrElt]
gresFromAvail prov_fn avail
= map mk_gre (availNonFldNames avail) ++ map mk_fld_gre (availFlds avail)
where
mk_gre n
= case prov_fn n of
Nothing -> GRE { gre_name = n, gre_par = mkParent n avail
, gre_lcl = True, gre_imp = [] }
Just is -> GRE { gre_name = n, gre_par = mkParent n avail
, gre_lcl = False, gre_imp = [is] }
mk_fld_gre (FieldLabel { flLabel = lbl, flIsOverloaded = is_overloaded
, flSelector = n })
= case prov_fn n of
Nothing -> GRE { gre_name = n, gre_par = FldParent (availName avail) mb_lbl
, gre_lcl = True, gre_imp = [] }
Just is -> GRE { gre_name = n, gre_par = FldParent (availName avail) mb_lbl
, gre_lcl = False, gre_imp = [is] }
where
mb_lbl | is_overloaded = Just lbl
| otherwise = Nothing
greQualModName :: GlobalRdrElt -> ModuleName
greQualModName gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss })
| lcl, Just mod <- nameModule_maybe name = moduleName mod
| (is:_) <- iss = is_as (is_decl is)
| otherwise = pprPanic "greQualModName" (ppr gre)
greUsedRdrName :: GlobalRdrElt -> RdrName
greUsedRdrName gre@GRE{ gre_name = name, gre_lcl = lcl, gre_imp = iss }
| lcl, Just mod <- nameModule_maybe name = Qual (moduleName mod) occ
| not (null iss), is <- bestImport iss = Qual (is_as (is_decl is)) occ
| otherwise = pprTrace "greUsedRdrName" (ppr gre) (Unqual occ)
where
occ = greOccName gre
greRdrNames :: GlobalRdrElt -> [RdrName]
greRdrNames gre@GRE{ gre_lcl = lcl, gre_imp = iss }
= (if lcl then [unqual] else []) ++ concatMap do_spec (map is_decl iss)
where
occ = greOccName gre
unqual = Unqual occ
do_spec decl_spec
| is_qual decl_spec = [qual]
| otherwise = [unqual,qual]
where qual = Qual (is_as decl_spec) occ
greSrcSpan :: GlobalRdrElt -> SrcSpan
greSrcSpan gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss } )
| lcl = nameSrcSpan name
| (is:_) <- iss = is_dloc (is_decl is)
| otherwise = pprPanic "greSrcSpan" (ppr gre)
mkParent :: Name -> AvailInfo -> Parent
mkParent _ (Avail _) = NoParent
mkParent n (AvailTC m _ _) | n == m = NoParent
| otherwise = ParentIs m
greParentName :: GlobalRdrElt -> Maybe Name
greParentName gre = case gre_par gre of
NoParent -> Nothing
ParentIs n -> Just n
FldParent n _ -> Just n
gresToAvailInfo :: [GlobalRdrElt] -> [AvailInfo]
gresToAvailInfo gres
= ASSERT( nub gres == gres ) nameEnvElts avail_env
where
avail_env :: NameEnv AvailInfo
avail_env = foldl' add emptyNameEnv gres
add :: NameEnv AvailInfo -> GlobalRdrElt -> NameEnv AvailInfo
add env gre = extendNameEnv_Acc comb availFromGRE env
(fromMaybe (gre_name gre)
(greParentName gre)) gre
where
insertChildIntoChildren :: Name -> [Name] -> Name -> [Name]
insertChildIntoChildren _ [] k = [k]
insertChildIntoChildren p (n:ns) k
| p == k = k:n:ns
| otherwise = n:k:ns
comb :: GlobalRdrElt -> AvailInfo -> AvailInfo
comb _ (Avail n) = Avail n
comb gre (AvailTC m ns fls) =
let n = gre_name gre
in case gre_par gre of
NoParent -> AvailTC m (n:ns) fls
ParentIs {} -> AvailTC m (insertChildIntoChildren m ns n) fls
FldParent _ mb_lbl -> AvailTC m ns (mkFieldLabel n mb_lbl : fls)
availFromGRE :: GlobalRdrElt -> AvailInfo
availFromGRE (GRE { gre_name = me, gre_par = parent })
= case parent of
ParentIs p -> AvailTC p [me] []
NoParent | isTyConName me -> AvailTC me [me] []
| otherwise -> avail me
FldParent p mb_lbl -> AvailTC p [] [mkFieldLabel me mb_lbl]
mkFieldLabel :: Name -> Maybe FastString -> FieldLabel
mkFieldLabel me mb_lbl =
case mb_lbl of
Nothing -> FieldLabel { flLabel = occNameFS (nameOccName me)
, flIsOverloaded = False
, flSelector = me }
Just lbl -> FieldLabel { flLabel = lbl
, flIsOverloaded = True
, flSelector = me }
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 :: Bool -> GlobalRdrEnv -> SDoc
pprGlobalRdrEnv locals_only env
= vcat [ text "GlobalRdrEnv" <+> ppWhen locals_only (ptext (sLit "(locals only)"))
<+> lbrace
, nest 2 (vcat [ pp (remove_locals gre_list) | gre_list <- occEnvElts env ]
<+> rbrace) ]
where
remove_locals gres | locals_only = filter isLocalGRE gres
| otherwise = gres
pp [] = empty
pp gres = hang (ppr occ
<+> parens (text "unique" <+> ppr (getUnique occ))
<> colon)
2 (vcat (map ppr gres))
where
occ = nameOccName (gre_name (head gres))
lookupGlobalRdrEnv :: GlobalRdrEnv -> OccName -> [GlobalRdrElt]
lookupGlobalRdrEnv env occ_name = case lookupOccEnv env occ_name of
Nothing -> []
Just gres -> gres
greOccName :: GlobalRdrElt -> OccName
greOccName (GRE{gre_par = FldParent{par_lbl = Just lbl}}) = mkVarOccFS lbl
greOccName gre = 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 -> Maybe GlobalRdrElt
lookupGRE_Name env name
= lookupGRE_Name_OccName env name (nameOccName name)
lookupGRE_FieldLabel :: GlobalRdrEnv -> FieldLabel -> Maybe GlobalRdrElt
lookupGRE_FieldLabel env fl
= lookupGRE_Name_OccName env (flSelector fl) (mkVarOccFS (flLabel fl))
lookupGRE_Name_OccName :: GlobalRdrEnv -> Name -> OccName -> Maybe GlobalRdrElt
lookupGRE_Name_OccName env name occ
= case [ gre | gre <- lookupGlobalRdrEnv env occ
, gre_name gre == name ] of
[] -> Nothing
[gre] -> Just gre
gres -> pprPanic "lookupGRE_Name_OccName"
(ppr name $$ ppr occ $$ ppr gres)
getGRE_NameQualifier_maybes :: GlobalRdrEnv -> Name -> [Maybe [ModuleName]]
getGRE_NameQualifier_maybes env name
= case lookupGRE_Name env name of
Just gre -> [qualifier_maybe gre]
Nothing -> []
where
qualifier_maybe (GRE { gre_lcl = lcl, gre_imp = iss })
| lcl = Nothing
| otherwise = Just $ map (is_as . is_decl) iss
isLocalGRE :: GlobalRdrElt -> Bool
isLocalGRE (GRE {gre_lcl = lcl }) = lcl
isRecFldGRE :: GlobalRdrElt -> Bool
isRecFldGRE (GRE {gre_par = FldParent{}}) = True
isRecFldGRE _ = False
greLabel :: GlobalRdrElt -> Maybe FieldLabelString
greLabel (GRE{gre_par = FldParent{par_lbl = Just lbl}}) = Just lbl
greLabel (GRE{gre_name = n, gre_par = FldParent{}}) = Just (occNameFS (nameOccName n))
greLabel _ = Nothing
unQualOK :: GlobalRdrElt -> Bool
unQualOK (GRE {gre_lcl = lcl, gre_imp = iss })
| lcl = True
| otherwise = any unQualSpecOK iss
pickGREs :: RdrName -> [GlobalRdrElt] -> [GlobalRdrElt]
pickGREs (Unqual {}) gres = mapMaybe pickUnqualGRE gres
pickGREs (Qual mod _) gres = mapMaybe (pickQualGRE mod) gres
pickGREs _ _ = []
pickUnqualGRE :: GlobalRdrElt -> Maybe GlobalRdrElt
pickUnqualGRE gre@(GRE { gre_lcl = lcl, gre_imp = iss })
| not lcl, null iss' = Nothing
| otherwise = Just (gre { gre_imp = iss' })
where
iss' = filter unQualSpecOK iss
pickQualGRE :: ModuleName -> GlobalRdrElt -> Maybe GlobalRdrElt
pickQualGRE mod gre@(GRE { gre_name = n, gre_lcl = lcl, gre_imp = iss })
| not lcl', null iss' = Nothing
| otherwise = Just (gre { gre_lcl = lcl', gre_imp = iss' })
where
iss' = filter (qualSpecOK mod) iss
lcl' = lcl && name_is_from mod n
name_is_from :: ModuleName -> Name -> Bool
name_is_from mod name = case nameModule_maybe name of
Just n_mod -> moduleName n_mod == mod
Nothing -> False
pickGREsModExp :: ModuleName -> [GlobalRdrElt] -> [(GlobalRdrElt,GlobalRdrElt)]
pickGREsModExp mod gres = mapMaybe (pickBothGRE mod) gres
pickBothGRE :: ModuleName -> GlobalRdrElt -> Maybe (GlobalRdrElt, GlobalRdrElt)
pickBothGRE mod gre@(GRE { gre_name = n })
| isBuiltInSyntax n = Nothing
| Just gre1 <- pickQualGRE mod gre
, Just gre2 <- pickUnqualGRE gre = Just (gre1, gre2)
| otherwise = Nothing
where
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
(greOccName 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
plusGRE g1 g2
= GRE { gre_name = gre_name g1
, gre_lcl = gre_lcl g1 || gre_lcl g2
, gre_imp = gre_imp g1 ++ gre_imp 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
extendGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrElt -> GlobalRdrEnv
extendGlobalRdrEnv env gre
= extendOccEnv_Acc insertGRE singleton env
(greOccName gre) gre
shadowNames :: GlobalRdrEnv -> [Name] -> GlobalRdrEnv
shadowNames = foldl shadowName
shadowName :: GlobalRdrEnv -> Name -> GlobalRdrEnv
shadowName env name
= alterOccEnv (fmap alter_fn) env (nameOccName name)
where
alter_fn :: [GlobalRdrElt] -> [GlobalRdrElt]
alter_fn gres = mapMaybe (shadow_with name) gres
shadow_with :: Name -> GlobalRdrElt -> Maybe GlobalRdrElt
shadow_with new_name
old_gre@(GRE { gre_name = old_name, gre_lcl = lcl, gre_imp = iss })
= case nameModule_maybe old_name of
Nothing -> Just old_gre
Just old_mod
| Just new_mod <- nameModule_maybe new_name
, new_mod == old_mod
-> Nothing
| null iss'
-> Nothing
| otherwise
-> Just (old_gre { gre_lcl = False, gre_imp = iss' })
where
iss' = lcl_imp ++ mapMaybe (shadow_is new_name) iss
lcl_imp | lcl = [mk_fake_imp_spec old_name old_mod]
| otherwise = []
mk_fake_imp_spec old_name old_mod
= ImpSpec id_spec ImpAll
where
old_mod_name = moduleName old_mod
id_spec = ImpDeclSpec { is_mod = old_mod_name
, is_as = old_mod_name
, is_qual = True
, is_dloc = nameSrcSpan old_name }
shadow_is :: Name -> ImportSpec -> Maybe ImportSpec
shadow_is new_name is@(ImpSpec { is_decl = id_spec })
| Just new_mod <- nameModule_maybe new_name
, is_as id_spec == moduleName new_mod
= Nothing
| otherwise
= Just (is { is_decl = id_spec { is_qual = True } })
data ImportSpec = ImpSpec { is_decl :: ImpDeclSpec,
is_item :: ImpItemSpec }
deriving( Eq, Ord, Data )
data ImpDeclSpec
= ImpDeclSpec {
is_mod :: ModuleName,
is_as :: ModuleName,
is_qual :: Bool,
is_dloc :: SrcSpan
} deriving Data
data ImpItemSpec
= ImpAll
| ImpSome {
is_explicit :: Bool,
is_iloc :: SrcSpan
}
deriving Data
instance Eq ImpDeclSpec where
p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False
instance Ord ImpDeclSpec where
compare is1 is2 = (is_mod is1 `compare` is_mod is2) `thenCmp`
(is_dloc is1 `compare` is_dloc is2)
instance Eq ImpItemSpec where
p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False
instance Ord ImpItemSpec where
compare is1 is2 =
case (is1, is2) of
(ImpAll, ImpAll) -> EQ
(ImpAll, _) -> GT
(_, ImpAll) -> LT
(ImpSome _ l1, ImpSome _ l2) -> l1 `compare` l2
bestImport :: [ImportSpec] -> ImportSpec
bestImport iss
= case sortBy best iss of
(is:_) -> is
[] -> pprPanic "bestImport" (ppr iss)
where
best :: ImportSpec -> ImportSpec -> Ordering
best (ImpSpec { is_item = item1, is_decl = d1 })
(ImpSpec { is_item = item2, is_decl = d2 })
= best_item item1 item2 `thenCmp` (is_dloc d1 `compare` is_dloc d2)
best_item :: ImpItemSpec -> ImpItemSpec -> Ordering
best_item ImpAll ImpAll = EQ
best_item ImpAll (ImpSome {}) = GT
best_item (ImpSome {}) ImpAll = LT
best_item (ImpSome { is_explicit = e1 })
(ImpSome { is_explicit = e2 }) = e2 `compare` e1
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
pprNameProvenance :: GlobalRdrElt -> SDoc
pprNameProvenance (GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss })
= ifPprDebug (vcat pp_provs)
(head pp_provs)
where
pp_provs = pp_lcl ++ map pp_is iss
pp_lcl = if lcl then [text "defined at" <+> ppr (nameSrcLoc name)]
else []
pp_is is = sep [ppr is, ppr_defn_site is name]
ppr_defn_site :: ImportSpec -> Name -> SDoc
ppr_defn_site imp_spec name
| same_module && not (isGoodSrcSpan loc)
= empty
| otherwise
= parens $ hang (text "and originally defined" <+> pp_mod)
2 (pprLoc loc)
where
loc = nameSrcSpan name
defining_mod = ASSERT2( isExternalName name, ppr name ) nameModule name
same_module = importSpecModule imp_spec == moduleName defining_mod
pp_mod | same_module = empty
| otherwise = text "in" <+> quotes (ppr defining_mod)
instance Outputable ImportSpec where
ppr imp_spec
= text "imported" <+> qual
<+> text "from" <+> quotes (ppr (importSpecModule imp_spec))
<+> pprLoc (importSpecLoc imp_spec)
where
qual | is_qual (is_decl imp_spec) = text "qualified"
| otherwise = empty
pprLoc :: SrcSpan -> SDoc
pprLoc (RealSrcSpan s) = text "at" <+> ppr s
pprLoc (UnhelpfulSpan {}) = empty