module RnNames (
getGlobalNames,
- GlobalNameInfo(..)
+ SYN_IE(GlobalNameInfo)
) where
-import PreludeGlaST ( MutableVar(..) )
+import PreludeGlaST ( SYN_IE(MutableVar) )
IMP_Ubiq()
import RnHsSyn
import RnMonad
-import RnIfaces ( IfaceCache(..), cachedIface, cachedDecl )
-import RnUtils ( RnEnv(..), emptyRnEnv, extendGlobalRnEnv,
- lubExportFlag, qualNameErr, dupNamesErr
+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, opt_CompilingPrelude )
-import ErrUtils ( Error(..), Warning(..), addErrLoc, addShortErrLocLine, addShortWarnLocLine )
-import FiniteMap ( emptyFM, addToFM, addListToFM, lookupFM, fmToList, eltsFM, delListFromFM, keysFM{-ToDo:rm-} )
+ 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, mkWiredInName, origName,
nameExportFlag, nameImportFlag,
getLocalName, getSrcLoc, getImpLocs,
moduleNamePair, pprNonSym,
- isLexCon, ExportFlag(..), OrigName(..)
+ isLexCon, isLexSpecialSym, ExportFlag(..), OrigName(..)
)
-import PrelInfo ( BuiltinNames(..), BuiltinKeys(..) )
+import PrelInfo ( SYN_IE(BuiltinNames), SYN_IE(BuiltinKeys) )
import PrelMods ( pRELUDE, gHC_BUILTINS, modulesWithBuiltins )
import Pretty
import SrcLoc ( SrcLoc, mkBuiltinSrcLoc )
import UniqFM ( emptyUFM, addListToUFM_C, lookupUFM )
import UniqSupply ( splitUniqSupply )
import Util ( isIn, assoc, cmpPString, sortLt, removeDups,
- equivClasses, panic, assertPanic, pprPanic{-ToDo:rm-}, pprTrace{-ToDo:rm-}
+ equivClasses, panic, assertPanic
)
-import PprStyle --ToDo:rm
+--import PprStyle --ToDo:rm
\end{code}
\begin{code}
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
all_errs = src_errs `unionBags` imp_errs `unionBags` listToBag dup_errs
all_warns = src_warns `unionBags` imp_warns
in
+-- 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
(uniq, is_toplev)
= case (lookupFM b_keys orig) of
Just (key,_) -> (key, True)
- Nothing -> if not opt_CompilingPrelude then (u,True) else -- really here just to save gratuitous lookup
+ 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!-})
n = if is_toplev
then mkTopLevName uniq orig locn exp (rec_occ_fn n) -- NB: two "n"s
- else mkWiredInName uniq orig
+ else mkWiredInName uniq orig exp
in
returnRn n
newGlobalName locn maybe_exp is_val_name rdr@(Qual mod name)
- | opt_CompilingPrelude
+ | opt_CompilingGhcInternals
-- we are actually defining something that compiler knows about (e.g., Bool)
= getExtraRn `thenRn` \ ((b_val_names,b_tc_names),b_keys,rec_exp_fn,rec_occ_fn) ->
= 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 -> (pprPanic "newGlobalName:Qual:uniq:" (ppr PprDebug rdr), True)
+ Nothing -> (panic "newGlobalName:Qual:uniq", True)
Just xx -> (uniqueOf xx, False{-builtin!-})
exp = case maybe_exp of
n = if is_toplev
then mkTopLevName uniq orig locn exp (rec_occ_fn n) -- NB: two "n"s
- else mkWiredInName uniq orig
+ else mkWiredInName uniq orig exp
in
returnRn n
| otherwise
= addErrRn (qualNameErr "name in definition" (rdr, locn)) `thenRn_`
- returnRn (pprPanic "newGlobalName:Qual:" (ppr PprDebug rdr))
+ returnRn (panic "newGlobalName:Qual")
\end{code}
*********************************************************
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)
-- 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 False iface_cache) imp_mods) >>
+ accumulate (map (cachedIface iface_cache False SLIT("doImportDecls")) imp_mods) >>
-- process the imports
doImports iface_cache i_info us all_imps
imp_errs `unionBags` errs,
imp_warns `unionBags` warns)
where
- the_imps = implicit_prel ++ src_imps
- all_imps = implicit_qprel ++ the_imps
+ all_imps = implicit_prel ++ src_imps
+-- all_imps = implicit_qprel ++ the_imps
- implicit_qprel = ImportDecl gHC_BUILTINS True Nothing Nothing prel_loc
- : (if opt_NoImplicitPrelude
- then [{- no "import qualified Prelude" -}]
- else [ImportDecl pRELUDE True Nothing Nothing prel_loc])
+ explicit_prelude_imp
+ = not (null [ () | (ImportDecl mod qual _ _ _) <- src_imps, mod == pRELUDE ])
- explicit_prelude_imp = not (null [ () | (ImportDecl mod qual _ _ _) <- src_imps,
- mod == pRELUDE ])
-
- implicit_prel = ImportDecl gHC_BUILTINS False Nothing Nothing prel_loc
- : (if explicit_prelude_imp || 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,
where
has_same_mod (_,ImportDecl mod2 _ _ _ _) = mod == mod2
- imp_mods = [ mod | ImportDecl mod _ _ _ _ <- uniq_imps, mod /= gHC_BUILTINS ]
+ imp_mods = [ mod | ImportDecl mod _ _ _ _ <- uniq_imps ]
imp_warns = listToBag (map dupImportWarn imp_dups)
`unionBags`
Bag (RnName,(ExportFlag,Bag SrcLoc))) -- import flags and src locs
doImport iface_cache info us (ImportDecl mod qual maybe_as maybe_spec src_loc)
- = let
- (b_vals, b_tcs, maybe_spec') = getBuiltins info mod maybe_spec
- in
- (if mod == gHC_BUILTINS then
- return (Succeeded (panic "doImport:GHC fake import!"),
- \ iface -> ([], [], emptyBag))
- else
- --pprTrace "doImport:" (ppPStr mod) $
- cachedIface False iface_cache mod >>= \ maybe_iface ->
- return (maybe_iface, \ iface -> getOrigIEs iface maybe_spec')
- ) >>= \ (maybe_iface, do_ies) ->
+ = --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 ->
accumulate (map (checkOrigIE iface_cache) chk_ies)
>>= \ chk_errs_warns ->
let
- 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
+ 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
- (if mod == gHC_BUILTINS then
- return [ (Nothing, emptyBag) | _ <- final_vals_list ]
- else
- accumulate (map (getFixityDecl iface_cache . snd) final_vals_list)
- ) >>= \ fix_maybes_errs ->
+ 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
fst_occ :: (FAST_STRING, RnName) -> (RdrName, RnName)
fst_occ (str, rn) = (mk_occ str, rn)
- pair_occ :: RnName -> (RdrName, RnName)
- pair_occ rn = (mk_occ (getLocalName rn), rn)
+ 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])
)
getBuiltins _ modname maybe_spec
- | modname `notElem` modulesWithBuiltins
+-- | modname `notElem` modulesWithBuiltins
= (emptyBag, emptyBag, maybe_spec)
getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) modname maybe_spec
(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]) $
+ Qual m s -> --pprTrace "do_builtin:surprising qual!" (ppCat [ppPStr m, ppPStr s]) $
(s, OrigName modname s)
in
case (lookupFM b_tc_names orig) of -- NB: we favour the tycon/class FM...
_ -> panic "importing builtin names (2)"
where
(vals, tcs, ies_left) = do_builtin ies
+-}
-------------------------
getOrigIEs :: ParsedIface
mkAllIE :: (OrigName, ExportFlag) -> IE OrigName
mkAllIE (orig,ExportAbs)
- = ASSERT(isLexCon (nameOf 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 (nameOf orig)
+ | isLexCon name_orig || isLexSpecialSym name_orig
= IEThingAll orig
| otherwise
= IEVar orig
+ where
+ name_orig = nameOf orig
------------
lookupIEs :: ExportsMap
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
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 "constructors" [con] ns, emptyBag)
-----------------------
with_decl :: IfaceCache
-> OrigName
- -> (Error -> something) -- if an error...
- -> (RdrIfaceDecl -> something) -- if OK...
+ -> (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 (isLexCon (nameOf 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
succeeded infx i = return (Just (infx rn i), emptyBag)
in
- cachedIface True iface_cache mod >>= \ maybe_iface ->
+ cachedIface iface_cache True str mod >>= \ maybe_iface ->
case maybe_iface of
Failed err ->
return (Nothing, unitBag err)
projects / ghc-hetmet.git / blobdiff