module Rename ( renameModule ) where
-import PreludeGlaST ( thenPrimIO, newVar, MutableVar(..) )
+import PreludeGlaST ( thenPrimIO )
-import Ubiq
+IMP_Ubiq()
+IMPORT_1_3(List(partition))
import HsSyn
-import RdrHsSyn ( RdrNameHsModule(..), RdrNameImportDecl(..) )
-import RnHsSyn ( RnName, RenamedHsModule(..), isRnTyConOrClass, isRnWired )
-
---ToDo:rm: all for debugging only
-import Maybes
-import Name
-import Outputable
-import RnIfaces
-import PprStyle
-import Pretty
-import FiniteMap
-import Util (pprPanic, pprTrace)
+import RdrHsSyn ( RdrName, SYN_IE(RdrNameHsModule), SYN_IE(RdrNameImportDecl) )
+import RnHsSyn ( SYN_IE(RenamedHsModule), SYN_IE(RenamedHsDecl), extractHsTyNames )
-import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst(..) )
+import CmdLineOpts ( opt_HiMap )
import RnMonad
-import RnNames ( getGlobalNames, GlobalNameInfo(..) )
-import RnSource ( rnSource )
-import RnIfaces ( findHiFiles, rnIfaces, finalIfaceInfo, VersionInfo(..) )
-import RnUtils ( extendGlobalRnEnv, emptyRnEnv, multipleOccWarn )
-import MainMonad
-
-import Bag ( isEmptyBag, unionBags, unionManyBags, bagToList, listToBag )
-import CmdLineOpts ( opt_HiDirList, opt_SysHiDirList )
-import ErrUtils ( Error(..), Warning(..) )
-import FiniteMap ( emptyFM, eltsFM, fmToList, lookupFM{-ToDo:rm-} )
-import Maybes ( catMaybes )
-import Name ( isLocallyDefined, mkBuiltinName, Name, RdrName(..) )
-import PrelInfo ( BuiltinNames(..), BuiltinKeys(..) )
-import PrelMods ( pRELUDE )
-import UniqFM ( emptyUFM, lookupUFM, addListToUFM_C, eltsUFM )
-import UniqSupply ( splitUniqSupply )
-import Util ( panic, assertPanic )
+import RnNames ( getGlobalNames )
+import RnSource ( rnDecl )
+import RnIfaces ( getImportedInstDecls, getDecl, getImportVersions, getSpecialInstModules,
+ mkSearchPath, getWiredInDecl
+ )
+import RnEnv ( availsToNameSet, addAvailToNameSet, addImplicitOccsRn )
+import Id ( GenId {- instance NamedThing -} )
+import Name ( Name, Provenance, ExportFlag(..), isLocallyDefined,
+ NameSet(..), elemNameSet, mkNameSet, unionNameSets, nameSetToList,
+ isWiredInName, modAndOcc
+ )
+import TysWiredIn ( unitTyCon, intTyCon, doubleTyCon )
+import TyCon ( TyCon )
+import ErrUtils ( SYN_IE(Error), SYN_IE(Warning) )
+import FiniteMap ( emptyFM, eltsFM, fmToList, addToFM, FiniteMap )
+import Pretty
+import PprStyle ( PprStyle(..) )
+import Util ( panic, assertPanic, pprTrace )
\end{code}
-\begin{code}
-renameModule :: BuiltinNames
- -> BuiltinKeys
- -> UniqSupply
- -> RdrNameHsModule
-
- -> IO (RenamedHsModule, -- output, after renaming
- [Module], -- imported modules; for profiling
- VersionInfo, -- version info; for usage
- [Module], -- instance modules; for iface
- Bag Error,
- Bag Warning)
+\begin{code}
+renameModule :: UniqSupply
+ -> RdrNameHsModule
+ -> IO (Maybe -- Nothing <=> everything up to date;
+ -- no ned to recompile any further
+ (RenamedHsModule, -- Output, after renaming
+ InterfaceDetails, -- Interface; for interface file generatino
+ RnNameSupply, -- Final env; for renaming derivings
+ [Module]), -- Imported modules; for profiling
+ Bag Error,
+ Bag Warning
+ )
\end{code}
-ToDo: May want to arrange to return old interface for this module!
-ToDo: Return OrigName RnEnv to rename derivings etc with.
-ToDo: Builtin names which must be read.
-ToDo: Deal with instances (instance version, this module on instance list ???)
\begin{code}
-renameModule b_names b_keys us
- input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _)
-
- = pprTrace "builtins:\n" (case b_names of { (builtin_ids, builtin_tcs) ->
- ppAboves [ ppCat (map ppPStr (keysFM builtin_ids))
- , ppCat (map ppPStr (keysFM builtin_tcs))
- , ppCat (map ppPStr (keysFM b_keys))
- ]}) $
-
- findHiFiles opt_HiDirList opt_SysHiDirList >>= \ hi_files ->
- newVar (emptyFM, hi_files){-init iface cache-} `thenPrimIO` \ iface_cache ->
-
- fixIO ( \ ~(_, _, _, _, rec_occ_fm, rec_export_fn) ->
+renameModule us this_mod@(HsModule mod_name vers exports imports fixities local_decls loc)
+ = -- INITIALISE THE RENAMER MONAD
+ initRn mod_name us (mkSearchPath opt_HiMap) loc $
+
+ -- FIND THE GLOBAL NAME ENVIRONMENT
+ getGlobalNames this_mod `thenRn` \ global_name_info ->
+
+ case global_name_info of {
+ Nothing -> -- Everything is up to date; no need to recompile further
+ returnRn Nothing ;
+
+ -- Otherwise, just carry on
+ Just (export_env, rn_env, local_avails) ->
+
+ -- RENAME THE SOURCE
+ -- We also add occurrences for Int, Double, and (), because they
+ -- are the types to which ambigious type variables may be defaulted by
+ -- the type checker; so they won't every appear explicitly.
+ -- [The () one is a GHC extension for defaulting CCall results.]
+ initRnMS rn_env mod_name SourceMode (mapRn rnDecl local_decls) `thenRn` \ rn_local_decls ->
+ addImplicitOccsRn [getName intTyCon,
+ getName doubleTyCon,
+ getName unitTyCon] `thenRn_`
+
+ -- SLURP IN ALL THE NEEDED DECLARATIONS
+ -- Notice that the rnEnv starts empty
+ closeDecls rn_local_decls (availsToNameSet local_avails) []
+ `thenRn` \ (rn_all_decls, imported_avails) ->
+
+ -- SLURP IN ALL NEEDED INSTANCE DECLARATIONS
+ -- We keep the ones that only mention things (type constructors, classes) that are
+ -- already imported. Ones which don't can't possibly be useful to us.
+ getImportedInstDecls `thenRn` \ imported_insts ->
let
- rec_occ_fn :: Name -> [RdrName]
- rec_occ_fn n = case lookupUFM rec_occ_fm n of
- Nothing -> []
- Just (rn,occs) -> occs
+ all_big_names = mkNameSet [name | Avail name _ <- local_avails] `unionNameSets`
+ mkNameSet [name | Avail name _ <- imported_avails]
- global_name_info = (b_names, b_keys, rec_export_fn, rec_occ_fn)
+ rn_needed_insts = [ initRnMS emptyRnEnv mod_name InterfaceMode (rnDecl (InstD inst_decl))
+ | (inst_names, mod_name, inst_decl) <- imported_insts,
+ all (`elemNameSet` all_big_names) inst_names
+ ]
in
- getGlobalNames iface_cache global_name_info us1 input >>=
- \ (occ_env, imp_mods, unqual_imps, imp_fixes, top_errs, top_warns) ->
+ sequenceRn rn_needed_insts `thenRn` \ inst_decls ->
+ -- Maybe we need to do another close-decls?
- if not (isEmptyBag top_errs) then
- return (rn_panic, rn_panic, top_errs, top_warns, emptyUFM, rn_panic)
- else
- -- No top-level name errors so rename source ...
- case initRn True mod occ_env us2
- (rnSource imp_mods unqual_imps imp_fixes input) of {
- ((rn_module, export_fn, src_occs), src_errs, src_warns) ->
+ -- GENERATE THE VERSION/USAGE INFO
+ getImportVersions imported_avails `thenRn` \ import_versions ->
+ getNameSupplyRn `thenRn` \ name_supply ->
- --pprTrace "renameModule:" (ppCat (map (ppr PprDebug . fst) (bagToList src_occs))) $
+ -- GENERATE THE SPECIAL-INSTANCE MODULE LIST
+ -- The "special instance" modules are those modules that contain instance
+ -- declarations that contain no type constructor or class that was declared
+ -- in that module.
+ getSpecialInstModules `thenRn` \ imported_special_inst_mods ->
let
- occ_fm :: UniqFM (RnName, [RdrName])
-
- occ_list = [ (rn,(rn,[occ])) | (rn,occ) <- bagToList src_occs]
- occ_fm = addListToUFM_C insert_occ emptyUFM occ_list
-
- insert_occ (rn,olds) (rn',[new]) = (rn, insert new olds)
-
- insert new [] = [new]
- insert new xxs@(x:xs) = case cmp new x of LT_ -> new : xxs
- EQ_ -> xxs
- GT__ -> x : insert new xs
-
- occ_warns = map multipleOccWarn (filter multiple_occs (eltsUFM occ_fm))
- multiple_occs (rn, (o1:o2:_)) = True
- multiple_occs _ = False
+ special_inst_decls = [d | InstD d@(InstDecl inst_ty _ _ _ _) <- rn_local_decls,
+ all (not.isLocallyDefined) (nameSetToList (extractHsTyNames inst_ty))
+ ]
+ special_inst_mods | null special_inst_decls = imported_special_inst_mods
+ | otherwise = mod_name : imported_special_inst_mods
in
- return (rn_module, imp_mods,
- top_errs `unionBags` src_errs,
- top_warns `unionBags` src_warns `unionBags` listToBag occ_warns,
- occ_fm, export_fn)
-
- }) >>= \ (rn_module, imp_mods, errs_so_far, warns_so_far, occ_fm, _) ->
-
- if not (isEmptyBag errs_so_far) then
- return (rn_panic, rn_panic, rn_panic, rn_panic, errs_so_far, warns_so_far)
- else
+
+
- -- No errors renaming source so rename the interfaces ...
+ -- RETURN THE RENAMED MODULE
let
- -- split up all names that occurred in the source; between
- -- those that are defined therein and those merely mentioned.
- -- We also divide by tycon/class and value names (as usual).
-
- occ_rns = [ rn | (rn,_) <- eltsUFM occ_fm ]
- -- all occurrence names, from this module and imported
-
- (defined_here, defined_elsewhere)
- = partition isLocallyDefined occ_rns
-
- (_, imports_used) = partition isRnWired defined_elsewhere
-
- (def_tcs, def_vals) = partition isRnTyConOrClass defined_here
- (occ_tcs, occ_vals) = partition isRnTyConOrClass occ_rns
- -- the occ stuff includes *all* occurrences,
- -- including those for which we have definitions
-
- (orig_def_env, orig_def_dups)
- = extendGlobalRnEnv emptyRnEnv (map pair_orig def_vals)
- (map pair_orig def_tcs)
- (orig_occ_env, orig_occ_dups)
- = extendGlobalRnEnv emptyRnEnv (map pair_orig occ_vals)
- (map pair_orig occ_tcs)
-
- pair_orig rn = (origName rn, rn)
-
- must_haves -- everything in the BuiltinKey table; as we *may* need these
- -- later, we'd better bring their definitions in
- = catMaybes [ mk_key_name str name_fn u | (str, (u, name_fn)) <- fmToList b_keys ]
- where
- mk_key_name str name_fn u
- = -- this is emphatically *not* the Right Way to do this... (WDP 96/04)
- if (str == SLIT("main") || str == SLIT("mainPrimIO")) then
- Nothing
- else
- Just (name_fn (mkBuiltinName u pRELUDE str))
- in
- ASSERT (isEmptyBag orig_occ_dups)
- ASSERT (isEmptyBag orig_def_dups)
+ import_mods = [mod | ImportDecl mod _ _ _ _ <- imports]
- rnIfaces iface_cache us3 orig_def_env orig_occ_env rn_module (imports_used ++ must_haves) >>=
- \ (rn_module_with_imports, (implicit_val_fm, implicit_tc_fm), iface_errs, iface_warns) ->
- let
- all_imports_used = bagToList (unionManyBags [listToBag imports_used,
- listToBag (eltsFM implicit_tc_fm),
- listToBag (eltsFM implicit_val_fm)])
+ renamed_module = HsModule mod_name vers
+ trashed_exports trashed_imports trashed_fixities
+ (inst_decls ++ rn_all_decls)
+ loc
in
- finalIfaceInfo iface_cache all_imports_used imp_mods >>=
- \ (version_info, instance_mods) ->
-
- return (rn_module_with_imports, imp_mods, version_info, instance_mods,
- errs_so_far `unionBags` iface_errs, warns_so_far `unionBags` iface_warns)
+ returnRn (Just (renamed_module,
+ (import_versions, export_env, special_inst_mods),
+ name_supply,
+ import_mods))
+ }
where
- rn_panic = panic "renameModule: aborted with errors"
-
- (us1, us') = splitUniqSupply us
- (us2, us3) = splitUniqSupply us'
+ trashed_exports = {-trace "rnSource:trashed_exports"-} Nothing
+ trashed_imports = {-trace "rnSource:trashed_imports"-} []
+ trashed_fixities = []
\end{code}
\begin{code}
-pprPIface (ParsedIface m v mv lcm exm ims lfx ltdm lvdm lids ldp)
- = ppAboves [
- ppCat [ppPStr SLIT("interface"), ppPStr m, ppInt v,
- case mv of { Nothing -> ppNil; Just n -> ppInt n }],
-
- ppPStr SLIT("__versions__"),
- ppAboves [ ppCat[ppPStr n, ppInt v] | (n,v) <- fmToList lcm ],
-
- ppPStr SLIT("__exports__"),
- ppAboves [ ppBesides[ppPStr n, ppSP, ppr PprDebug rn,
- case ex of {ExportAll -> ppStr "(..)"; _ -> ppNil}]
- | (n,(rn,ex)) <- fmToList exm ],
-
- pp_ims (bagToList ims),
- pp_fixities lfx,
- pp_decls ltdm lvdm,
- pp_insts (bagToList lids),
- pp_pragmas ldp
- ]
- where
- pp_ims [] = ppNil
- pp_ims ms = ppAbove (ppPStr SLIT("__instance_modules__"))
- (ppCat (map ppPStr ms))
-
- pp_fixities fx
- | isEmptyFM fx = ppNil
- | otherwise = ppAboves (ppPStr SLIT("__fixities__")
- : [ ppr PprDebug fix | (n, fix) <- fmToList fx])
-
- pp_decls tds vds = ppAboves (ppPStr SLIT("__declarations__")
- : [ pprRdrIfaceDecl d | (n, d) <- fmToList tds ++ fmToList vds])
-
- pp_insts [] = ppNil
- pp_insts is = ppAboves (ppPStr SLIT("__instances__")
- : [ pprRdrInstDecl i | i <- is])
-
- pp_pragmas ps | isEmptyFM ps = ppNil
- | otherwise = panic "Rename.pp_pragmas"
-
-pprRdrIfaceDecl (TypeSig tc _ decl)
- = ppBesides [ppStr "tycon=", ppr PprDebug tc, ppStr "; ", ppr PprDebug decl]
-
-pprRdrIfaceDecl (NewTypeSig tc dc _ decl)
- = ppBesides [ppStr "tycon=", ppr PprDebug tc, ppStr "; datacon=", ppr PprDebug dc, ppStr "; ", ppr PprDebug decl]
-
-pprRdrIfaceDecl (DataSig tc dcs _ decl)
- = ppBesides [ppStr "tycon=", ppr PprDebug tc, ppStr "; datacons=", ppr PprDebug dcs, ppStr "; ", ppr PprDebug decl]
-
-pprRdrIfaceDecl (ClassSig c ops _ decl)
- = ppBesides [ppStr "class=", ppr PprDebug c, ppStr "; ops=", ppr PprDebug ops, ppStr "; ", ppr PprDebug decl]
+closeDecls :: [RenamedHsDecl] -- Declarations got so far
+ -> NameSet -- Names bound by those declarations
+ -> [AvailInfo] -- Available stuff generated by closeDecls so far
+ -> RnMG ([RenamedHsDecl], -- The closed set
+ [AvailInfo]) -- Available stuff generated by closeDecls
+ -- The monad includes a list of possibly-unresolved Names
+ -- This list is empty when closeDecls returns
+
+closeDecls decls decl_names import_avails
+ = popOccurrenceName `thenRn` \ maybe_unresolved ->
+
+ case maybe_unresolved of
+
+ -- No more unresolved names; we're done
+ Nothing -> returnRn (decls, import_avails)
+
+ -- An "unresolved" name that we've already dealt with
+ Just (name,_) | name `elemNameSet` decl_names
+ -> closeDecls decls decl_names import_avails
+
+ -- An unresolved name that's wired in. In this case there's no
+ -- declaration to get, but we still want to record it as now available,
+ -- so that we remember to look for instance declarations involving it.
+ Just (name,_) | isWiredInName name
+ -> getWiredInDecl name `thenRn` \ decl_avail ->
+ closeDecls decls
+ (addAvailToNameSet decl_names decl_avail)
+ (decl_avail : import_avails)
+
+ -- Genuinely unresolved name
+ Just (name,necessity) | otherwise
+ -> getDecl name `thenRn` \ (decl_avail,new_decl) ->
+ case decl_avail of
+
+ -- Can't find the declaration; check that it was optional
+ NotAvailable -> checkRn (case necessity of { Optional -> True; other -> False})
+ (getDeclErr name) `thenRn_`
+ closeDecls decls decl_names import_avails
+
+ -- Found it
+ other -> initRnMS emptyRnEnv mod_name InterfaceMode (
+ rnDecl new_decl
+ ) `thenRn` \ rn_decl ->
+ closeDecls (rn_decl : decls)
+ (addAvailToNameSet decl_names decl_avail)
+ (decl_avail : import_avails)
+ where
+ (mod_name,_) = modAndOcc name
+
+getDeclErr name sty
+ = ppSep [ppStr "Failed to find interface decl for", ppr sty name]
+\end{code}
-pprRdrIfaceDecl (ValSig f _ ty)
- = ppBesides [ppr PprDebug f, ppStr " :: ", ppr PprDebug ty]
-pprRdrInstDecl (InstSig c t _ decl)
- = ppBesides [ppStr "class=", ppr PprDebug c, ppStr " type=", ppr PprDebug t, ppStr "; ",
- ppr PprDebug decl]
-\end{code}