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,
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_Field_Name, getGRE_NameQualifier_maybes,
transformGREs, pickGREs, pickGREsModExp,
gresFromAvails, gresFromAvail, localGREsFromAvail, availFromGRE,
greUsedRdrName, greRdrNames, greSrcSpan, greQualModName,
GlobalRdrElt(..), isLocalGRE, isRecFldGRE, greLabel,
unQualOK, qualSpecOK, unQualSpecOK,
pprNameProvenance,
Parent(..),
ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..),
importSpecLoc, importSpecModule, isExplicitItem, bestImport
) where
#include "HsVersions.h"
import Module
import Name
import Avail
import NameSet
import Maybes
import SrcLoc
import FastString
import FieldLabel
import Outputable
import Unique
import Util
import StaticFlags( opt_PprStyle_Debug )
import Data.Data
import Data.List( sortBy )
data RdrName
= Unqual OccName
| Qual ModuleName OccName
| Orig Module OccName
| Exact Name
deriving (Data, Typeable)
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
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 ="
<+> braces (pprWithCommas ppr (nameSetElems ns))
] <+> 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, Typeable)
data Parent = NoParent
| ParentIs { par_is :: Name }
| FldParent { par_is :: Name, par_lbl :: Maybe FieldLabelString }
| PatternSynonym
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
ppr (PatternSynonym) = text "pattern synonym"
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 PatternSynonym PatternSynonym = PatternSynonym
plusParent _ _ = NoParent
hasParent :: Parent -> Parent -> Parent
#ifdef 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 lbl is_overloaded 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 NotPatSyn _) = NoParent
mkParent _ (Avail IsPatSyn _) = PatternSynonym
mkParent n (AvailTC m _ _) | n == m = NoParent
| otherwise = ParentIs m
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 Nothing -> AvailTC p [] [FieldLabel (occNameFS $ nameOccName me) False me]
FldParent p (Just lbl) -> AvailTC p [] [FieldLabel lbl True me]
PatternSynonym -> patSynAvail 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 -> [GlobalRdrElt]
lookupGRE_Name env name
= [ gre | gre <- lookupGlobalRdrEnv env (nameOccName name),
gre_name gre == name ]
lookupGRE_Field_Name :: GlobalRdrEnv -> Name -> FastString -> [GlobalRdrElt]
lookupGRE_Field_Name env sel_name lbl
= [ gre | gre <- lookupGlobalRdrEnv env (mkVarOccFS lbl),
gre_name gre == sel_name ]
getGRE_NameQualifier_maybes :: GlobalRdrEnv -> Name -> [Maybe [ModuleName]]
getGRE_NameQualifier_maybes env
= map (qualifier_maybe) . lookupGRE_Name env
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, Typeable )
data ImpDeclSpec
= ImpDeclSpec {
is_mod :: ModuleName,
is_as :: ModuleName,
is_qual :: Bool,
is_dloc :: SrcSpan
} deriving (Data, Typeable)
data ImpItemSpec
= ImpAll
| ImpSome {
is_explicit :: Bool,
is_iloc :: SrcSpan
}
deriving (Data, Typeable)
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 = is_iloc is1 `compare` is_iloc is2
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 })
| opt_PprStyle_Debug = vcat pp_provs
| otherwise = 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 = 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