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(..){-.. is for Ix hack only-}, 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(..),
- UsagesMap(..), VersionsMap(..)
- )
-import RnMonad
-import RnNames ( getGlobalNames, GlobalNameInfo(..) )
-import RnSource ( rnSource )
-import RnIfaces ( rnIfaces )
-import RnUtils ( RnEnv(..), extendGlobalRnEnv, emptyRnEnv, multipleOccWarn )
-
-import Bag ( isEmptyBag, unionBags, unionManyBags, bagToList, listToBag )
import CmdLineOpts ( opt_HiMap )
-import ErrUtils ( Error(..), Warning(..) )
-import FiniteMap ( emptyFM, eltsFM, fmToList, lookupFM{-ToDo:rm-} )
-import Maybes ( catMaybes )
-import Name ( isLocallyDefined, mkBuiltinName, Name, RdrName(..) )
-import PrelInfo ( builtinNameInfo, BuiltinNames(..), BuiltinKeys(..) )
-import PrelMods ( pRELUDE )
-import Unique ( ixClassKey )
-import UniqFM ( emptyUFM, lookupUFM, addListToUFM_C, eltsUFM )
-import UniqSupply ( splitUniqSupply )
-import Util ( panic, assertPanic )
+import RnMonad
+import RnNames ( getGlobalNames )
+import RnSource ( rnDecl )
+import RnIfaces ( getImportedInstDecls, importDecl, getImportVersions, getSpecialInstModules,
+ mkSearchPath
+ )
+import RnEnv ( availsToNameSet, addAvailToNameSet,
+ addImplicitOccsRn, lookupImplicitOccRn )
+import Id ( GenId {- instance NamedThing -} )
+import Name ( Name, Provenance, ExportFlag(..), isLocallyDefined,
+ NameSet(..), elemNameSet, mkNameSet, unionNameSets, nameSetToList,
+ isWiredInName, modAndOcc
+ )
+import TysWiredIn ( unitTyCon, intTyCon, doubleTyCon )
+import PrelInfo ( ioTyCon_NAME, primIoTyCon_NAME )
+import TyCon ( TyCon )
+import PrelMods ( mAIN, gHC_MAIN )
+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 :: UniqSupply
-> RdrNameHsModule
-
- -> IO (RenamedHsModule, -- output, after renaming
- RnEnv, -- final env (for renaming derivings)
- [Module], -- imported modules; for profiling
-
- (UsagesMap,
- VersionsMap, -- version info; for usage
- [Module]), -- instance modules; for iface
-
- Bag Error,
- Bag Warning)
+ -> 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: Deal with instances (instance version, this module on instance list ???)
\begin{code}
-renameModule us input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _)
-
- = let
- (b_names, b_keys, _) = builtinNameInfo
- in
- --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))
- -- ]}) $
+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 $
- makeHiMap opt_HiMap >>= \ hi_files ->
--- pprTrace "HiMap:\n" (ppAboves [ ppCat [ppPStr m, ppStr p] | (m,p) <- fmToList hi_files])
- newVar (emptyFM,emptyFM,hi_files){-init iface cache-} `thenPrimIO` \ iface_cache ->
+ -- FIND THE GLOBAL NAME ENVIRONMENT
+ getGlobalNames this_mod `thenRn` \ global_name_info ->
- fixIO ( \ ~(_, _, _, _, rec_occ_fm, rec_export_fn) ->
- let
- rec_occ_fn :: Name -> [RdrName]
- rec_occ_fn n = case lookupUFM rec_occ_fm n of
- Nothing -> []
- Just (rn,occs) -> occs
-
- global_name_info = (b_names, b_keys, rec_export_fn, rec_occ_fn)
- in
- getGlobalNames iface_cache global_name_info us1 input >>=
- \ (occ_env, imp_mods, unqual_imps, imp_fixes, top_errs, top_warns) ->
+ case global_name_info of {
+ Nothing -> -- Everything is up to date; no need to recompile further
+ returnRn Nothing ;
- if not (isEmptyBag top_errs) then
- return (rn_panic, rn_panic, top_errs, top_warns, emptyUFM, rn_panic)
- else
+ -- Otherwise, just carry on
+ Just (export_env, rn_env, local_avails) ->
- -- 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) ->
+ -- RENAME THE SOURCE
+ initRnMS rn_env mod_name SourceMode (
+ addImplicits mod_name `thenRn_`
+ mapRn rnDecl local_decls
+ ) `thenRn` \ rn_local_decls ->
- --pprTrace "renameModule:" (ppCat (map (ppr PprDebug . fst) (bagToList src_occs))) $
-
- let
- occ_fm :: UniqFM (RnName, [RdrName])
+ -- SLURP IN ALL THE NEEDED DECLARATIONS
+ closeDecls rn_local_decls `thenRn` \ rn_all_decls ->
- 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)
+ -- GENERATE THE VERSION/USAGE INFO
+ getImportVersions mod_name exports `thenRn` \ import_versions ->
+ getNameSupplyRn `thenRn` \ name_supply ->
- 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
+ -- 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
+ 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)
-
- -- we must ensure that the definitions of things in the BuiltinKey
- -- table which may be *required* by the typechecker etc are read.
- -- We *hack* in a requirement for Ix.Ix here
- -- (it's the one thing that doesn't come from Prelude.<blah>)
-
- must_haves
- = (RnImplicitClass (mkBuiltinName ixClassKey SLIT("Ix") SLIT("Ix")))
- : [ name_fn (mkBuiltinName u pRELUDE str)
- | (str, (u, name_fn)) <- fmToList b_keys,
- str `notElem` [ SLIT("main"), SLIT("mainPrimIO")] ]
+ import_mods = [mod | ImportDecl mod _ _ _ _ <- imports]
+
+ renamed_module = HsModule mod_name vers
+ trashed_exports trashed_imports trashed_fixities
+ rn_all_decls
+ loc
in
--- ASSERT (isEmptyBag orig_occ_dups)
- (if (isEmptyBag orig_occ_dups) then \x->x
- else pprTrace "orig_occ_dups:" (ppAboves [ ppCat [ppr PprDebug m, ppr PprDebug n, ppr PprDebug o] | (m,n,o) <- bagToList orig_occ_dups])) $
- ASSERT (isEmptyBag orig_def_dups)
-
- rnIfaces iface_cache imp_mods us3 orig_def_env orig_occ_env
- rn_module (must_haves ++ imports_used) >>=
- \ (rn_module_with_imports, final_env,
- (implicit_val_fm, implicit_tc_fm),
- usage_stuff,
- (iface_errs, iface_warns)) ->
-
- return (rn_module_with_imports,
- final_env,
- imp_mods,
- usage_stuff,
- 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}
-makeHiMap :: Maybe String -> IO (FiniteMap Module FilePath)
+@addImplicits@ forces the renamer to slurp in some things which aren't
+mentioned explicitly, but which might be needed by the type checker.
-makeHiMap Nothing = error "Rename.makeHiMap:no .hi map given by the GHC driver (?)"
-makeHiMap (Just f)
- = readFile f >>= \ cts ->
- return (snag_mod emptyFM cts [])
+\begin{code}
+addImplicits mod_name
+ = addImplicitOccsRn (implicit_main ++ default_tys)
where
- -- we alternate between "snag"ging mod(ule names) and path(names),
- -- accumulating names (reversed) and the final resulting map
- -- as we move along.
-
- snag_mod map [] [] = map
- snag_mod map (' ':cs) rmod = snag_path map (_PK_ (reverse rmod)) cs []
- snag_mod map (c:cs) rmod = snag_mod map cs (c:rmod)
-
- snag_path map mod [] rpath = addToFM map mod (reverse rpath)
- snag_path map mod ('\n':cs) rpath = snag_mod (addToFM map mod (reverse rpath)) cs []
- snag_path map mod (c:cs) rpath = snag_path map mod cs (c:rpath)
+ -- 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.]
+ default_tys = [getName intTyCon, getName doubleTyCon, getName unitTyCon]
+
+ -- Add occurrences for IO or PrimIO
+ implicit_main | mod_name == mAIN = [ioTyCon_NAME]
+ | mod_name == gHC_MAIN = [primIoTyCon_NAME]
+ | otherwise = []
\end{code}
+
\begin{code}
-{- TESTING:
-pprPIface (ParsedIface m ms v mv usgs 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
- ]
+closeDecls :: [RenamedHsDecl] -- Declarations got so far
+ -> RnMG [RenamedHsDecl] -- input + extra decls slurped
+ -- The monad includes a list of possibly-unresolved Names
+ -- This list is empty when closeDecls returns
+
+closeDecls decls
+ = popOccurrenceName `thenRn` \ maybe_unresolved ->
+ case maybe_unresolved of
+
+ -- No more unresolved names
+ Nothing -> -- Slurp instance declarations
+ getImportedInstDecls `thenRn` \ inst_decls ->
+ traceRn (ppSep [ppPStr SLIT("Slurped"), ppInt (length inst_decls), ppPStr SLIT("instance decls")])
+ `thenRn_`
+
+ -- None? then at last we are done
+ if null inst_decls then
+ returnRn decls
+ else
+ mapRn rn_inst_decl inst_decls `thenRn` \ new_inst_decls ->
+
+ -- We *must* loop again here. Why? Two reasons:
+ -- (a) an instance decl will give rise to an unresolved dfun, whose
+ -- decl we must slurp to get its version number; that's the version
+ -- number for the whole instance decl.
+ -- (b) an instance decl might give rise to a new unresolved class,
+ -- whose decl we must slurp, which might let in some new instance decls,
+ -- and so on. Example: instance Foo a => Baz [a] where ...
+
+ closeDecls (new_inst_decls ++ decls)
+
+ -- An unresolved name
+ Just (name,necessity)
+ -> -- Slurp its declaration, if any
+-- traceRn (ppSep [ppPStr SLIT("Considering"), ppr PprDebug name]) `thenRn_`
+ importDecl name necessity `thenRn` \ maybe_decl ->
+ case maybe_decl of
+
+ -- No declaration... (wired in thing or optional)
+ Nothing -> closeDecls decls
+
+ -- Found a declaration... rename it
+ Just decl -> rn_iface_decl mod_name decl `thenRn` \ new_decl ->
+ closeDecls (new_decl : decls)
+ where
+ (mod_name,_) = modAndOcc name
where
- pp_ims [] = ppNil
- pp_ims ms = ppAbove (ppPStr SLIT("__instance_modules__"))
- (ppCat (map ppPStr ms))
+ -- Notice that the rnEnv starts empty
+ rn_iface_decl mod_name decl = initRnMS emptyRnEnv mod_name InterfaceMode (rnDecl decl)
+ rn_inst_decl (mod_name,decl) = rn_iface_decl mod_name (InstD decl)
- 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 dfs _ decl)
- = ppBesides [ppStr "tycon=", ppr PprDebug tc, ppStr "; datacons=", ppr PprDebug dcs,
- ppStr "; fields=", ppr PprDebug dfs, ppStr "; ", ppr PprDebug decl]
-
-pprRdrIfaceDecl (ClassSig c ops _ decl)
- = ppBesides [ppStr "class=", ppr PprDebug c, ppStr "; ops=", ppr PprDebug ops,
- ppStr "; ", ppr PprDebug decl]
+\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}
projects / ghc-hetmet.git / blobdiff