unitAvailEnv, availEnvElts, availNames,
plusAvailEnv, groupAvails, warnUnusedImports,
warnUnusedLocalBinds, warnUnusedModules,
- lookupSrcName, getImplicitStmtFVs,
+ lookupSrcName, getImplicitStmtFVs, mkTopFixityEnv,
getImplicitModuleFVs, newGlobalName, unQualInScope,
ubiquitousNames, lookupOccRn, checkMain,
plusGlobalRdrEnv, mkGlobalRdrEnv
-> Module
-> RdrNameHsModule
-> IO (PersistentCompilerState, PrintUnqualified,
- Maybe (IsExported, ModIface, RnResult))
+ Maybe (IsExported, ModIface, [RenamedHsDecl]))
-- Nothing => some error occurred in the renamer
renameExtCore dflags hit hst pcs this_module
- rdr_module@(HsModule _ _ exports imports local_decls mod_deprec loc)
+ rdr_module@(HsModule _ _ _ _ local_decls _ loc)
-- Rename the (Core) module
= renameSource dflags hit hst pcs this_module $
pushSrcLocRn loc $
- -- RENAME THE SOURCE
- rnSourceDecls emptyRdrEnv emptyAvailEnv
- emptyLocalFixityEnv
- InterfaceMode local_decls `thenRn` \ (rn_local_decls, source_fvs) ->
- let
- tycl_decls = [d | (TyClD d) <- rn_local_decls ]
- local_names = foldl add emptyNameSet tycl_decls
- add names decl = addListToNameSet names (map fst (tyClDeclSysNames decl ++ tyClDeclNames decl))
- in
- recordLocalSlurps local_names `thenRn_`
- closeDecls rn_local_decls source_fvs `thenRn` \ final_decls ->
- -- print everything qualified.
- let print_unqualified = const False in
- -- Bail out if we fail
+ -- Rename the source
+ initIfaceRnMS this_module (rnExtCoreDecls local_decls) `thenRn` \ (rn_local_decls, binders, fvs) ->
+ recordLocalSlurps binders `thenRn_`
+ closeDecls rn_local_decls fvs `thenRn` \ final_decls ->
+
+ -- Bail out if we fail (but dump debug output anyway for debugging)
+ rnDump final_decls `thenRn_`
checkErrsRn `thenRn` \ no_errs_so_far ->
if not no_errs_so_far then
returnRn (print_unqualified, Nothing)
else
- let
+ let
mod_iface = ModIface { mi_module = this_module,
mi_package = opt_InPackage,
mi_version = initialVersionInfo,
mi_usages = [],
mi_boot = False,
mi_orphan = panic "is_orphan",
- mi_exports = [],
+ -- ToDo: export the data types also.
+ mi_exports = [(moduleName this_module,
+ map Avail (nameSetToList binders))],
mi_globals = Nothing,
mi_fixities = mkNameEnv [],
mi_deprecs = NoDeprecs,
mi_decls = panic "mi_decls"
}
- rn_result = RnResult { rr_mod = this_module,
- rr_fixities = mkNameEnv [],
- rr_decls = final_decls,
- rr_main = Nothing }
-
is_exported _ = True
in
- returnRn (print_unqualified, Just (is_exported, mod_iface, rn_result))
+ returnRn (print_unqualified, Just (is_exported, mod_iface, final_decls))
+
+ where
+ print_unqualified = const False -- print everything qualified.
+
+
+rnExtCoreDecls :: [RdrNameHsDecl]
+ -> RnMS ([RenamedHsDecl],
+ NameSet, -- Binders
+ FreeVars) -- Free variables
+
+rnExtCoreDecls decls
+ -- Renaming external-core decls is rather like renaming an interface file
+ -- All the decls are TyClDecls, and all the names are original names
+ = go [] emptyNameSet emptyNameSet decls
+ where
+ go rn_decls bndrs fvs [] = returnRn (rn_decls, bndrs, fvs)
+
+ go rn_decls bndrs fvs (TyClD decl : decls)
+ = rnTyClDecl decl `thenRn` \ rn_decl ->
+ go (TyClD rn_decl : rn_decls)
+ (addListToNameSet bndrs (map fst (tyClDeclSysNames rn_decl ++ tyClDeclNames rn_decl)))
+ (fvs `plusFV` tyClDeclFVs rn_decl)
+ decls
+
+ go rn_decls bndrs fvs (decl : decls)
+ = addErrRn (text "Unexpected decl in ExtCore file" $$ ppr decl) `thenRn_`
+ go rn_decls bndrs fvs decls
\end{code}
checkErrsRn `thenRn` \ no_errs_so_far ->
if not no_errs_so_far then
-- Found errors already, so exit now
- rnDump [] [] `thenRn_`
returnRn (print_unqualified, Nothing)
else
checkErrsRn `thenRn` \ no_errs_so_far ->
if not no_errs_so_far then
-- Found errors already, so exit now
- rnDump [] rn_local_decls `thenRn_`
+ rnDump rn_local_decls `thenRn_`
returnRn (print_unqualified, Nothing)
else
-- SLURP IN ALL THE NEEDED DECLARATIONS
slurpImpDecls needed_fvs `thenRn` \ rn_imp_decls ->
- rnDump rn_imp_decls rn_local_decls `thenRn_`
-- GENERATE THE VERSION/USAGE INFO
mkImportInfo mod_name imports `thenRn` \ my_usages ->
-- introduced by the type checker.
dont_discard :: Name -> Bool
dont_discard | ghci_mode == Interactive = isExternalName
- | otherwise = (`elemNameSet` exported_names)
-
- exported_names = availsToNameSet export_avails
+ | otherwise = (`elemNameSet` export_fvs)
mod_iface = ModIface { mi_module = this_module,
mi_package = opt_InPackage,
rr_main = maybe_main_name }
in
+ rnDump final_decls `thenRn_`
+ rnStats rn_imp_decls `thenRn_`
+
-- REPORT UNUSED NAMES, AND DEBUG DUMP
reportUnusedNames mod_iface print_unqualified
imports full_avail_env gbl_env
\begin{code}
fixitiesFromLocalDecls :: GlobalRdrEnv -> [RdrNameHsDecl] -> RnMG LocalFixityEnv
fixitiesFromLocalDecls gbl_env decls
- = foldlRn getFixities emptyNameEnv decls `thenRn` \ env ->
+ = mkTopFixityEnv gbl_env (foldr get_fix_sigs [] decls) `thenRn` \ env ->
traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts env))) `thenRn_`
returnRn env
where
- getFixities :: LocalFixityEnv -> RdrNameHsDecl -> RnMG LocalFixityEnv
- getFixities acc (FixD fix)
- = fix_decl acc fix
-
- getFixities acc (TyClD (ClassDecl { tcdSigs = sigs}))
- = foldlRn fix_decl acc [sig | FixSig sig <- sigs]
- -- Get fixities from class decl sigs too.
- getFixities acc other_decl
- = returnRn acc
-
- fix_decl acc sig@(FixitySig rdr_name fixity loc)
- = -- Check for fixity decl for something not declared
- pushSrcLocRn loc $
- lookupSrcName gbl_env rdr_name `thenRn` \ name ->
-
- -- Check for duplicate fixity decl
- case lookupNameEnv acc name of
- Just (FixitySig _ _ loc') -> addErrRn (dupFixityDecl rdr_name loc loc') `thenRn_`
- returnRn acc ;
-
- Nothing -> returnRn (extendNameEnv acc name (FixitySig name fixity loc))
+ get_fix_sigs (FixD fix) acc = fix:acc
+ get_fix_sigs (TyClD (ClassDecl { tcdSigs = sigs})) acc
+ = [sig | FixSig sig <- sigs] ++ acc -- Get fixities from class decl sigs too.
+ get_fix_sigs other_decl acc = acc
\end{code}
map TyClD tycl_decls
needed = unionManyNameSets (map ruleDeclFVs rule_decls) `unionNameSets`
unionManyNameSets (map instDeclFVs inst_decls) `unionNameSets`
- unionManyNameSets (map tyClDeclFVs tycl_decls)
+ unionManyNameSets (map tyClDeclFVs tycl_decls) `unionNameSets`
+ ubiquitousNames
+ -- Data type decls with record selectors,
+ -- which may appear in the decls, need unpackCString
+ -- and friends. It's easier to just grab them right now.
+
local_names = foldl add emptyNameSet tycl_decls
add names decl = addListToNameSet names (map fst (tyClDeclSysNames decl ++ tyClDeclNames decl))
in
-
recordLocalSlurps local_names `thenRn_`
-- Do the transitive closure
- closeDecls decls (needed `plusFV` implicit_fvs) `thenRn` \closed_decls ->
- rnDump [] closed_decls `thenRn_`
+ closeDecls decls needed `thenRn` \closed_decls ->
+ rnDump closed_decls `thenRn_`
returnRn closed_decls
- where
- implicit_fvs = ubiquitousNames -- Data type decls with record selectors,
- -- which may appear in the decls, need unpackCString
- -- and friends. It's easier to just grab them right now.
\end{code}
%*********************************************************
where
n_mod = moduleName (nameModule n)
-rnDump :: [RenamedHsDecl] -- Renamed imported decls
- -> [RenamedHsDecl] -- Renamed local decls
+rnDump :: [RenamedHsDecl] -- Renamed decls
-> RnMG ()
-rnDump imp_decls local_decls
+rnDump decls
= doptRn Opt_D_dump_rn_trace `thenRn` \ dump_rn_trace ->
doptRn Opt_D_dump_rn_stats `thenRn` \ dump_rn_stats ->
doptRn Opt_D_dump_rn `thenRn` \ dump_rn ->
getIfacesRn `thenRn` \ ifaces ->
- ioToRnM (do { dumpIfSet (dump_rn_trace || dump_rn_stats || dump_rn)
- "Renamer statistics"
- (getRnStats imp_decls ifaces) ;
+ ioToRnM ( dumpIfSet dump_rn "Renamer:"
+ (vcat (map ppr decls)) )
+ `thenRn_`
- dumpIfSet dump_rn "Renamer:"
- (vcat (map ppr (local_decls ++ imp_decls)))
- }) `thenRn_`
+ returnRn ()
+rnStats :: [RenamedHsDecl] -- Imported decls
+ -> RnMG ()
+rnStats imp_decls
+ = doptRn Opt_D_dump_rn_trace `thenRn` \ dump_rn_trace ->
+ doptRn Opt_D_dump_rn_stats `thenRn` \ dump_rn_stats ->
+ doptRn Opt_D_dump_rn `thenRn` \ dump_rn ->
+ getIfacesRn `thenRn` \ ifaces ->
+
+ ioToRnM (dumpIfSet (dump_rn_trace || dump_rn_stats || dump_rn)
+ "Renamer statistics"
+ (getRnStats imp_decls ifaces)) `thenRn_`
returnRn ()
\end{code}
%************************************************************************
\begin{code}
-dupFixityDecl rdr_name loc1 loc2
- = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
- ptext SLIT("at ") <+> ppr loc1,
- ptext SLIT("and") <+> ppr loc2]
-
badDeprec d
= sep [ptext SLIT("Illegal deprecation when whole module is deprecated"),
nest 4 (ppr d)]
projects / ghc-hetmet.git / blobdiff