module RnNames (
getGlobalNames,
- GlobalNameInfo(..)
+ SYN_IE(GlobalNameInfo)
) where
-import PreludeGlaST ( MutableVar(..) )
+import PreludeGlaST ( SYN_IE(MutableVar) )
-import Ubiq
+IMP_Ubiq()
import HsSyn
import RdrHsSyn
import RnHsSyn
import RnMonad
-import RnIfaces ( IfaceCache(..), cachedIface, cachedDecl )
-import RnUtils ( RnEnv(..), emptyRnEnv, extendGlobalRnEnv,
- lubExportFlag, qualNameErr, dupNamesErr, negateNameWarn )
-import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst )
+import RnIfaces ( IfaceCache, cachedIface, cachedDecl, CachingResult(..) )
+import RnUtils ( SYN_IE(RnEnv), emptyRnEnv, initRnEnv, extendGlobalRnEnv,
+ lubExportFlag, qualNameErr, dupNamesErr, pprRnEnv
+ )
+import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), ExportsMap(..), RdrIfaceInst )
import Bag ( emptyBag, unitBag, consBag, snocBag, unionBags,
- unionManyBags, mapBag, filterBag, listToBag, bagToList )
-import CmdLineOpts ( opt_NoImplicitPrelude )
-import ErrUtils ( Error(..), Warning(..), addErrLoc, addShortErrLocLine )
-import FiniteMap ( emptyFM, addListToFM, lookupFM, fmToList, eltsFM, delListFromFM )
+ unionManyBags, mapBag, foldBag, filterBag, listToBag, bagToList )
+import CmdLineOpts ( opt_NoImplicitPrelude, opt_CompilingGhcInternals )
+import ErrUtils ( SYN_IE(Error), SYN_IE(Warning), addErrLoc, addShortErrLocLine, addShortWarnLocLine )
+import FiniteMap ( emptyFM, addToFM, addListToFM, lookupFM, fmToList, eltsFM, delListFromFM, FiniteMap )
import Id ( GenId )
import Maybes ( maybeToBool, catMaybes, MaybeErr(..) )
-import Name ( RdrName(..), Name, isQual, mkTopLevName, origName,
- mkImportedName, nameExportFlag, nameImportFlag,
- getLocalName, getSrcLoc, getImpLocs, moduleNamePair,
- pprNonSym, isLexCon, isRdrLexCon, ExportFlag(..)
+import Name ( RdrName(..), Name, isQual, mkTopLevName, mkWiredInName, origName,
+ nameOf, qualToOrigName, mkImportedName,
+ nameExportFlag, nameImportFlag,
+ getLocalName, getSrcLoc, getImpLocs,
+ moduleNamePair, pprNonSym,
+ isLexCon, isLexSpecialSym, ExportFlag(..), OrigName(..)
)
-import PrelInfo ( BuiltinNames(..), BuiltinKeys(..) )
-import PrelMods ( fromPrelude, pRELUDE )
+import PrelInfo ( SYN_IE(BuiltinNames), SYN_IE(BuiltinKeys) )
+import PrelMods ( pRELUDE, gHC_BUILTINS, modulesWithBuiltins )
import Pretty
import SrcLoc ( SrcLoc, mkBuiltinSrcLoc )
import TyCon ( tyConDataCons )
import UniqFM ( emptyUFM, addListToUFM_C, lookupUFM )
import UniqSupply ( splitUniqSupply )
import Util ( isIn, assoc, cmpPString, sortLt, removeDups,
- equivClasses, panic, assertPanic )
+ equivClasses, panic, assertPanic
+ )
+--import PprStyle --ToDo:rm
\end{code}
-
\begin{code}
type GlobalNameInfo = (BuiltinNames,
BuiltinKeys,
Name -> ExportFlag, -- export flag
- Name -> [RdrName]) -- occurence names
+ Name -> [RdrName]) -- occurrence names
+ -- NB: both of the functions are in a *knot* and
+ -- must be tugged on oh-so-gently...
type RnM_Info s r = RnMonad GlobalNameInfo s r
getGlobalNames iface_cache info us
(HsModule mod _ _ imports _ ty_decls _ cls_decls _ _ _ binds _ _)
- = case initRn True mod emptyRnEnv us1
+ = let
+ (us1, us2) = splitUniqSupply us
+ in
+ case initRn True mod emptyRnEnv us1
(setExtraRn info $
getSourceNames ty_decls cls_decls binds)
of { ((src_vals, src_tcs), src_errs, src_warns) ->
unqual_vals = map (\rn -> (Unqual (getLocalName rn), rn)) (bagToList src_vals)
unqual_tcs = map (\rn -> (Unqual (getLocalName rn), rn)) (bagToList src_tcs)
- (src_env, src_dups) = extendGlobalRnEnv emptyRnEnv unqual_vals unqual_tcs
+ (src_env, src_dups) = extendGlobalRnEnv initRnEnv unqual_vals unqual_tcs
(all_env, imp_dups) = extendGlobalRnEnv src_env (bagToList imp_vals) (bagToList imp_tcs)
-- remove dups of the same imported thing
diff_imp_dups = filterBag diff_orig imp_dups
- diff_orig (_,rn1,rn2) = origName rn1 /= origName rn2
+ diff_orig (_,rn1,rn2) = origName "diff_orig" rn1 /= origName "diff_orig" rn2
all_dups = bagToList (src_dups `unionBags` diff_imp_dups)
dup_errs = map dup_err (equivClasses cmp_rdr all_dups)
all_errs = src_errs `unionBags` imp_errs `unionBags` listToBag dup_errs
all_warns = src_warns `unionBags` imp_warns
in
- return (all_env, imp_mods, unqual_imps, imp_fixes, all_errs, all_warns)
- }
- where
- (us1, us2) = splitUniqSupply us
+-- pprTrace "initRnEnv:" (pprRnEnv PprDebug initRnEnv) $
+-- pprTrace "src_env:" (pprRnEnv PprDebug src_env) $
+-- pprTrace "all_env:" (pprRnEnv PprDebug all_env) $
+ return (all_env, imp_mods, unqual_imps, imp_fixes, all_errs, all_warns) }
\end{code}
*********************************************************
*********************************************************
\begin{code}
-getSourceNames ::
+getSourceNames :: -- Collects global *binders* (not uses)
[RdrNameTyDecl]
-> [RdrNameClassDecl]
-> RdrNameHsBinds
unionManyBags cls_ops_s `unionBags` bind_names,
listToBag tycon_s `unionBags` listToBag cls_s)
-
+--------------
getTyDeclNames :: RdrNameTyDecl
-> RnM_Info s (RnName, Bag RnName, Bag RnName) -- tycon, constrs and fields
getTyDeclNames (TyData _ tycon _ condecls _ _ src_loc)
- = newGlobalName src_loc Nothing tycon `thenRn` \ tycon_name ->
+ = --getExtraRn `thenRn` \ ((b_val_names,b_tc_names),b_keys,rec_exp_fn,rec_occ_fn) ->
+ --pprTrace "getTyDeclNames:" (ppr PprDebug tycon) $
+ --pprTrace "getTDN1:" (ppAboves [ ppCat [ppPStr m, ppPStr n] | ((OrigName m n), _) <- fmToList b_tc_names]) $
+
+ newGlobalName src_loc Nothing False{-not val-} tycon `thenRn` \ tycon_name ->
getConFieldNames (Just (nameExportFlag tycon_name)) emptyBag emptyBag emptyFM
condecls `thenRn` \ (con_names, field_names) ->
let
returnRn (rn_tycon, listToBag rn_constrs, listToBag rn_fields)
getTyDeclNames (TyNew _ tycon _ [NewConDecl con _ con_loc] _ _ src_loc)
- = newGlobalName src_loc Nothing tycon `thenRn` \ tycon_name ->
- newGlobalName con_loc (Just (nameExportFlag tycon_name)) con
+ = newGlobalName src_loc Nothing False{-not val-} tycon `thenRn` \ tycon_name ->
+ newGlobalName con_loc (Just (nameExportFlag tycon_name)) True{-val-} con
`thenRn` \ con_name ->
returnRn (RnData tycon_name [con_name] [],
unitBag (RnConstr con_name tycon_name),
emptyBag)
getTyDeclNames (TySynonym tycon _ _ src_loc)
- = newGlobalName src_loc Nothing tycon `thenRn` \ tycon_name ->
+ = newGlobalName src_loc Nothing False{-not val-} tycon `thenRn` \ tycon_name ->
returnRn (RnSyn tycon_name, emptyBag, emptyBag)
+----------------
+getConFieldNames :: Maybe ExportFlag
+ -> Bag Name -> Bag Name
+ -> FiniteMap RdrName ()
+ -> [RdrNameConDecl]
+ -> RnM_Info s ([Name], [Name])
getConFieldNames exp constrs fields have []
= returnRn (bagToList constrs, bagToList fields)
getConFieldNames exp constrs fields have (ConDecl con _ src_loc : rest)
- = newGlobalName src_loc exp con `thenRn` \ con_name ->
+ = newGlobalName src_loc exp True{-val-} con `thenRn` \ con_name ->
getConFieldNames exp (constrs `snocBag` con_name) fields have rest
getConFieldNames exp constrs fields have (ConOpDecl _ con _ src_loc : rest)
- = newGlobalName src_loc exp con `thenRn` \ con_name ->
+ = newGlobalName src_loc exp True{-val-} con `thenRn` \ con_name ->
getConFieldNames exp (constrs `snocBag` con_name) fields have rest
getConFieldNames exp constrs fields have (RecConDecl con fielddecls src_loc : rest)
= mapRn (addErrRn . dupFieldErr con src_loc) dups `thenRn_`
- newGlobalName src_loc exp con `thenRn` \ con_name ->
- mapRn (newGlobalName src_loc exp) new_fields `thenRn` \ field_names ->
+ newGlobalName src_loc exp True{-val-} con `thenRn` \ con_name ->
+ mapRn (newGlobalName src_loc exp True{-val-}) new_fields `thenRn` \ field_names ->
let
all_constrs = constrs `snocBag` con_name
all_fields = fields `unionBags` listToBag field_names
new_fields = filter (not . maybeToBool . lookupFM have) uniq_fields
new_have = addListToFM have (zip new_fields (repeat ()))
+-------------
getClassNames :: RdrNameClassDecl
-> RnM_Info s (RnName, Bag RnName) -- class and class ops
getClassNames (ClassDecl _ cname _ sigs _ _ src_loc)
- = newGlobalName src_loc Nothing cname `thenRn` \ class_name ->
+ = newGlobalName src_loc Nothing False{-notval-} cname `thenRn` \ class_name ->
getClassOpNames (Just (nameExportFlag class_name))
sigs `thenRn` \ op_names ->
returnRn (RnClass class_name op_names,
listToBag (map (\ n -> RnClassOp n class_name) op_names))
-getClassOpNames exp []
- = returnRn []
+---------------
+getClassOpNames :: Maybe ExportFlag
+ -> [RdrNameSig]
+ -> RnM_Info s [Name]
+
+getClassOpNames exp [] = returnRn []
+
getClassOpNames exp (ClassOpSig op _ _ src_loc : sigs)
- = newGlobalName src_loc exp op `thenRn` \ op_name ->
+ = newGlobalName src_loc exp True{-val-} op `thenRn` \ op_name ->
getClassOpNames exp sigs `thenRn` \ op_names ->
returnRn (op_name : op_names)
getClassOpNames exp (_ : sigs)
doField locn (_, pat, _) = doPat locn pat
doName locn rdr
- = newGlobalName locn Nothing rdr `thenRn` \ name ->
+ = newGlobalName locn Nothing True{-val-} rdr `thenRn` \ name ->
returnRn (unitBag (RnName name))
\end{code}
*********************************************************
\begin{code}
-newGlobalName :: SrcLoc -> Maybe ExportFlag
- -> RdrName -> RnM_Info s Name
+newGlobalName :: SrcLoc
+ -> Maybe ExportFlag
+ -> Bool{-True<=>value name,False<=>tycon/class-}
+ -> RdrName
+ -> RnM_Info s Name
+
+newGlobalName locn maybe_exp is_val_name (Unqual name)
+ = getExtraRn `thenRn` \ ((b_val_names,b_tc_names),b_keys,rec_exp_fn,rec_occ_fn) ->
+ getModuleRn `thenRn` \ mod ->
+ rnGetUnique `thenRn` \ u ->
+ let
+ orig = OrigName mod name
+
+ (uniq, is_toplev)
+ = case (lookupFM b_keys orig) of
+ Just (key,_) -> (key, True)
+ Nothing -> if not opt_CompilingGhcInternals then (u,True) else -- really here just to save gratuitous lookup
+ case (lookupFM (if is_val_name then b_val_names else b_tc_names) orig) of
+ Nothing -> (u, True)
+ Just xx -> (uniqueOf xx, False{-builtin!-})
+
+ exp = case maybe_exp of
+ Just flag -> flag
+ Nothing -> rec_exp_fn n
+
+ n = if is_toplev
+ then mkTopLevName uniq orig locn exp (rec_occ_fn n) -- NB: two "n"s
+ else mkWiredInName uniq orig exp
+ in
+ returnRn n
--- ToDo: b_names and b_keys being defined in this module !!!
+newGlobalName locn maybe_exp is_val_name rdr@(Qual mod name)
+ | opt_CompilingGhcInternals
+ -- we are actually defining something that compiler knows about (e.g., Bool)
-newGlobalName locn maybe_exp rdr
- = getExtraRn `thenRn` \ (_,b_keys,exp_fn,occ_fn) ->
- getModuleRn `thenRn` \ mod ->
- rnGetUnique `thenRn` \ u ->
+ = getExtraRn `thenRn` \ ((b_val_names,b_tc_names),b_keys,rec_exp_fn,rec_occ_fn) ->
let
- (uniq, unqual)
- = case rdr of
- Qual m n -> (u, n)
- Unqual n -> case (lookupFM b_keys n) of
- Nothing -> (u, n)
- Just (key,_) -> (key, n)
+ orig = OrigName mod name
- orig = if fromPrelude mod
- then (Unqual unqual)
- else (Qual mod unqual)
+ (uniq, is_toplev)
+ = case (lookupFM b_keys orig) of
+ Just (key,_) -> (key, True)
+ Nothing -> case (lookupFM (if is_val_name then b_val_names else b_tc_names) orig) of
+ Nothing -> (panic "newGlobalName:Qual:uniq", True)
+ Just xx -> (uniqueOf xx, False{-builtin!-})
exp = case maybe_exp of
- Just exp -> exp
- Nothing -> exp_fn n
+ Just flag -> flag
+ Nothing -> rec_exp_fn n
- n = mkTopLevName uniq orig locn exp (occ_fn n)
+ n = if is_toplev
+ then mkTopLevName uniq orig locn exp (rec_occ_fn n) -- NB: two "n"s
+ else mkWiredInName uniq orig exp
in
- addWarnIfRn (rdr == Unqual SLIT("negate")) (negateNameWarn (rdr, locn)) `thenRn_`
- addErrIfRn (isQual rdr) (qualNameErr "name in definition" (rdr, locn)) `thenRn_`
returnRn n
+
+ | otherwise
+ = addErrRn (qualNameErr "name in definition" (rdr, locn)) `thenRn_`
+ returnRn (panic "newGlobalName:Qual")
\end{code}
*********************************************************
*********************************************************
\begin{code}
-type ImportNameInfo = (GlobalNameInfo,
- FiniteMap (Module,FAST_STRING) RnName, -- values imported so far
- FiniteMap (Module,FAST_STRING) RnName, -- tycons/classes imported so far
- Name -> (ExportFlag, [SrcLoc])) -- import flag and src locns
-
+type ImportNameInfo
+ = (GlobalNameInfo,
+ FiniteMap OrigName RnName, -- values imported so far
+ FiniteMap OrigName RnName, -- tycons/classes imported so far
+ Name -> (ExportFlag, [SrcLoc])) -- import flag and src locns;
+ -- NB: this last field is in a knot
+ -- and mustn't be tugged on!
+
type RnM_IInfo s r = RnMonad ImportNameInfo s r
+------------------------------------------------------------------
doImportDecls ::
IfaceCache
- -> GlobalNameInfo -- builtin and knot name info
+ -> GlobalNameInfo -- builtin and knot name info
-> UniqSupply
- -> [RdrNameImportDecl] -- import declarations
- -> IO (Bag (RdrName,RnName), -- imported values in scope
- Bag (RdrName,RnName), -- imported tycons/classes in scope
- [Module], -- directly imported modules
- Bag (Module,RnName), -- unqualified import from module
- Bag RenamedFixityDecl, -- fixity info for imported names
+ -> [RdrNameImportDecl] -- import declarations
+ -> IO (Bag (RdrName,RnName), -- imported values in scope
+ Bag (RdrName,RnName), -- imported tycons/classes in scope
+ [Module], -- directly imported modules
+ Bag (Module,RnName), -- unqualified import from module
+ Bag RenamedFixityDecl, -- fixity info for imported names
Bag Error,
Bag Warning)
rec_imp_fn :: Name -> (ExportFlag, [SrcLoc])
rec_imp_fn n = case lookupUFM rec_imp_fm n of
- Nothing -> panic "RnNames:rec_imp_fn"
+ Nothing -> (NotExported,[mkBuiltinSrcLoc])
+ -- panic "RnNames:rec_imp_fn"
+ -- but the panic can show up
+ -- in error messages
Just (flag, locns) -> (flag, bagToList locns)
i_info = (g_info, emptyFM, emptyFM, rec_imp_fn)
in
+ -- cache the imported modules
+ -- this ensures that all directly imported modules
+ -- will have their original name iface in scope
+ -- pprTrace "doImportDecls:" (ppCat (map ppPStr imp_mods)) $
+ accumulate (map (cachedIface iface_cache False SLIT("doImportDecls")) imp_mods) >>
+
+ -- process the imports
doImports iface_cache i_info us all_imps
+
) >>= \ (vals, tcs, unquals, fixes, errs, warns, _) ->
return (vals, tcs, imp_mods, unquals, fixes,
- errs, imp_warns `unionBags` warns)
+ imp_errs `unionBags` errs,
+ imp_warns `unionBags` warns)
where
- (src_qprels, ok_imps) = partition qual_prel src_imps
- the_imps = ok_imps ++ prel_imp
- all_imps = the_imps ++ qprel_imp
-
- qual_prel (ImportDecl mod qual imp_as _ _)
- = fromPrelude mod && qual && not (maybeToBool imp_as)
-
- explicit_prelude_import
- = null [() | (ImportDecl mod qual _ _ _) <- ok_imps, fromPrelude mod]
+ all_imps = implicit_prel ++ src_imps
+-- all_imps = implicit_qprel ++ the_imps
- qprel_imp = if opt_NoImplicitPrelude
- then [{-the flag really means it: *NO* implicit "import Prelude" -}]
- else [ImportDecl pRELUDE True Nothing Nothing prel_loc]
+ explicit_prelude_imp
+ = not (null [ () | (ImportDecl mod qual _ _ _) <- src_imps, mod == pRELUDE ])
- prel_imp = if not explicit_prelude_import || opt_NoImplicitPrelude
- then
- [{- no "import Prelude" -}]
- else
- [ImportDecl pRELUDE False Nothing Nothing prel_loc]
+ implicit_prel | opt_NoImplicitPrelude = []
+ | explicit_prelude_imp = [ImportDecl pRELUDE True Nothing Nothing prel_loc]
+ | otherwise = [ImportDecl pRELUDE False Nothing Nothing prel_loc]
prel_loc = mkBuiltinSrcLoc
- (uniq_imps, imp_dups) = removeDups cmp_mod the_imps
+ (uniq_imps, imp_dups) = removeDups cmp_mod all_imps
cmp_mod (ImportDecl m1 _ _ _ _) (ImportDecl m2 _ _ _ _) = cmpPString m1 m2
+ qprel_imps = [ imp | imp@(ImportDecl mod True Nothing _ _) <- src_imps,
+ mod == pRELUDE ]
+
+ qual_mods = [ (qual_name mod as_mod, imp) | imp@(ImportDecl mod True as_mod _ _) <- src_imps ]
+ qual_name mod (Just as_mod) = as_mod
+ qual_name mod Nothing = mod
+
+ (_, qual_dups) = removeDups cmp_qual qual_mods
+ bad_qual_dups = filter (not . all_same_mod) qual_dups
+
+ cmp_qual (q1,_) (q2,_) = cmpPString q1 q2
+ all_same_mod ((q,ImportDecl mod _ _ _ _):rest)
+ = all has_same_mod rest
+ where
+ has_same_mod (_,ImportDecl mod2 _ _ _ _) = mod == mod2
+
imp_mods = [ mod | ImportDecl mod _ _ _ _ <- uniq_imps ]
+
imp_warns = listToBag (map dupImportWarn imp_dups)
`unionBags`
- listToBag (map qualPreludeImportWarn src_qprels)
-
+ listToBag (map qualPreludeImportWarn qprel_imps)
+
+ imp_errs = listToBag (map dupQualImportErr bad_qual_dups)
+
+-----------------------
+doImports :: IfaceCache
+ -> ImportNameInfo
+ -> UniqSupply
+ -> [RdrNameImportDecl] -- import declarations
+ -> IO (Bag (RdrName,RnName), -- imported values in scope
+ Bag (RdrName,RnName), -- imported tycons/classes in scope
+ Bag (Module, RnName), -- unqualified import from module
+ Bag RenamedFixityDecl, -- fixity info for imported names
+ Bag Error,
+ Bag Warning,
+ Bag (RnName,(ExportFlag,Bag SrcLoc))) -- import flags and src locs
doImports iface_cache i_info us []
= return (emptyBag, emptyBag, emptyBag, emptyBag, emptyBag, emptyBag, emptyBag)
-doImports iface_cache i_info@(g_info,done_vals,done_tcs,imp_fn) us (imp:imps)
- = doImport iface_cache i_info us1 imp
+
+doImports iface_cache i_info@(g_info,done_vals,done_tcs,rec_imp_fn) us (imp:imps)
+ = let
+ (us1, us2) = splitUniqSupply us
+ in
+ doImport iface_cache i_info us1 imp
>>= \ (vals1, tcs1, unquals1, fixes1, errs1, warns1, imps1) ->
let
- new_vals = [ (moduleNamePair rn, rn) | (_,rn) <- bagToList vals1,
- not (maybeToBool (lookupFM done_vals (moduleNamePair rn))) ]
- -- moduleNamePair computed twice
- ext_vals = addListToFM done_vals new_vals
-
- new_tcs = [ (moduleNamePair rn, rn) | (_,rn) <- bagToList tcs1,
- not (maybeToBool (lookupFM done_tcs (moduleNamePair rn))) ]
- ext_tcs = addListToFM done_tcs new_tcs
+ ext_vals = foldl add_new_one done_vals (bagToList vals1)
+ ext_tcs = foldl add_new_one done_tcs (bagToList tcs1)
in
- doImports iface_cache (g_info,ext_vals,ext_tcs,imp_fn) us2 imps
+ doImports iface_cache (g_info,ext_vals,ext_tcs,rec_imp_fn) us2 imps
>>= \ (vals2, tcs2, unquals2, fixes2, errs2, warns2, imps2) ->
return (vals1 `unionBags` vals2,
tcs1 `unionBags` tcs2,
warns1 `unionBags` warns2,
imps1 `unionBags` imps2)
where
- (us1, us2) = splitUniqSupply us
+ add_new_one :: FiniteMap OrigName RnName -- ones done so far
+ -> (dont_care, RnName)
+ -> FiniteMap OrigName RnName -- extended
+ add_new_one fm (_, rn)
+ = let
+ orig = origName "add_new_one" rn
+ in
+ case (lookupFM fm orig) of
+ Just _ -> fm -- already there: no change
+ Nothing -> addToFM fm orig rn
+----------------------
doImport :: IfaceCache
-> ImportNameInfo
-> UniqSupply
Bag (RnName,(ExportFlag,Bag SrcLoc))) -- import flags and src locs
doImport iface_cache info us (ImportDecl mod qual maybe_as maybe_spec src_loc)
- = cachedIface iface_cache mod >>= \ maybe_iface ->
+ = --let
+ -- (b_vals, b_tcs, maybe_spec')
+ -- = (emptyBag, emptyBag, maybe_spec)
+ --in
+ --pprTrace "doImport:" (ppPStr mod) $
+ cachedIface iface_cache False SLIT("doImport") mod >>= \ maybe_iface ->
+ return (maybe_iface, \ iface -> getOrigIEs iface maybe_spec)
+ >>= \ (maybe_iface, do_ies) ->
+
case maybe_iface of
Failed err ->
return (emptyBag, emptyBag, emptyBag, emptyBag,
unitBag err, emptyBag, emptyBag)
Succeeded iface ->
let
- (b_vals, b_tcs, maybe_spec') = getBuiltins info mod maybe_spec
- (ies, chk_ies, get_errs) = getOrigIEs iface maybe_spec'
+ (ies, chk_ies, get_errs) = do_ies iface
in
doOrigIEs iface_cache info mod src_loc us ies
>>= \ (ie_vals, ie_tcs, imp_flags, errs, warns) ->
accumulate (map (checkOrigIE iface_cache) chk_ies)
>>= \ chk_errs_warns ->
- accumulate (map (getFixityDecl iface_cache) (bagToList ie_vals))
- >>= \ fix_maybes_errs ->
+ let
+ fold_ies = foldBag unionBags pair_occ emptyBag
+
+ final_vals = {-OLD:mapBag fst_occ b_vals `unionBags`-} fold_ies ie_vals
+ final_tcs = {-OLD:mapBag fst_occ b_tcs `unionBags`-} fold_ies ie_tcs
+ final_vals_list = bagToList final_vals
+ in
+ accumulate (map (getFixityDecl iface_cache . snd) final_vals_list)
+ >>= \ fix_maybes_errs ->
let
(chk_errs, chk_warns) = unzip chk_errs_warns
(fix_maybes, fix_errs) = unzip fix_maybes_errs
- final_vals = mapBag fst_occ b_vals `unionBags` mapBag pair_occ ie_vals
- final_tcs = mapBag fst_occ b_tcs `unionBags` mapBag pair_occ ie_tcs
-
- unquals = if qual then emptyBag
+ unquals = if qual{-ified import-}
+ then emptyBag
else mapBag pair_as (ie_vals `unionBags` ie_tcs)
final_fixes = listToBag (catMaybes fix_maybes)
return (final_vals, final_tcs, unquals, final_fixes,
final_errs, final_warns, imp_stuff)
where
+ as_mod :: Module
as_mod = case maybe_as of {Nothing -> mod; Just as_this -> as_this}
+
+ mk_occ :: FAST_STRING -> RdrName
mk_occ str = if qual then Qual as_mod str else Unqual str
+ fst_occ :: (FAST_STRING, RnName) -> (RdrName, RnName)
fst_occ (str, rn) = (mk_occ str, rn)
- pair_occ rn = (mk_occ (getLocalName rn), rn)
- pair_as rn = (as_mod, rn)
-
-getBuiltins _ mod maybe_spec
- | not (fromPrelude mod)
+ pair_occ :: RnName -> Bag (RdrName, RnName)
+ pair_occ rn
+ = let
+ str = getLocalName rn
+ qual_bag = unitBag (Qual as_mod str, rn)
+ in
+ if qual
+ then qual_bag
+ else qual_bag -- the qualified name is *also* visible
+ `snocBag` (Unqual str, rn)
+
+
+ pair_as :: RnName -> (Module, RnName)
+ pair_as rn = (as_mod, rn)
+
+-----------------------------
+{-
+getBuiltins :: ImportNameInfo
+ -> Module
+ -> Maybe (Bool, [RdrNameIE])
+ -> (Bag (FAST_STRING, RnName),
+ Bag (FAST_STRING, RnName),
+ Maybe (Bool, [RdrNameIE]) -- return IEs that had no effect
+ )
+
+getBuiltins _ modname maybe_spec
+-- | modname `notElem` modulesWithBuiltins
= (emptyBag, emptyBag, maybe_spec)
-getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) mod maybe_spec
+getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) modname maybe_spec
= case maybe_spec of
Nothing -> (all_vals, all_tcs, Nothing)
Just (True, ies) -> -- hiding does not work for builtin names
+ trace "NOTE: `import Prelude hiding ...' does not hide built-in names" $
(all_vals, all_tcs, maybe_spec)
Just (False, ies) -> let
all_tcs = do_all_builtin (fmToList b_tc_names)
do_all_builtin [] = emptyBag
- do_all_builtin ((str,rn):rest)
- = (str, rn) `consBag` do_all_builtin rest
+ do_all_builtin (((OrigName mod str),rn):rest)
+ = --pprTrace "do_all_builtin:" (ppCat [ppPStr modname, ppPStr mod, ppPStr str]) $
+ (if mod == modname then consBag (str, rn) else id) (do_all_builtin rest)
do_builtin [] = (emptyBag,emptyBag,[])
do_builtin (ie:ies)
- = let str = unqual_str (ie_name ie)
+ = let
+ (str, orig)
+ = case (ie_name ie) of
+ Unqual s -> (s, OrigName modname s)
+ Qual m s -> --pprTrace "do_builtin:surprising qual!" (ppCat [ppPStr m, ppPStr s]) $
+ (s, OrigName modname s)
in
- case (lookupFM b_tc_names str) of -- NB: we favour the tycon/class FM...
+ case (lookupFM b_tc_names orig) of -- NB: we favour the tycon/class FM...
Just rn -> case (ie,rn) of
(IEThingAbs _, WiredInTyCon tc)
-> (vals, (str, rn) `consBag` tcs, ies_left)
(tyConDataCons tc))
`unionBags` vals,
(str,rn) `consBag` tcs, ies_left)
+ (IEThingWith _ _, WiredInTyCon tc) -- No checking of With...
+ -> (listToBag (map (\ id -> (nameOf (origName "IEThingWith" id), WiredInId id))
+ (tyConDataCons tc))
+ `unionBags` vals,
+ (str,rn) `consBag` tcs, ies_left)
_ -> panic "importing builtin names (1)"
Nothing ->
- case (lookupFM b_val_names str) of
+ case (lookupFM b_val_names orig) of
Nothing -> (vals, tcs, ie:ies_left)
Just rn -> case (ie,rn) of
(IEVar _, WiredInId _)
_ -> panic "importing builtin names (2)"
where
(vals, tcs, ies_left) = do_builtin ies
+-}
+-------------------------
+getOrigIEs :: ParsedIface
+ -> Maybe (Bool, [RdrNameIE]) -- "hiding" or not, blah, blah, blah
+ -> ([IE OrigName],
+ [(IE OrigName, ExportFlag)],
+ Bag (Module -> SrcLoc -> Error))
-getOrigIEs (ParsedIface _ _ _ _ exps _ _ _ _ _ _) Nothing -- import all
+getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) Nothing -- import all
= (map mkAllIE (eltsFM exps), [], emptyBag)
-getOrigIEs (ParsedIface _ _ _ _ exps _ _ _ _ _ _) (Just (True, ies)) -- import hiding
+getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) (Just (True, ies)) -- import hiding
= (map mkAllIE (eltsFM exps_left), found_ies, errs)
where
(found_ies, errs) = lookupIEs exps ies
exps_left = delListFromFM exps (map (getLocalName.ie_name.fst) found_ies)
-getOrigIEs (ParsedIface _ _ _ _ exps _ _ _ _ _ _) (Just (False, ies)) -- import these
+getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) (Just (False, ies)) -- import these
= (map fst found_ies, found_ies, errs)
where
(found_ies, errs) = lookupIEs exps ies
+------------------------------------------------
+mkAllIE :: (OrigName, ExportFlag) -> IE OrigName
mkAllIE (orig,ExportAbs)
- = ASSERT(isLexCon (getLocalName orig))
+ = --ASSERT(isLexCon (nameOf orig))
+ -- the ASSERT is correct, but it is too easy to
+ -- trigger when writing .hi files by hand (e.g.
+ -- when hackily breaking a module loop)
IEThingAbs orig
mkAllIE (orig, ExportAll)
- | isLexCon (getLocalName orig)
+ | isLexCon name_orig || isLexSpecialSym name_orig
= IEThingAll orig
| otherwise
= IEVar orig
+ where
+ name_orig = nameOf orig
+------------
+lookupIEs :: ExportsMap
+ -> [RdrNameIE]
+ -> ([(IE OrigName, ExportFlag)], -- IEs we found, orig-ified
+ Bag (Module -> SrcLoc -> Error))
-lookupIEs exps []
- = ([], emptyBag)
-lookupIEs exps (ie:ies)
- = case lookupFM exps (unqual_str (ie_name ie)) of
- Nothing ->
- (orig_ies, unknownImpSpecErr ie `consBag` errs)
- Just (orig,flag) ->
- (orig_ie orig flag ie ++ orig_ies,
- adderr_if (seen_ie orig orig_ies) (duplicateImpSpecErr ie) errs)
+lookupIEs exps ies
+ = foldr go ([], emptyBag) ies
where
- (orig_ies, errs) = lookupIEs exps ies
-
- orig_ie orig flag (IEVar n) = [(IEVar orig, flag)]
- orig_ie orig flag (IEThingAbs n) = [(IEThingAbs orig, flag)]
- orig_ie orig flag (IEThingAll n) = [(IEThingAll orig, flag)]
- orig_ie orig flag (IEThingWith n ns) = [(IEThingWith orig ns, flag)]
+ go ie (already, errs)
+ = let
+ str = case (ie_name ie) of
+ Unqual s -> s
+ Qual m s -> s
+ in
+ case (lookupFM exps str) of
+ Nothing ->
+ (already, unknownImpSpecErr ie `consBag` errs)
+ Just (orig, flag) ->
+ ((orig_ie orig ie, flag) : already,
+ adderr_if (seen_ie orig already) (duplicateImpSpecErr ie) errs)
+
+ orig_ie orig (IEVar n) = IEVar orig
+ orig_ie orig (IEThingAbs n) = IEThingAbs orig
+ orig_ie orig (IEThingAll n) = IEThingAll orig
+ orig_ie orig (IEThingWith n ns) = IEThingWith orig (map re_orig ns)
+ where
+ (OrigName mod _) = orig
+ re_orig (Unqual s) = OrigName mod s
seen_ie orig seen_ies = any (\ (ie,_) -> orig == ie_name ie) seen_ies
-
+--------------------------------------------
doOrigIEs iface_cache info mod src_loc us []
= return (emptyBag,emptyBag,emptyBag,emptyBag,emptyBag)
doOrigIEs iface_cache info mod src_loc us (ie:ies)
- = doOrigIE iface_cache info mod src_loc us1 ie
+ = let
+ (us1, us2) = splitUniqSupply us
+ in
+ doOrigIE iface_cache info mod src_loc us1 ie
>>= \ (vals1, tcs1, imps1, errs1, warns1) ->
doOrigIEs iface_cache info mod src_loc us2 ies
>>= \ (vals2, tcs2, imps2, errs2, warns2) ->
imps1 `unionBags` imps2,
errs1 `unionBags` errs2,
warns1 `unionBags` warns2)
- where
- (us1, us2) = splitUniqSupply us
+
+----------------------
+doOrigIE :: IfaceCache
+ -> ImportNameInfo
+ -> Module
+ -> SrcLoc
+ -> UniqSupply
+ -> IE OrigName
+ -> IO (Bag RnName, -- values
+ Bag RnName, -- tycons/classes
+ Bag (RnName,ExportFlag), -- import flags
+ Bag Error,
+ Bag Warning)
doOrigIE iface_cache info mod src_loc us ie
= with_decl iface_cache (ie_name ie)
+ avoided_fn
(\ err -> (emptyBag, emptyBag, emptyBag, unitBag err, emptyBag))
(\ decl -> case initRn True mod emptyRnEnv us
(setExtraRn info $
getIfaceDeclNames ie decl)
of
((vals, tcs, imps), errs, warns) -> (vals, tcs, imps, errs, warns))
+ where
+ avoided_fn Nothing -- the thing should be in the source
+ = (emptyBag, emptyBag, emptyBag, emptyBag, emptyBag)
+ avoided_fn (Just (Left rn@(WiredInId _))) -- a builtin value brought into scope
+ = (unitBag rn, emptyBag, emptyBag, emptyBag, emptyBag)
+ avoided_fn (Just (Right rn@(WiredInTyCon tc)))
+ -- a builtin tc brought into scope; we also must bring its
+ -- data constructors into scope
+ = --pprTrace "avoided:Right:" (ppr PprDebug rn) $
+ (listToBag [WiredInId dc | dc <- tyConDataCons tc], unitBag rn, emptyBag, emptyBag, emptyBag)
+
+-------------------------
+checkOrigIE :: IfaceCache
+ -> (IE OrigName, ExportFlag)
+ -> IO (Bag (Module -> SrcLoc -> Error), Bag (Module -> SrcLoc -> Warning))
checkOrigIE iface_cache (IEThingAll n, ExportAbs)
= with_decl iface_cache n
+ (\ _ -> (emptyBag, emptyBag))
(\ err -> (unitBag (\ mod locn -> err), emptyBag))
(\ decl -> case decl of
TypeSig _ _ _ -> (emptyBag, unitBag (allWhenSynImpSpecWarn n))
checkOrigIE iface_cache (IEThingWith n ns, ExportAll)
= with_decl iface_cache n
+ (\ _ -> (emptyBag, emptyBag))
(\ err -> (unitBag (\ mod locn -> err), emptyBag))
(\ decl -> case decl of
- NewTypeSig _ con _ _ -> (check_with "constructrs" [con] ns, emptyBag)
- DataSig _ cons fields _ _ -> (check_with "constructrs (and fields)" (cons++fields) ns, emptyBag)
+ NewTypeSig _ con _ _ -> (check_with "constructors" [con] ns, emptyBag)
+ DataSig _ cons fields _ _ -> (check_with "constructors (and fields)" (cons++fields) ns, emptyBag)
ClassSig _ ops _ _ -> (check_with "class ops" ops ns, emptyBag))
where
- check_with str has rdrs
- | sortLt (<) (map getLocalName has) == sortLt (<) (map unqual_str rdrs)
+ check_with str has origs
+ | sortLt (<) (map getLocalName has) == sortLt (<) (map nameOf origs)
= emptyBag
| otherwise
- = unitBag (withImpSpecErr str n has rdrs)
+ = unitBag (withImpSpecErr str n has origs)
checkOrigIE iface_cache other
= return (emptyBag, emptyBag)
+-----------------------
+with_decl :: IfaceCache
+ -> OrigName
+ -> (Maybe (Either RnName RnName) -> something) -- if avoided..
+ -> (Error -> something) -- if an error...
+ -> (RdrIfaceDecl -> something) -- if OK...
+ -> IO something
-with_decl iface_cache n do_err do_decl
- = cachedDecl iface_cache (isRdrLexCon n) n >>= \ maybe_decl ->
+with_decl iface_cache n do_avoid do_err do_decl
+ = cachedDecl iface_cache (isLexCon n_name || isLexSpecialSym n_name) n >>= \ maybe_decl ->
case maybe_decl of
- Failed err -> return (do_err err)
- Succeeded decl -> return (do_decl decl)
+ CachingAvoided info -> return (do_avoid info)
+ CachingFail err -> return (do_err err)
+ CachingHit decl -> return (do_decl decl)
+ where
+ n_name = nameOf n
+-------------
+getFixityDecl :: IfaceCache
+ -> RnName
+ -> IO (Maybe RenamedFixityDecl, Bag Error)
getFixityDecl iface_cache rn
= let
- (mod, str) = moduleNamePair rn
+ (OrigName mod str) = origName "getFixityDecl" rn
+
+ succeeded infx i = return (Just (infx rn i), emptyBag)
in
- cachedIface iface_cache mod >>= \ maybe_iface ->
+ cachedIface iface_cache True str mod >>= \ maybe_iface ->
case maybe_iface of
Failed err ->
return (Nothing, unitBag err)
- Succeeded (ParsedIface _ _ _ _ _ _ fixes _ _ _ _) ->
+ Succeeded (ParsedIface _ _ _ _ _ _ _ _ fixes _ _ _ _) ->
case lookupFM fixes str of
Nothing -> return (Nothing, emptyBag)
- Just (InfixL _ i) -> return (Just (InfixL rn i), emptyBag)
- Just (InfixR _ i) -> return (Just (InfixR rn i), emptyBag)
- Just (InfixN _ i) -> return (Just (InfixN rn i), emptyBag)
+ Just (InfixL _ i) -> succeeded InfixL i
+ Just (InfixR _ i) -> succeeded InfixR i
+ Just (InfixN _ i) -> succeeded InfixN i
ie_name (IEVar n) = n
ie_name (IEThingAbs n) = n
ie_name (IEThingAll n) = n
ie_name (IEThingWith n _) = n
-unqual_str (Unqual str) = str
-unqual_str q@(Qual _ _) = panic "unqual_str"
-
-adderr_if True err errs = err `consBag` errs
+adderr_if True err errs = err `consBag` errs
adderr_if False err errs = errs
\end{code}
*********************************************************
\begin{code}
-getIfaceDeclNames :: RdrNameIE -> RdrIfaceDecl
+getIfaceDeclNames :: IE OrigName -> RdrIfaceDecl
-> RnM_IInfo s (Bag RnName, -- values
Bag RnName, -- tycons/classes
Bag (RnName,ExportFlag)) -- import flags
getIfaceDeclNames ie (DataSig tycon cons fields src_loc _)
= newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name ->
- mapRn (newImportedName False src_loc (Just (nameExportFlag tycon_name))
- (Just (nameImportFlag tycon_name)))
- cons `thenRn` \ con_names ->
- mapRn (newImportedName False src_loc (Just (nameExportFlag tycon_name))
- (Just (nameImportFlag tycon_name)))
- fields `thenRn` \ field_names ->
+ let
+ map_me = mapRn (newImportedName False src_loc
+ (Just (nameExportFlag tycon_name))
+ (Just (nameImportFlag tycon_name)))
+ in
+ map_me cons `thenRn` \ con_names ->
+ map_me fields `thenRn` \ field_names ->
let
rn_tycon = RnData tycon_name con_names field_names
rn_constrs = [ RnConstr name tycon_name | name <- con_names ]
-> RnM_IInfo s Name
newImportedName tycon_or_class locn maybe_exp maybe_imp rdr
- = getExtraRn `thenRn` \ ((_,b_keys,exp_fn,occ_fn),done_vals,done_tcs,imp_fn) ->
- case if tycon_or_class
- then lookupFM done_tcs (moduleNamePair rdr)
- else lookupFM done_vals (moduleNamePair rdr)
- of
- Just rn -> returnRn (getName rn)
- Nothing ->
+ = let
+ orig = qualToOrigName rdr
+ in
+ getExtraRn `thenRn` \ ((_,b_keys,rec_exp_fn,rec_occ_fn),done_vals,done_tcs,rec_imp_fn) ->
+ case ((if tycon_or_class
+ then lookupFM done_tcs
+ else lookupFM done_vals) orig) of
+
+ Just rn -> returnRn (getName rn)
+ Nothing ->
rnGetUnique `thenRn` \ u ->
let
- uniq = case rdr of
- Qual m n -> u
- Unqual n -> case lookupFM b_keys n of
- Nothing -> u
- Just (key,_) -> key
+ uniq = case lookupFM b_keys orig of
+ Nothing -> u
+ Just (key,_) -> key
exp = case maybe_exp of
- Just exp -> exp
- Nothing -> exp_fn n
+ Just xx -> xx
+ Nothing -> rec_exp_fn n
imp = case maybe_imp of
- Just imp -> imp
- Nothing -> imp_flag
+ Just xx -> xx
+ Nothing -> imp_flag
- (imp_flag, imp_locs) = imp_fn n
+ (imp_flag, imp_locs) = rec_imp_fn n
- n = mkImportedName uniq rdr imp locn imp_locs exp (occ_fn n)
+ n = mkImportedName uniq orig imp locn imp_locs exp (rec_occ_fn n) -- NB: two "n"s
in
returnRn n
\end{code}
message = ppBesides [ppStr "multiple declarations of `", pprNonSym sty rdr, ppStr "'"]
pp_dup rn = addShortErrLocLine (get_loc rn) (\ sty ->
- ppBesides [pp_descrip rn, pprNonSym sty rn]) sty
+ ppCat [pp_descrip rn, pprNonSym sty rn]) sty
get_loc rn = case getImpLocs rn of
[] -> getSrcLoc rn
locs -> head locs
- pp_descrip (RnName _) = ppStr "a value"
- pp_descrip (RnSyn _) = ppStr "a type synonym"
- pp_descrip (RnData _ _ _) = ppStr "a data type"
- pp_descrip (RnConstr _ _) = ppStr "a data constructor"
- pp_descrip (RnField _ _) = ppStr "a record field"
- pp_descrip (RnClass _ _) = ppStr "a class"
- pp_descrip (RnClassOp _ _) = ppStr "a class method"
+ pp_descrip (RnName _) = ppStr "as a value:"
+ pp_descrip (RnSyn _) = ppStr "as a type synonym:"
+ pp_descrip (RnData _ _ _) = ppStr "as a data type:"
+ pp_descrip (RnConstr _ _) = ppStr "as a data constructor:"
+ pp_descrip (RnField _ _) = ppStr "as a record field:"
+ pp_descrip (RnClass _ _) = ppStr "as a class:"
+ pp_descrip (RnClassOp _ _) = ppStr "as a class method:"
pp_descrip _ = ppNil
dupImportWarn (ImportDecl m1 _ _ _ locn1 : dup_imps) sty
= ppAboves (item1 : map dup_item dup_imps)
where
- item1 = addShortErrLocLine locn1 (\ sty ->
+ item1 = addShortWarnLocLine locn1 (\ sty ->
ppCat [ppStr "multiple imports from module", ppPStr m1]) sty
dup_item (ImportDecl m _ _ _ locn)
- = addShortErrLocLine locn (\ sty ->
+ = addShortWarnLocLine locn (\ sty ->
ppCat [ppStr "here was another import from module", ppPStr m]) sty
qualPreludeImportWarn (ImportDecl m _ _ _ locn)
- = addShortErrLocLine locn (\ sty ->
+ = addShortWarnLocLine locn (\ sty ->
ppCat [ppStr "qualified import of prelude module", ppPStr m])
+dupQualImportErr ((q1,ImportDecl _ _ _ _ locn1):dup_quals) sty
+ = ppAboves (item1 : map dup_item dup_quals)
+ where
+ item1 = addShortErrLocLine locn1 (\ sty ->
+ ppCat [ppStr "multiple imports (from different modules) with same qualified name", ppPStr q1]) sty
+
+ dup_item (q,ImportDecl _ _ _ _ locn)
+ = addShortErrLocLine locn (\ sty ->
+ ppCat [ppStr "here was another import with qualified name", ppPStr q]) sty
+
unknownImpSpecErr ie imp_mod locn
= addShortErrLocLine locn (\ sty ->
ppBesides [ppStr "module ", ppPStr imp_mod, ppStr " does not export `", ppr sty (ie_name ie), ppStr "'"])
ppBesides [ppStr "`", ppr sty (ie_name ie), ppStr "' already seen in import list"])
allWhenSynImpSpecWarn n imp_mod locn
- = addShortErrLocLine locn (\ sty ->
+ = addShortWarnLocLine locn (\ sty ->
ppBesides [ppStr "type synonym `", ppr sty n, ppStr "' should not be imported with (..)"])
allWhenAbsImpSpecErr n imp_mod locn
projects / ghc-hetmet.git / blobdiff