import Name ( Name {-instance NamedThing-}, nameOccName,
nameModule, isLocallyDefined,
- isWiredInName, nameUnique, NamedThing(..)
+ isWiredInName, NamedThing(..),
+ elemNameEnv, extendNameEnv
)
-import Module ( Module, moduleString, pprModule,
- mkVanillaModule, pprModuleName,
- moduleUserString, moduleName, isLocalModule,
+import Module ( Module, mkVanillaModule, pprModuleName,
+ moduleName, isLocalModule,
ModuleName, WhereFrom(..),
)
import RdrName ( RdrName, rdrNameOcc )
import NameSet
import SrcLoc ( mkSrcLoc, SrcLoc )
import PrelInfo ( cCallishTyKeys )
-import Maybes ( MaybeErr(..), maybeToBool, orElse )
+import Maybes ( maybeToBool )
import Unique ( Uniquable(..) )
import StringBuffer ( hGetStringBuffer )
import FastString ( mkFastString )
-- If we do loadExport first the wrong info gets into the cache (unless we
-- explicitly tag each export which seems a bit of a bore)
- getModuleRn `thenRn` \ this_mod_nm ->
+ getModuleRn `thenRn` \ this_mod ->
let
- mod = pi_mod iface
+ mod = pi_mod iface
in
-- Sanity check. If we're system-importing a module we know nothing at all
-- about, it should be from a different package to this one
case from of { ImportBySystem -> True; other -> False } &&
isLocalModule mod,
ppr mod )
- foldlRn (loadDecl mod) (iDecls ifaces) (pi_decls iface) `thenRn` \ new_decls ->
- foldlRn (loadInstDecl mod) (iInsts ifaces) (pi_insts iface) `thenRn` \ new_insts ->
- loadRules mod (iRules ifaces) (pi_rules iface) `thenRn` \ new_rules ->
- loadFixDecls mod_name (iFixes ifaces) (pi_fixity iface) `thenRn` \ new_fixities ->
- foldlRn (loadDeprec mod) (iDeprecs ifaces) (pi_deprecs iface) `thenRn` \ new_deprecs ->
- mapRn (loadExport this_mod_nm) (pi_exports iface) `thenRn` \ avails_s ->
+ foldlRn (loadDecl mod) (iDecls ifaces) (pi_decls iface) `thenRn` \ new_decls ->
+ foldlRn (loadInstDecl mod) (iInsts ifaces) (pi_insts iface) `thenRn` \ new_insts ->
+ loadRules mod (iRules ifaces) (pi_rules iface) `thenRn` \ new_rules ->
+ loadFixDecls mod_name (iFixes ifaces) (pi_fixity iface) `thenRn` \ new_fixities ->
+ foldlRn (loadDeprec mod) (iDeprecs ifaces) (pi_deprecs iface) `thenRn` \ new_deprecs ->
+ mapRn (loadExport this_mod) (pi_exports iface) `thenRn` \ avails_s ->
let
-- For an explicit user import, add to mod_map info about
-- the things the imported module depends on, extracted
-- Loading the export list
-----------------------------------------------------
-loadExport :: ModuleName -> ExportItem -> RnM d [AvailInfo]
+loadExport :: Module -> ExportItem -> RnM d [AvailInfo]
loadExport this_mod (mod, entities)
- | mod == this_mod = returnRn []
+ | mod == moduleName this_mod = returnRn []
-- If the module exports anything defined in this module, just ignore it.
-- Reason: otherwise it looks as if there are two local definition sites
-- for the thing, and an error gets reported. Easiest thing is just to
| otherwise
= mapRn (load_entity mod) entities
where
- new_name mod occ = mkImportedGlobalName mod occ
+ new_name mod occ = newGlobalName mod occ
load_entity mod (Avail occ)
= new_name mod occ `thenRn` \ name ->
| name <- availNames full_avail]
add_decl decls_map (name, stuff)
= WARN( name `elemNameEnv` decls_map, ppr name )
- addToNameEnv decls_map name stuff
+ extendNameEnv decls_map name stuff
in
returnRn new_decls_map
}
| otherwise
= mapRn (loadFixDecl mod_name) decls `thenRn` \ to_add ->
- returnRn (addListToNameEnv fixity_env to_add)
+ returnRn (extendNameEnvList fixity_env to_add)
loadFixDecl mod_name sig@(FixitySig rdr_name fixity loc)
- = mkImportedGlobalName mod_name (rdrNameOcc rdr_name) `thenRn` \ name ->
+ = newGlobalName mod_name (rdrNameOcc rdr_name) `thenRn` \ name ->
returnRn (name, FixitySig name fixity loc)
munged_inst_ty = removeContext inst_ty
free_names = extractHsTyRdrNames munged_inst_ty
in
- setModuleRn (moduleName mod) $
- mapRn mkImportedGlobalFromRdrName free_names `thenRn` \ gate_names ->
+ setModuleRn mod $
+ mapRn lookupOrigName free_names `thenRn` \ gate_names ->
returnRn ((mkNameSet gate_names, (mod, InstD decl)) `consBag` insts)
| null rules || opt_IgnoreIfacePragmas
= returnRn rule_bag
| otherwise
- = setModuleRn mod_name $
+ = setModuleRn mod $
mapRn (loadRule mod) rules `thenRn` \ new_rules ->
returnRn (rule_bag `unionBags` listToBag new_rules)
- where
- mod_name = moduleName mod
loadRule :: Module -> RdrNameRuleDecl -> RnM d GatedDecl
-- "Gate" the rule simply by whether the rule variable is
-- needed. We can refine this later.
loadRule mod decl@(IfaceRule _ _ var _ _ src_loc)
- = mkImportedGlobalFromRdrName var `thenRn` \ var_name ->
+ = lookupOrigName var `thenRn` \ var_name ->
returnRn (unitNameSet var_name, (mod, RuleD decl))
loadBuiltinRules :: [(RdrName, CoreRule)] -> RnMG ()
setIfacesRn (ifaces { iRules = iRules ifaces `unionBags` listToBag rule_decls })
loadBuiltinRule (var, rule)
- = mkImportedGlobalFromRdrName var `thenRn` \ var_name ->
+ = lookupOrigName var `thenRn` \ var_name ->
returnRn (unitNameSet var_name, (nameModule var_name, RuleD (IfaceRuleOut var rule)))
returnRn deprec_env
loadDeprec mod deprec_env (Deprecation ie txt _)
- = setModuleRn (moduleName mod) $
- mapRn mkImportedGlobalFromRdrName (ieNames ie) `thenRn` \ names ->
+ = setModuleRn mod $
+ mapRn lookupOrigName (ieNames ie) `thenRn` \ names ->
traceRn (text "loaded deprecation(s) for" <+> hcat (punctuate comma (map ppr names)) <> colon <+> ppr txt) `thenRn_`
- returnRn (extendNameEnv deprec_env (zip names (repeat txt)))
+ returnRn (extendNameEnvList deprec_env (zip names (repeat txt)))
\end{code}
= returnRn upToDate -- Yes! All up to date!
checkEntityUsage mod decls ((occ_name,old_vers) : rest)
- = mkImportedGlobalName mod occ_name `thenRn` \ name ->
+ = newGlobalName mod occ_name `thenRn` \ name ->
case lookupNameEnv decls name of
Nothing -> -- We used it before, but it ain't there now
loadHomeInterface doc_str needed_name `thenRn` \ ifaces ->
case lookupNameEnv (iDecls ifaces) needed_name of
- Just (version, avail, is_tycon_name, decl@(_, TyClD (TyData DataType _ _ _ _ ncons _ _ _)))
+ Just (version, avail, is_tycon_name, decl@(_, TyClD (TyData DataType _ _ _ _ ncons _ _ _ _ _)))
-- This case deals with deferred import of algebraic data types
| not opt_NoPruneTyDecls
export_info = [(m, sortExport as) | (m,as) <- fmToList export_fm]
in
+ traceRn (text "Modules in Ifaces: " <+> fsep (map ppr (keysFM mod_map))) `thenRn_`
returnRn (export_info, import_info)
-> RdrNameHsDecl
-> RnM d (Maybe AvailInfo)
-getDeclBinders new_name (TyClD (TyData _ _ tycon _ condecls _ _ _ src_loc))
+getDeclBinders new_name (TyClD (TyData _ _ tycon _ condecls _ _ _ src_loc _ _))
= new_name tycon src_loc `thenRn` \ tycon_name ->
getConFieldNames new_name condecls `thenRn` \ sub_names ->
returnRn (Just (AvailTC tycon_name (tycon_name : nub sub_names)))
= new_name tycon src_loc `thenRn` \ tycon_name ->
returnRn (Just (AvailTC tycon_name [tycon_name]))
-getDeclBinders new_name (TyClD (ClassDecl _ cname _ _ sigs _ _ _ _ _ _ src_loc))
+getDeclBinders new_name (TyClD (ClassDecl _ cname _ _ sigs _ _ _ src_loc))
= new_name cname src_loc `thenRn` \ class_name ->
-- Record the names for the class ops
= new_name nm loc `thenRn` \ name ->
returnRn (Just (Avail name))
- | otherwise -- a foreign export
- = lookupImplicitOccRn nm `thenRn_`
+ | otherwise -- a foreign export
+ = lookupOrigName nm `thenRn_`
returnRn Nothing
getDeclBinders new_name (DefD _) = returnRn Nothing
getConFieldNames new_name (ConDecl con _ _ _ condecl src_loc : rest)
= new_name con src_loc `thenRn` \ n ->
- (case condecl of
- NewCon _ (Just f) ->
- new_name f src_loc `thenRn` \ new_f ->
- returnRn [n,new_f]
- _ -> returnRn [n]) `thenRn` \ nn ->
getConFieldNames new_name rest `thenRn` \ ns ->
- returnRn (nn ++ ns)
+ returnRn (n : ns)
getConFieldNames new_name [] = returnRn []
-getClassOpNames new_name (ClassOpSig op _ _ _ src_loc) = new_name op src_loc
+getClassOpNames new_name (ClassOpSig op _ _ src_loc) = new_name op src_loc
\end{code}
@getDeclSysBinders@ gets the implicit binders introduced by a decl.
bindings of their own elsewhere.
\begin{code}
-getDeclSysBinders new_name (TyClD (ClassDecl _ cname _ _ sigs _ _ tname dname dwname snames src_loc))
- = sequenceRn [new_name n src_loc | n <- (tname : dname : dwname : snames)]
+getDeclSysBinders new_name (TyClD (ClassDecl _ cname _ _ sigs _ _ names
+ src_loc))
+ = sequenceRn [new_name n src_loc | n <- names]
-getDeclSysBinders new_name (TyClD (TyData _ _ _ _ cons _ _ _ _))
+getDeclSysBinders new_name (TyClD (TyData _ _ _ _ cons _ _ _ _ _ _))
= sequenceRn [new_name wkr_name src_loc | ConDecl _ wkr_name _ _ _ src_loc <- cons]
getDeclSysBinders new_name other_decl
-- one for 'normal' ones, the other for .hi-boot files,
-- hence the need to signal which kind we're interested.
- getHiMaps `thenRn` \ (search_path, hi_map, hiboot_map) ->
+ --getHiMaps `thenRn` \ (search_path, hi_map, hiboot_map) ->
let
- relevant_map | hi_boot_file = hiboot_map
- | otherwise = hi_map
+ bomb = panic "findAndReadInterface: hi_maps: FIXME"
+ search_path = panic "findAndReadInterface: search_path: FIXME"
+ relevant_map | hi_boot_file = bomb --hiboot_map
+ | otherwise = bomb --hi_map
in
case lookupFM relevant_map mod_name of
-- Found the file
ptext SLIT("from module") <+> quotes (ppr (nameModule name))
]
-getDeclWarn name loc
- = sep [ptext SLIT("Failed to find (optional) interface decl for") <+> quotes (ppr name),
- ptext SLIT("desired at") <+> ppr loc]
-
importDeclWarn name
= sep [ptext SLIT(
"Compiler tried to import decl from interface file with same name as module."),
projects / ghc-hetmet.git / blobdiff