module Rename ( renameModule ) where
-import PreludeGlaST ( thenPrimIO, newVar, MutableVar(..) )
+#if __GLASGOW_HASKELL__ <= 201
+import PreludeGlaST ( thenPrimIO )
+#else
+import GlaExts
+import IO
+#endif
-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(..),
- UsagesMap(..), VersionsMap(..)
- )
+import CmdLineOpts ( opt_HiMap, opt_WarnNameShadowing, opt_D_show_rn_trace,
+ opt_D_dump_rn, opt_D_show_rn_stats,
+ opt_D_show_unused_imports, opt_PprUserLength
+ )
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 UniqFM ( emptyUFM, lookupUFM, addListToUFM_C, eltsUFM )
-import UniqSupply ( splitUniqSupply )
-import Util ( panic, assertPanic )
+import RnNames ( getGlobalNames )
+import RnSource ( rnDecl )
+import RnIfaces ( getImportedInstDecls, importDecl, getImportVersions, getSpecialInstModules,
+ getDeferredDataDecls,
+ mkSearchPath, getSlurpedNames, getRnStats
+ )
+import RnEnv ( availsToNameSet, addAvailToNameSet,
+ addImplicitOccsRn, lookupImplicitOccRn )
+import Id ( GenId {- instance NamedThing -} )
+import Name ( Name, Provenance, ExportFlag(..), isLocallyDefined,
+ NameSet(..), elemNameSet, mkNameSet, unionNameSets,
+ nameSetToList, minusNameSet, NamedThing(..),
+ nameModule, pprModule, pprOccName, nameOccName
+ )
+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), pprBagOfErrors,
+ doIfSet, dumpIfSet, ghcExit
+ )
+import FiniteMap ( emptyFM, eltsFM, fmToList, addToFM, FiniteMap )
+import Pretty
+import Outputable ( Outputable(..), PprStyle(..),
+ pprErrorsStyle, pprDumpStyle, printErrs
+ )
+import Bag ( isEmptyBag )
+import Util ( cmpPString, equivClasses, panic, assertPanic, pprTrace )
+#if __GLASGOW_HASKELL__ >= 202
+import UniqSupply
+#endif
\end{code}
+
+
\begin{code}
renameModule :: UniqSupply
-> RdrNameHsModule
+ -> IO (Maybe (RenamedHsModule, -- Output, after renaming
+ InterfaceDetails, -- Interface; for interface file generatino
+ RnNameSupply, -- Final env; for renaming derivings
+ [Module])) -- Imported modules; for profiling
+
+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
+ (rename this_mod) >>=
+ \ (maybe_rn_stuff, rn_errs_bag, rn_warns_bag) ->
+
+ -- Check for warnings
+ doIfSet (not (isEmptyBag rn_warns_bag))
+ (print_errs rn_warns_bag) >>
+
+ -- Check for errors; exit if so
+ doIfSet (not (isEmptyBag rn_errs_bag))
+ (print_errs rn_errs_bag >>
+ ghcExit 1
+ ) >>
+
+ -- Dump output, if any
+ (case maybe_rn_stuff of
+ Nothing -> return ()
+ Just results@(rn_mod, _, _, _)
+ -> dumpIfSet opt_D_dump_rn "Renamer:"
+ (ppr pprDumpStyle rn_mod)
+ ) >>
+
+ -- Return results
+ return maybe_rn_stuff
+
+
+print_errs errs = printErrs (pprBagOfErrors pprErrorsStyle errs)
+\end{code}
- -> 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)
-\end{code}
-
-ToDo: May want to arrange to return old interface for this module!
-ToDo: Builtin names which must be read.
-ToDo: Deal with instances (instance version, this module on instance list ???)
\begin{code}
-renameModule us input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _)
+rename this_mod@(HsModule mod_name vers exports imports fixities local_decls loc)
+ = -- FIND THE GLOBAL NAME ENVIRONMENT
+ getGlobalNames this_mod `thenRn` \ global_name_info ->
- = 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))
- -- ]}) $
+ case global_name_info of {
+ Nothing -> -- Everything is up to date; no need to recompile further
+ rnStats [] `thenRn_`
+ returnRn Nothing ;
- 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 ->
+ -- Otherwise, just carry on
+ Just (export_env, rn_env, explicit_names) ->
- 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
+ -- RENAME THE SOURCE
+ initRnMS rn_env mod_name SourceMode (
+ addImplicits mod_name `thenRn_`
+ mapRn rnDecl local_decls
+ ) `thenRn` \ rn_local_decls ->
- 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) ->
+ -- SLURP IN ALL THE NEEDED DECLARATIONS
+ slurpDecls rn_local_decls `thenRn` \ rn_all_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 mod_name exports `thenRn` \ import_versions ->
+ getNameSupplyRn `thenRn` \ name_supply ->
- --pprTrace "renameModule:" (ppCat (map (ppr PprDebug . fst) (bagToList src_occs))) $
+ -- REPORT UNUSED NAMES
+ reportUnusedNames explicit_names `thenRn_`
+ -- 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
+ import_mods = [mod | ImportDecl mod _ _ _ _ _ <- imports]
- (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.
-
- must_haves
- = [ name_fn (mkBuiltinName u pRELUDE str)
- | (str, (u, name_fn)) <- fmToList b_keys,
- str `notElem` [ SLIT("main"), SLIT("mainPrimIO")] ]
+ renamed_module = HsModule mod_name vers
+ trashed_exports trashed_imports trashed_fixities
+ rn_all_decls
+ loc
in
- ASSERT (isEmptyBag 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)
+ rnStats rn_all_decls `thenRn_`
+ 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)
-
-makeHiMap Nothing = error "Rename.makeHiMap:no .hi map given by the GHC driver (?)"
-makeHiMap (Just f)
- = readFile f >>= \ cts ->
- return (snag_mod emptyFM cts [])
- 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)
-\end{code}
+@addImplicits@ forces the renamer to slurp in some things which aren't
+mentioned explicitly, but which might be needed by the type checker.
\begin{code}
-{- TESTING:
-pprPIface (ParsedIface m ?? 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
- ]
+addImplicits mod_name
+ = addImplicitOccsRn (implicit_main ++ default_tys)
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])
+ -- 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}
- 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])
+\begin{code}
+slurpDecls decls
+ = -- First of all, get all the compulsory decls
+ slurp_compulsories decls `thenRn` \ decls1 ->
- pp_pragmas ps | isEmptyFM ps = ppNil
- | otherwise = panic "Rename.pp_pragmas"
+ -- Next get the optional ones
+ closeDecls Optional decls1 `thenRn` \ decls2 ->
-pprRdrIfaceDecl (TypeSig tc _ decl)
- = ppBesides [ppStr "tycon=", ppr PprDebug tc, ppStr "; ", ppr PprDebug decl]
+ -- Finally get those deferred data type declarations
+ getDeferredDataDecls `thenRn` \ data_decls ->
+ mapRn rn_data_decl data_decls `thenRn` \ rn_data_decls ->
-pprRdrIfaceDecl (NewTypeSig tc dc _ decl)
- = ppBesides [ppStr "tycon=", ppr PprDebug tc, ppStr "; datacon=", ppr PprDebug dc,
- ppStr "; ", ppr PprDebug decl]
+ -- Done
+ returnRn (rn_data_decls ++ decls2)
-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]
+ where
+ -- The "slurp_compulsories" function is a loop that alternates
+ -- between slurping compulsory decls and slurping the instance
+ -- decls thus made relavant.
+ -- 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. (And its unfolding might mention new
+ -- unresolved names.)
+ -- (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 ...
+ slurp_compulsories decls
+ = closeDecls Compulsory decls `thenRn` \ decls1 ->
+
+ -- Instance decls still pending?
+ getImportedInstDecls `thenRn` \ inst_decls ->
+ if null inst_decls then
+ -- No, none
+ returnRn decls1
+ else
+ -- Yes, there are some, so rename them and loop
+ traceRn (sep [ptext SLIT("Slurped"), int (length inst_decls), ptext SLIT("instance decls")])
+ `thenRn_`
+ mapRn rn_inst_decl inst_decls `thenRn` \ new_inst_decls ->
+ slurp_compulsories (new_inst_decls ++ decls1)
+\end{code}
-pprRdrIfaceDecl (ClassSig c ops _ decl)
- = ppBesides [ppStr "class=", ppr PprDebug c, ppStr "; ops=", ppr PprDebug ops,
- ppStr "; ", ppr PprDebug decl]
+\begin{code}
+closeDecls :: Necessity
+ -> [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 necessity decls
+ = popOccurrenceName necessity `thenRn` \ maybe_unresolved ->
+ case maybe_unresolved of
+
+ -- No more unresolved names
+ Nothing -> returnRn decls
+
+ -- An unresolved name
+ Just name
+ -> -- Slurp its declaration, if any
+-- traceRn (sep [ptext 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 necessity decls
+
+ -- Found a declaration... rename it
+ Just decl -> rn_iface_decl mod_name necessity decl `thenRn` \ new_decl ->
+ closeDecls necessity (new_decl : decls)
+ where
+ mod_name = nameModule name
+
+
+rn_iface_decl mod_name necessity decl -- Notice that the rnEnv starts empty
+ = initRnMS emptyRnEnv mod_name (InterfaceMode necessity) (rnDecl decl)
+
+rn_inst_decl (mod_name,decl) = rn_iface_decl mod_name Compulsory (InstD decl)
+
+rn_data_decl (tycon_name,ty_decl) = rn_iface_decl mod_name Compulsory (TyD ty_decl)
+ where
+ mod_name = nameModule tycon_name
+\end{code}
-pprRdrIfaceDecl (ValSig f _ ty)
- = ppBesides [ppr PprDebug f, ppStr " :: ", ppr PprDebug ty]
+\begin{code}
+reportUnusedNames explicit_avail_names
+ | not opt_D_show_unused_imports
+ = returnRn ()
-pprRdrInstDecl (InstSig c t _ decl)
- = ppBesides [ppStr "class=", ppr PprDebug c, ppStr " type=", ppr PprDebug t, ppStr "; ",
- ppr PprDebug decl]
--}
+ | otherwise
+ = getSlurpedNames `thenRn` \ slurped_names ->
+ let
+ unused = explicit_avail_names `minusNameSet` slurped_names
+ (local_unused, imported_unused) = partition isLocallyDefined (nameSetToList unused)
+ imports_by_module = equivClasses cmp imported_unused
+ name1 `cmp` name2 = nameModule name1 `_CMP_STRING_` nameModule name2
+
+ pp_imp sty = sep [text "For information: the following unqualified imports are unused:",
+ nest 4 (vcat (map (pp_group sty) imports_by_module))]
+ pp_group sty (n:ns) = sep [hcat [text "Module ", pprModule (PprForUser opt_PprUserLength) (nameModule n), char ':'],
+ nest 4 (sep (map (pprOccName sty . nameOccName) (n:ns)))]
+
+ pp_local sty = sep [text "For information: the following local top-level definitions are unused:",
+ nest 4 (sep (map (pprOccName sty . nameOccName) local_unused))]
+ in
+ (if null imported_unused
+ then returnRn ()
+ else addWarnRn pp_imp) `thenRn_`
+
+ (if null local_unused
+ then returnRn ()
+ else addWarnRn pp_local)
+
+rnStats :: [RenamedHsDecl] -> RnMG ()
+rnStats all_decls
+ | opt_D_show_rn_trace ||
+ opt_D_show_rn_stats ||
+ opt_D_dump_rn
+ = getRnStats all_decls `thenRn` \ msg ->
+ ioToRnMG (printErrs msg) `thenRn_`
+ returnRn ()
+
+ | otherwise = returnRn ()
\end{code}
+
projects / ghc-hetmet.git / blobdiff