diff options
Diffstat (limited to 'ghc/compiler/rename')
| -rw-r--r-- | ghc/compiler/rename/Rename.lhs | 1048 | ||||
| -rw-r--r-- | ghc/compiler/rename/RnBinds.hi-boot | 5 | ||||
| -rw-r--r-- | ghc/compiler/rename/RnBinds.hi-boot-5 | 3 | ||||
| -rw-r--r-- | ghc/compiler/rename/RnBinds.hi-boot-6 | 6 | ||||
| -rw-r--r-- | ghc/compiler/rename/RnBinds.lhs | 197 | ||||
| -rw-r--r-- | ghc/compiler/rename/RnEnv.lhs | 988 | ||||
| -rw-r--r-- | ghc/compiler/rename/RnExpr.lhs | 762 | ||||
| -rw-r--r-- | ghc/compiler/rename/RnHiFiles.hi-boot-5 | 3 | ||||
| -rw-r--r-- | ghc/compiler/rename/RnHiFiles.hi-boot-6 | 4 | ||||
| -rw-r--r-- | ghc/compiler/rename/RnHiFiles.lhs | 667 | ||||
| -rw-r--r-- | ghc/compiler/rename/RnHsSyn.lhs | 51 | ||||
| -rw-r--r-- | ghc/compiler/rename/RnIfaces.lhs | 820 | ||||
| -rw-r--r-- | ghc/compiler/rename/RnMonad.lhs | 760 | ||||
| -rw-r--r-- | ghc/compiler/rename/RnNames.lhs | 684 | ||||
| -rw-r--r-- | ghc/compiler/rename/RnSource.hi-boot-5 | 12 | ||||
| -rw-r--r-- | ghc/compiler/rename/RnSource.hi-boot-6 | 10 | ||||
| -rw-r--r-- | ghc/compiler/rename/RnSource.lhs | 745 | ||||
| -rw-r--r-- | ghc/compiler/rename/RnTypes.lhs | 168 |
18 files changed, 2669 insertions, 4264 deletions
diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs deleted file mode 100644 index 54dadd0c08..0000000000 --- a/ghc/compiler/rename/Rename.lhs +++ /dev/null @@ -1,1048 +0,0 @@ -% -% (c) The GRASP Project, Glasgow University, 1992-1998 -% -\section[Rename]{Renaming and dependency analysis passes} - -\begin{code} -module Rename - ( renameModule - , RnResult(..) - , renameStmt - , renameRdrName - , renameExtCore - , mkGlobalContext - , closeIfaceDecls - , checkOldIface - , slurpIface - ) where - -#include "HsVersions.h" - -import HsSyn -import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameDeprecation, - RdrNameTyClDecl, RdrNameRuleDecl, RdrNameInstDecl, RdrNameImportDecl, - RdrNameStmt - ) -import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl, - RenamedStmt, - instDeclFVs, tyClDeclFVs, ruleDeclFVs - ) - -import CmdLineOpts ( DynFlags, DynFlag(..), opt_InPackage ) -import RnMonad -import RnExpr ( rnStmt ) -import RnNames ( getGlobalNames, exportsFromAvail ) -import RnSource ( rnSourceDecls, rnTyClDecl, rnIfaceRuleDecl, rnInstDecl ) -import RnIfaces ( slurpImpDecls, mkImportInfo, recordLocalSlurps, - closeDecls, - RecompileRequired, outOfDate, recompileRequired - ) -import RnHiFiles ( readIface, loadInterface, - loadExports, loadFixDecls, loadDeprecs, - ) -import RnEnv ( availsToNameSet, - unitAvailEnv, availEnvElts, availNames, - plusAvailEnv, groupAvails, warnUnusedImports, - warnUnusedLocalBinds, warnUnusedModules, - lookupSrcName, getImplicitStmtFVs, mkTopFixityEnv, - getImplicitModuleFVs, newGlobalName, unQualInScope, - ubiquitousNames, lookupOccRn, checkMain, - plusGlobalRdrEnv, mkGlobalRdrEnv - ) -import Module ( Module, ModuleName, WhereFrom(..), - moduleNameUserString, moduleName, - moduleEnvElts - ) -import Name ( Name, nameModule, isExternalName ) -import NameEnv -import NameSet -import RdrName ( foldRdrEnv, isQual, emptyRdrEnv ) -import PrelNames ( iNTERACTIVE, pRELUDE_Name ) -import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass, - printErrorsAndWarnings, errorsFound ) -import Bag ( bagToList ) -import FiniteMap ( FiniteMap, fmToList, emptyFM, lookupFM, - addToFM_C, elemFM, addToFM - ) -import Maybes ( maybeToBool, catMaybes ) -import Outputable -import IO ( openFile, IOMode(..) ) -import HscTypes -- lots of it -import List ( partition, nub ) -\end{code} - - -%********************************************************* -%* * -\subsection{The main wrappers} -%* * -%********************************************************* - -\begin{code} -renameModule :: DynFlags -> GhciMode - -> HomeIfaceTable -> HomeSymbolTable - -> PersistentCompilerState - -> Module -> RdrNameHsModule - -> IO (PersistentCompilerState, PrintUnqualified, - Maybe (IsExported, ModIface, RnResult)) - -- Nothing => some error occurred in the renamer - -renameModule dflags ghci_mode hit hst pcs this_module rdr_module - = renameSource dflags hit hst pcs this_module $ - rename ghci_mode this_module rdr_module -\end{code} - -\begin{code} -renameStmt :: DynFlags - -> HomeIfaceTable -> HomeSymbolTable - -> PersistentCompilerState - -> InteractiveContext - -> RdrNameStmt -- parsed stmt - -> IO ( PersistentCompilerState, - PrintUnqualified, - Maybe ([Name], (RenamedStmt, [RenamedHsDecl])) - ) - -renameStmt dflags hit hst pcs ic stmt - = renameSource dflags hit hst pcs iNTERACTIVE $ - - -- load the context module - let InteractiveContext{ ic_rn_gbl_env = rdr_env, - ic_print_unqual = print_unqual, - ic_rn_local_env = local_rdr_env, - ic_type_env = type_env } = ic - in - - extendTypeEnvRn type_env $ - - -- Rename the stmt - initRnMS rdr_env emptyAvailEnv local_rdr_env emptyLocalFixityEnv CmdLineMode ( - rnStmt stmt $ \ stmt' -> - returnRn (([], stmt'), emptyFVs) - ) `thenRn` \ ((binders, stmt), fvs) -> - - -- Bale out if we fail - checkErrsRn `thenRn` \ no_errs_so_far -> - if not no_errs_so_far then - doDump dflags [] stmt [] `thenRn_` returnRn (print_unqual, Nothing) - else - - -- Add implicit free vars, and close decls - getImplicitStmtFVs `thenRn` \ implicit_fvs -> - slurpImpDecls (fvs `plusFV` implicit_fvs) `thenRn` \ decls -> - -- NB: an earlier version deleted (rdrEnvElts local_env) from - -- the fvs. But (a) that isn't necessary, because previously - -- bound things in the local_env will be in the TypeEnv, and - -- the renamer doesn't re-slurp such things, and - -- (b) it's WRONG to delete them. Consider in GHCi: - -- Mod> let x = e :: T - -- Mod> let y = x + 3 - -- We need to pass 'x' among the fvs to slurpImpDecls, so that - -- the latter can see that T is a gate, and hence import the Num T - -- instance decl. (See the InTypEnv case in RnIfaces.slurpSourceRefs.) - - doDump dflags binders stmt decls `thenRn_` - returnRn (print_unqual, Just (binders, (stmt, decls))) - - where - doDump :: DynFlags -> [Name] -> RenamedStmt -> [RenamedHsDecl] - -> RnMG (Either IOError ()) - doDump dflags bndrs stmt decls - = ioToRnM (dumpIfSet_dyn dflags Opt_D_dump_rn "Renamer:" - (vcat [text "Binders:" <+> ppr bndrs, - ppr stmt, text "", - vcat (map ppr decls)])) - - -renameRdrName - :: DynFlags - -> HomeIfaceTable -> HomeSymbolTable - -> PersistentCompilerState - -> InteractiveContext - -> [RdrName] -- name to rename - -> IO ( PersistentCompilerState, - PrintUnqualified, - Maybe ([Name], [RenamedHsDecl]) - ) - -renameRdrName dflags hit hst pcs ic rdr_names = - renameSource dflags hit hst pcs iNTERACTIVE $ - - -- load the context module - let InteractiveContext{ ic_rn_gbl_env = rdr_env, - ic_print_unqual = print_unqual, - ic_rn_local_env = local_rdr_env, - ic_type_env = type_env } = ic - in - - extendTypeEnvRn type_env $ - - -- rename the rdr_name - initRnMS rdr_env emptyAvailEnv local_rdr_env emptyLocalFixityEnv CmdLineMode - (mapRn (tryRn.lookupOccRn) rdr_names) `thenRn` \ maybe_names -> - let - ok_names = [ a | Right a <- maybe_names ] - in - if null ok_names - then let errs = head [ e | Left e <- maybe_names ] - in setErrsRn errs `thenRn_` - doDump dflags ok_names [] `thenRn_` - returnRn (print_unqual, Nothing) - else - - slurpImpDecls (mkNameSet ok_names) `thenRn` \ decls -> - - doDump dflags ok_names decls `thenRn_` - returnRn (print_unqual, Just (ok_names, decls)) - where - doDump :: DynFlags -> [Name] -> [RenamedHsDecl] -> RnMG (Either IOError ()) - doDump dflags names decls - = ioToRnM (dumpIfSet_dyn dflags Opt_D_dump_rn "Renamer:" - (vcat [ppr names, text "", - vcat (map ppr decls)])) -\end{code} - -\begin{code} -renameExtCore :: DynFlags - -> HomeIfaceTable -> HomeSymbolTable - -> PersistentCompilerState - -> Module - -> RdrNameHsModule - -> IO (PersistentCompilerState, PrintUnqualified, - Maybe (IsExported, ModIface, [RenamedHsDecl])) - - -- Nothing => some error occurred in the renamer -renameExtCore dflags hit hst pcs this_module - rdr_module@(HsModule _ _ _ _ local_decls _ loc) - -- Rename the (Core) module - = renameSource dflags hit hst pcs this_module $ - pushSrcLocRn loc $ - - -- 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 - mod_iface = ModIface { mi_module = this_module, - mi_package = opt_InPackage, - mi_version = initialVersionInfo, - mi_usages = [], - mi_boot = False, - mi_orphan = panic "is_orphan", - -- 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" - } - - is_exported _ = True - in - 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} - - -%********************************************************* -%* * -\subsection{Make up an interactive context} -%* * -%********************************************************* - -\begin{code} -mkGlobalContext - :: DynFlags -> HomeIfaceTable -> HomeSymbolTable - -> PersistentCompilerState - -> [Module] -> [Module] - -> IO (PersistentCompilerState, PrintUnqualified, Maybe GlobalRdrEnv) -mkGlobalContext dflags hit hst pcs toplevs exports - = renameSource dflags hit hst pcs iNTERACTIVE $ - - mapRn getTopLevScope toplevs `thenRn` \ toplev_envs -> - mapRn getModuleExports exports `thenRn` \ export_envs -> - let full_env = foldr plusGlobalRdrEnv emptyRdrEnv - (toplev_envs ++ export_envs) - print_unqual = unQualInScope full_env - in - checkErrsRn `thenRn` \ no_errs_so_far -> - if not no_errs_so_far then - returnRn (print_unqual, Nothing) - else - returnRn (print_unqual, Just full_env) - -contextDoc = text "context for compiling statements" - -getTopLevScope :: Module -> RnM d GlobalRdrEnv -getTopLevScope mod = - loadInterface contextDoc (moduleName mod) ImportByUser `thenRn` \ iface -> - case mi_globals iface of - Nothing -> panic "getTopLevScope" - Just env -> returnRn env - -getModuleExports :: Module -> RnM d GlobalRdrEnv -getModuleExports mod = - loadInterface contextDoc (moduleName mod) ImportByUser `thenRn` \ iface -> - returnRn (foldl add emptyRdrEnv (mi_exports iface)) - where - prov_fn n = NonLocalDef ImplicitImport - add env (mod,avails) = - plusGlobalRdrEnv env (mkGlobalRdrEnv mod True prov_fn avails NoDeprecs) -\end{code} - -%********************************************************* -%* * -\subsection{Slurp in a whole module eagerly} -%* * -%********************************************************* - -\begin{code} -slurpIface - :: DynFlags -> HomeIfaceTable -> HomeSymbolTable - -> PersistentCompilerState -> Module - -> IO (PersistentCompilerState, PrintUnqualified, - Maybe ([Name], [RenamedHsDecl])) -slurpIface dflags hit hst pcs mod = - renameSource dflags hit hst pcs iNTERACTIVE $ - - let mod_name = moduleName mod - in - loadInterface contextDoc mod_name ImportByUser `thenRn` \ iface -> - let fvs = availsToNameSet [ avail | (mn,avails) <- mi_exports iface, - avail <- avails ] - in - slurpImpDecls fvs `thenRn` \ rn_imp_decls -> - returnRn (alwaysQualify, Just (nameSetToList fvs, rn_imp_decls)) -\end{code} - -%********************************************************* -%* * -\subsection{The main function: rename} -%* * -%********************************************************* - -\begin{code} -renameSource :: DynFlags - -> HomeIfaceTable -> HomeSymbolTable - -> PersistentCompilerState - -> Module - -> RnMG (PrintUnqualified, Maybe r) - -> IO (PersistentCompilerState, PrintUnqualified, Maybe r) - -- Nothing => some error occurred in the renamer - -renameSource dflags hit hst old_pcs this_module thing_inside - = do { showPass dflags "Renamer" - - -- Initialise the renamer monad - ; (new_pcs, msgs, (print_unqual, maybe_rn_stuff)) - <- initRn dflags hit hst old_pcs this_module thing_inside - - -- Print errors from renaming - ; printErrorsAndWarnings print_unqual msgs ; - - -- Return results. No harm in updating the PCS - ; if errorsFound msgs then - return (new_pcs, print_unqual, Nothing) - else - return (new_pcs, print_unqual, maybe_rn_stuff) - } -\end{code} - -\begin{code} -data RnResult -- A RenamedModule ia passed from renamer to typechecker - = RnResult { rr_mod :: Module, -- Same as in the ModIface, - rr_fixities :: FixityEnv, -- but convenient to have it here - - rr_main :: Maybe Name, -- Just main, for module Main, - -- Nothing for other modules - - rr_decls :: [RenamedHsDecl] - -- The other declarations of the module - -- Fixity and deprecations have already been slurped out - } -- and are now in the ModIface for the module - -rename :: GhciMode -> Module -> RdrNameHsModule - -> RnMG (PrintUnqualified, Maybe (IsExported, ModIface, RnResult)) -rename ghci_mode this_module - contents@(HsModule _ _ exports imports local_decls mod_deprec loc) - = pushSrcLocRn loc $ - - -- FIND THE GLOBAL NAME ENVIRONMENT - getGlobalNames this_module contents `thenRn` \ (gbl_env, local_gbl_env, - (mod_avail_env, global_avail_env)) -> - let - print_unqualified = unQualInScope gbl_env - - full_avail_env :: NameEnv AvailInfo - -- The domain of global_avail_env is just the 'major' things; - -- variables, type constructors, classes. - -- E.g. Functor |-> Functor( Functor, fmap ) - -- The domain of full_avail_env is everything in scope - -- E.g. Functor |-> Functor( Functor, fmap ) - -- fmap |-> Functor( Functor, fmap ) - -- - -- This filled-out avail_env is needed to generate - -- exports (mkExportAvails), and for generating minimal - -- exports (reportUnusedNames) - full_avail_env = mkNameEnv [ (name,avail) - | avail <- availEnvElts global_avail_env, - name <- availNames avail] - in - -- Exit if we've found any errors - checkErrsRn `thenRn` \ no_errs_so_far -> - if not no_errs_so_far then - -- Found errors already, so exit now - returnRn (print_unqualified, Nothing) - else - - -- PROCESS EXPORT LIST - exportsFromAvail mod_name exports mod_avail_env - full_avail_env gbl_env `thenRn` \ export_avails -> - - traceRn (text "Local top-level environment" $$ - nest 4 (pprGlobalRdrEnv local_gbl_env)) `thenRn_` - - -- DEAL WITH DEPRECATIONS - rnDeprecs local_gbl_env mod_deprec - [d | DeprecD d <- local_decls] `thenRn` \ my_deprecs -> - - -- DEAL WITH LOCAL FIXITIES - fixitiesFromLocalDecls local_gbl_env local_decls `thenRn` \ local_fixity_env -> - - -- RENAME THE SOURCE - rnSourceDecls gbl_env global_avail_env - local_fixity_env SourceMode local_decls `thenRn` \ (rn_local_decls, source_fvs) -> - - -- GET ANY IMPLICIT FREE VARIALBES - getImplicitModuleFVs rn_local_decls `thenRn` \ implicit_fvs -> - checkMain ghci_mode mod_name gbl_env `thenRn` \ (maybe_main_name, main_fvs, implicit_main_fvs) -> - let - export_fvs = availsToNameSet export_avails - used_fvs = source_fvs `plusFV` export_fvs `plusFV` main_fvs - -- The export_fvs make the exported names look just as if they - -- occurred in the source program. For the reasoning, see the - -- comments with RnIfaces.mkImportInfo - -- It also helps reportUnusedNames, which of course must not complain - -- that 'f' isn't mentioned if it is mentioned in the export list - - needed_fvs = implicit_fvs `plusFV` implicit_main_fvs `plusFV` used_fvs - -- It's important to do the "plus" this way round, so that - -- when compiling the prelude, locally-defined (), Bool, etc - -- override the implicit ones. - - in - traceRn (text "Needed FVs:" <+> fsep (map ppr (nameSetToList needed_fvs))) `thenRn_` - - -- EXIT IF ERRORS FOUND - -- We exit here if there are any errors in the source, *before* - -- we attempt to slurp the decls from the interfaces, otherwise - -- the slurped decls may get lost when we return up the stack - -- to hscMain/hscExpr. - checkErrsRn `thenRn` \ no_errs_so_far -> - if not no_errs_so_far then - -- Found errors already, so exit now - rnDump rn_local_decls `thenRn_` - returnRn (print_unqualified, Nothing) - else - - -- SLURP IN ALL THE NEEDED DECLARATIONS - slurpImpDecls needed_fvs `thenRn` \ rn_imp_decls -> - - -- GENERATE THE VERSION/USAGE INFO - mkImportInfo mod_name imports `thenRn` \ my_usages -> - - -- BUILD THE MODULE INTERFACE - let - -- We record fixities even for things that aren't exported, - -- so that we can change into the context of this moodule easily - fixities = mkNameEnv [ (name, fixity) - | FixitySig name fixity loc <- nameEnvElts local_fixity_env - ] - - -- Sort the exports to make them easier to compare for versions - my_exports = groupAvails this_module export_avails - - final_decls = rn_local_decls ++ rn_imp_decls - - -- In interactive mode, we don't want to discard any top-level - -- entities at all (eg. do not inline them away during - -- simplification), and retain them all in the TypeEnv so they are - -- available from the command line. - -- - -- isExternalName separates the user-defined top-level names from those - -- introduced by the type checker. - dont_discard :: Name -> Bool - dont_discard | ghci_mode == Interactive = isExternalName - | otherwise = (`elemNameSet` export_fvs) - - mod_iface = ModIface { mi_module = this_module, - mi_package = opt_InPackage, - mi_version = initialVersionInfo, - mi_usages = my_usages, - mi_boot = False, - mi_orphan = panic "is_orphan", - mi_exports = my_exports, - mi_globals = Just gbl_env, - mi_fixities = fixities, - mi_deprecs = my_deprecs, - mi_decls = panic "mi_decls" - } - - rn_result = RnResult { rr_mod = this_module, - rr_fixities = fixities, - rr_decls = final_decls, - 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 - used_fvs rn_imp_decls `thenRn_` - -- NB: used_fvs: include exports (else we get bogus - -- warnings of unused things) but not implicit FVs. - - returnRn (print_unqualified, Just (dont_discard, mod_iface, rn_result)) - where - mod_name = moduleName this_module -\end{code} - - - -%********************************************************* -%* * -\subsection{Fixities} -%* * -%********************************************************* - -\begin{code} -fixitiesFromLocalDecls :: GlobalRdrEnv -> [RdrNameHsDecl] -> RnMG LocalFixityEnv -fixitiesFromLocalDecls gbl_env decls - = mkTopFixityEnv gbl_env (foldr get_fix_sigs [] decls) `thenRn` \ env -> - traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts env))) `thenRn_` - returnRn env - where - 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} - - -%********************************************************* -%* * -\subsection{Deprecations} -%* * -%********************************************************* - -For deprecations, all we do is check that the names are in scope. -It's only imported deprecations, dealt with in RnIfaces, that we -gather them together. - -\begin{code} -rnDeprecs :: GlobalRdrEnv -> Maybe DeprecTxt - -> [RdrNameDeprecation] -> RnMG Deprecations -rnDeprecs gbl_env Nothing [] - = returnRn NoDeprecs - -rnDeprecs gbl_env (Just txt) decls - = mapRn (addErrRn . badDeprec) decls `thenRn_` - returnRn (DeprecAll txt) - -rnDeprecs gbl_env Nothing decls - = mapRn rn_deprec decls `thenRn` \ pairs -> - returnRn (DeprecSome (mkNameEnv (catMaybes pairs))) - where - rn_deprec (Deprecation rdr_name txt loc) - = pushSrcLocRn loc $ - lookupSrcName gbl_env rdr_name `thenRn` \ name -> - returnRn (Just (name, (name,txt))) -\end{code} - - -%************************************************************************ -%* * -\subsection{Grabbing the old interface file and checking versions} -%* * -%************************************************************************ - -\begin{code} -checkOldIface :: GhciMode - -> DynFlags - -> HomeIfaceTable -> HomeSymbolTable - -> PersistentCompilerState - -> Module - -> FilePath - -> Bool -- Source unchanged - -> Maybe ModIface -- Old interface from compilation manager, if any - -> IO (PersistentCompilerState, Bool, (RecompileRequired, Maybe ModIface)) - -- True <=> errors happened - -checkOldIface ghci_mode dflags hit hst pcs mod iface_path source_unchanged maybe_iface - = runRn dflags hit hst pcs (panic "Bogus module") $ - - -- CHECK WHETHER THE SOURCE HAS CHANGED - ( if not source_unchanged then - traceHiDiffsRn (nest 4 (text "Source file changed or recompilation check turned off")) - else returnRn () ) `thenRn_` - - -- If the source has changed and we're in interactive mode, avoid reading - -- an interface; just return the one we might have been supplied with. - if ghci_mode == Interactive && not source_unchanged then - returnRn (outOfDate, maybe_iface) - else - - setModuleRn mod $ - case maybe_iface of - Just old_iface -> -- Use the one we already have - check_versions old_iface - - Nothing -- try and read it from a file - -> readIface iface_path `thenRn` \ read_result -> - case read_result of - Left err -> -- Old interface file not found, or garbled; give up - traceHiDiffsRn ( - text "Cannot read old interface file:" - $$ nest 4 err) `thenRn_` - returnRn (outOfDate, Nothing) - - Right parsed_iface -> - let read_mod_name = pi_mod parsed_iface - wanted_mod_name = moduleName mod - in - if (wanted_mod_name /= read_mod_name) then - traceHiDiffsRn ( - text "Existing interface file has wrong module name: " - <> quotes (ppr read_mod_name) - ) `thenRn_` - returnRn (outOfDate, Nothing) - else - loadOldIface mod parsed_iface `thenRn` \ m_iface -> - check_versions m_iface - where - check_versions :: ModIface -> RnMG (RecompileRequired, Maybe ModIface) - check_versions iface - | not source_unchanged - = returnRn (outOfDate, Just iface) - | otherwise - = -- Check versions - recompileRequired iface_path iface `thenRn` \ recompile -> - returnRn (recompile, Just iface) -\end{code} - -I think the following function should now have a more representative name, -but what? - -\begin{code} -loadOldIface :: Module -> ParsedIface -> RnMG ModIface - -loadOldIface mod parsed_iface - = let iface = parsed_iface - in - initIfaceRnMS mod ( - loadHomeDecls (pi_decls iface) `thenRn` \ decls -> - loadHomeRules (pi_rules iface) `thenRn` \ rules -> - loadHomeInsts (pi_insts iface) `thenRn` \ insts -> - returnRn (decls, rules, insts) - ) - `thenRn` \ ((decls_vers, new_decls), (rule_vers, new_rules), new_insts) -> - - mapRn loadHomeUsage (pi_usages iface) `thenRn` \ usages -> - loadExports (pi_exports iface) `thenRn` \ (export_vers, avails) -> - loadFixDecls mod (pi_fixity iface) `thenRn` \ fix_env -> - loadDeprecs mod (pi_deprecs iface) `thenRn` \ deprec_env -> - let - version = VersionInfo { vers_module = pi_vers iface, - vers_exports = export_vers, - vers_rules = rule_vers, - vers_decls = decls_vers } - - decls = mkIfaceDecls new_decls new_rules new_insts - - mod_iface = ModIface { mi_module = mod, mi_package = pi_pkg parsed_iface, - mi_version = version, - mi_exports = avails, mi_usages = usages, - mi_boot = False, mi_orphan = pi_orphan iface, - mi_fixities = fix_env, mi_deprecs = deprec_env, - mi_decls = decls, - mi_globals = Nothing - } - in - returnRn mod_iface -\end{code} - -\begin{code} -loadHomeDecls :: [(Version, RdrNameTyClDecl)] - -> RnMS (NameEnv Version, [RenamedTyClDecl]) -loadHomeDecls decls = foldlRn loadHomeDecl (emptyNameEnv, []) decls - -loadHomeDecl :: (NameEnv Version, [RenamedTyClDecl]) - -> (Version, RdrNameTyClDecl) - -> RnMS (NameEnv Version, [RenamedTyClDecl]) -loadHomeDecl (version_map, decls) (version, decl) - = rnTyClDecl decl `thenRn` \ decl' -> - returnRn (extendNameEnv version_map (tyClDeclName decl') version, decl':decls) - ------------------- -loadHomeRules :: (Version, [RdrNameRuleDecl]) - -> RnMS (Version, [RenamedRuleDecl]) -loadHomeRules (version, rules) - = mapRn rnIfaceRuleDecl rules `thenRn` \ rules' -> - returnRn (version, rules') - ------------------- -loadHomeInsts :: [RdrNameInstDecl] - -> RnMS [RenamedInstDecl] -loadHomeInsts insts = mapRn rnInstDecl insts - ------------------- -loadHomeUsage :: ImportVersion OccName - -> RnMG (ImportVersion Name) -loadHomeUsage (mod_name, orphans, is_boot, whats_imported) - = rn_imps whats_imported `thenRn` \ whats_imported' -> - returnRn (mod_name, orphans, is_boot, whats_imported') - where - rn_imps NothingAtAll = returnRn NothingAtAll - rn_imps (Everything v) = returnRn (Everything v) - rn_imps (Specifically mv ev items rv) = mapRn rn_imp items `thenRn` \ items' -> - returnRn (Specifically mv ev items' rv) - rn_imp (occ,vers) = newGlobalName mod_name occ `thenRn` \ name -> - returnRn (name,vers) -\end{code} - - - -%********************************************************* -%* * -\subsection{Closing up the interface decls} -%* * -%********************************************************* - -Suppose we discover we don't need to recompile. Then we start from the -IfaceDecls in the ModIface, and fluff them up by sucking in all the decls they need. - -\begin{code} -closeIfaceDecls :: DynFlags - -> HomeIfaceTable -> HomeSymbolTable - -> PersistentCompilerState - -> ModIface -- Get the decls from here - -> IO (PersistentCompilerState, Bool, [RenamedHsDecl]) - -- True <=> errors happened -closeIfaceDecls dflags hit hst pcs - mod_iface@(ModIface { mi_module = mod, mi_decls = iface_decls }) - = runRn dflags hit hst pcs mod $ - - let - rule_decls = dcl_rules iface_decls - inst_decls = dcl_insts iface_decls - tycl_decls = dcl_tycl iface_decls - decls = map RuleD rule_decls ++ - map InstD inst_decls ++ - map TyClD tycl_decls - needed = unionManyNameSets (map ruleDeclFVs rule_decls) `unionNameSets` - unionManyNameSets (map instDeclFVs inst_decls) `unionNameSets` - 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 `thenRn` \closed_decls -> - rnDump closed_decls `thenRn_` - returnRn closed_decls -\end{code} - -%********************************************************* -%* * -\subsection{Unused names} -%* * -%********************************************************* - -\begin{code} -reportUnusedNames :: ModIface -> PrintUnqualified - -> [RdrNameImportDecl] - -> AvailEnv - -> GlobalRdrEnv - -> NameSet -- Used in this module - -> [RenamedHsDecl] - -> RnMG () -reportUnusedNames my_mod_iface unqual imports avail_env gbl_env - used_names imported_decls - = warnUnusedModules unused_imp_mods `thenRn_` - warnUnusedLocalBinds bad_locals `thenRn_` - warnUnusedImports bad_imp_names `thenRn_` - printMinimalImports this_mod unqual minimal_imports - where - this_mod = mi_module my_mod_iface - - -- Now, a use of C implies a use of T, - -- if C was brought into scope by T(..) or T(C) - really_used_names = used_names `unionNameSets` - mkNameSet [ parent_name - | sub_name <- nameSetToList used_names - - -- Usually, every used name will appear in avail_env, but there - -- is one time when it doesn't: tuples and other built in syntax. When you - -- write (a,b) that gives rise to a *use* of "(,)", so that the - -- instances will get pulled in, but the tycon "(,)" isn't actually - -- in scope. Also, (-x) gives rise to an implicit use of 'negate'; - -- similarly, 3.5 gives rise to an implcit use of :% - -- Hence the silent 'False' in all other cases - - , Just parent_name <- [case lookupNameEnv avail_env sub_name of - Just (AvailTC n _) -> Just n - other -> Nothing] - ] - - -- Collect the defined names from the in-scope environment - -- Look for the qualified ones only, else get duplicates - defined_names :: [GlobalRdrElt] - defined_names = foldRdrEnv add [] gbl_env - add rdr_name ns acc | isQual rdr_name = ns ++ acc - | otherwise = acc - - defined_and_used, defined_but_not_used :: [GlobalRdrElt] - (defined_and_used, defined_but_not_used) = partition used defined_names - used (GRE name _ _) = name `elemNameSet` really_used_names - - -- Filter out the ones only defined implicitly - bad_locals :: [Name] - bad_locals = [n | (GRE n LocalDef _) <- defined_but_not_used] - - bad_imp_names :: [(Name,Provenance)] - bad_imp_names = [(n,p) | GRE n p@(NonLocalDef (UserImport mod _ True)) _ <- defined_but_not_used, - not (module_unused mod)] - - -- inst_mods are directly-imported modules that - -- contain instance decl(s) that the renamer decided to suck in - -- It's not necessarily redundant to import such modules. - -- - -- NOTE: Consider - -- module This - -- import M () - -- - -- The import M() is not *necessarily* redundant, even if - -- we suck in no instance decls from M (e.g. it contains - -- no instance decls, or This contains no code). It may be - -- that we import M solely to ensure that M's orphan instance - -- decls (or those in its imports) are visible to people who - -- import This. Sigh. - -- There's really no good way to detect this, so the error message - -- in RnEnv.warnUnusedModules is weakened instead - inst_mods :: [ModuleName] - inst_mods = [m | InstD (InstDecl _ _ _ (Just dfun) _) <- imported_decls, - let m = moduleName (nameModule dfun), - m `elem` direct_import_mods - ] - - -- To figure out the minimal set of imports, start with the things - -- that are in scope (i.e. in gbl_env). Then just combine them - -- into a bunch of avails, so they are properly grouped - minimal_imports :: FiniteMap ModuleName AvailEnv - minimal_imports0 = emptyFM - minimal_imports1 = foldr add_name minimal_imports0 defined_and_used - minimal_imports = foldr add_inst_mod minimal_imports1 inst_mods - - -- We've carefully preserved the provenance so that we can - -- construct minimal imports that import the name by (one of) - -- the same route(s) as the programmer originally did. - add_name (GRE n (NonLocalDef (UserImport m _ _)) _) acc = addToFM_C plusAvailEnv acc (moduleName m) - (unitAvailEnv (mk_avail n)) - add_name (GRE n other_prov _) acc = acc - - mk_avail n = case lookupNameEnv avail_env n of - Just (AvailTC m _) | n==m -> AvailTC n [n] - | otherwise -> AvailTC m [n,m] - Just avail -> Avail n - Nothing -> pprPanic "mk_avail" (ppr n) - - add_inst_mod m acc - | m `elemFM` acc = acc -- We import something already - | otherwise = addToFM acc m emptyAvailEnv - -- Add an empty collection of imports for a module - -- from which we have sucked only instance decls - - direct_import_mods :: [ModuleName] - direct_import_mods = nub [m | ImportDecl m _ _ _ _ _ <- imports] - - -- unused_imp_mods are the directly-imported modules - -- that are not mentioned in minimal_imports - unused_imp_mods = [m | m <- direct_import_mods, - not (maybeToBool (lookupFM minimal_imports m)), - m /= pRELUDE_Name] - - module_unused :: Module -> Bool - module_unused mod = moduleName mod `elem` unused_imp_mods - - --- ToDo: deal with original imports with 'qualified' and 'as M' clauses -printMinimalImports :: Module -- This module - -> PrintUnqualified - -> FiniteMap ModuleName AvailEnv -- Minimal imports - -> RnMG () -printMinimalImports this_mod unqual imps - = ifOptRn Opt_D_dump_minimal_imports $ - - mapRn to_ies (fmToList imps) `thenRn` \ mod_ies -> - ioToRnM (do { h <- openFile filename WriteMode ; - printForUser h unqual (vcat (map ppr_mod_ie mod_ies)) - }) `thenRn_` - returnRn () - where - filename = moduleNameUserString (moduleName this_mod) ++ ".imports" - ppr_mod_ie (mod_name, ies) - | mod_name == pRELUDE_Name - = empty - | otherwise - = ptext SLIT("import") <+> ppr mod_name <> - parens (fsep (punctuate comma (map ppr ies))) - - to_ies (mod, avail_env) = mapRn to_ie (availEnvElts avail_env) `thenRn` \ ies -> - returnRn (mod, ies) - - to_ie :: AvailInfo -> RnMG (IE Name) - -- The main trick here is that if we're importing all the constructors - -- we want to say "T(..)", but if we're importing only a subset we want - -- to say "T(A,B,C)". So we have to find out what the module exports. - to_ie (Avail n) = returnRn (IEVar n) - to_ie (AvailTC n [m]) = ASSERT( n==m ) - returnRn (IEThingAbs n) - to_ie (AvailTC n ns) - = loadInterface (text "Compute minimal imports from" <+> ppr n_mod) - n_mod ImportBySystem `thenRn` \ iface -> - case [xs | (m,as) <- mi_exports iface, - m == n_mod, - AvailTC x xs <- as, - x == n] of - [xs] | all (`elem` ns) xs -> returnRn (IEThingAll n) - | otherwise -> returnRn (IEThingWith n (filter (/= n) ns)) - other -> pprTrace "to_ie" (ppr n <+> ppr (nameModule n) <+> ppr other) $ - returnRn (IEVar n) - where - n_mod = moduleName (nameModule n) - -rnDump :: [RenamedHsDecl] -- Renamed decls - -> RnMG () -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 ( dumpIfSet dump_rn "Renamer:" - (vcat (map ppr 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} - - -%********************************************************* -%* * -\subsection{Statistics} -%* * -%********************************************************* - -\begin{code} -getRnStats :: [RenamedHsDecl] -> Ifaces -> SDoc -getRnStats imported_decls ifaces - = hcat [text "Renamer stats: ", stats] - where - n_mods = length [() | _ <- moduleEnvElts (iPIT ifaces)] - -- This is really only right for a one-shot compile - - (decls_map, n_decls_slurped) = iDecls ifaces - - n_decls_left = length [decl | (avail, True, (_,decl)) <- nameEnvElts decls_map - -- Data, newtype, and class decls are in the decls_fm - -- under multiple names; the tycon/class, and each - -- constructor/class op too. - -- The 'True' selects just the 'main' decl - ] - - (insts_left, n_insts_slurped) = iInsts ifaces - n_insts_left = length (bagToList insts_left) - - (rules_left, n_rules_slurped) = iRules ifaces - n_rules_left = length (bagToList rules_left) - - stats = vcat - [int n_mods <+> text "interfaces read", - hsep [ int n_decls_slurped, text "type/class/variable imported, out of", - int (n_decls_slurped + n_decls_left), text "read"], - hsep [ int n_insts_slurped, text "instance decls imported, out of", - int (n_insts_slurped + n_insts_left), text "read"], - hsep [ int n_rules_slurped, text "rule decls imported, out of", - int (n_rules_slurped + n_rules_left), text "read"] - ] -\end{code} - - -%************************************************************************ -%* * -\subsection{Errors and warnings} -%* * -%************************************************************************ - -\begin{code} -badDeprec d - = sep [ptext SLIT("Illegal deprecation when whole module is deprecated"), - nest 4 (ppr d)] -\end{code} - - diff --git a/ghc/compiler/rename/RnBinds.hi-boot b/ghc/compiler/rename/RnBinds.hi-boot deleted file mode 100644 index 66637e0467..0000000000 --- a/ghc/compiler/rename/RnBinds.hi-boot +++ /dev/null @@ -1,5 +0,0 @@ -_interface_ RnBinds 1 -_exports_ -RnBinds rnBinds; -_declarations_ -1 rnBinds _:_ _forall_ [b] => RdrHsSyn.RdrNameHsBinds -> (RnHsSyn.RenamedHsBinds -> RnMonad.RnMS (b, NameSet.FreeVars)) -> RnMonad.RnMS (b, NameSet.FreeVars) ;; diff --git a/ghc/compiler/rename/RnBinds.hi-boot-5 b/ghc/compiler/rename/RnBinds.hi-boot-5 deleted file mode 100644 index b2fcc90b11..0000000000 --- a/ghc/compiler/rename/RnBinds.hi-boot-5 +++ /dev/null @@ -1,3 +0,0 @@ -__interface RnBinds 1 0 where -__export RnBinds rnBinds; -1 rnBinds :: __forall [b] => RdrHsSyn.RdrNameHsBinds -> (RnHsSyn.RenamedHsBinds -> RnMonad.RnMS (b, NameSet.FreeVars)) -> RnMonad.RnMS (b, NameSet.FreeVars) ; diff --git a/ghc/compiler/rename/RnBinds.hi-boot-6 b/ghc/compiler/rename/RnBinds.hi-boot-6 deleted file mode 100644 index 6f2f354394..0000000000 --- a/ghc/compiler/rename/RnBinds.hi-boot-6 +++ /dev/null @@ -1,6 +0,0 @@ -module RnBinds where - -rnBinds :: forall b . RdrHsSyn.RdrNameHsBinds - -> (RnHsSyn.RenamedHsBinds - -> RnMonad.RnMS (b, NameSet.FreeVars)) - -> RnMonad.RnMS (b, NameSet.FreeVars) diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index af0f98253a..7a0c19ea45 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -10,10 +10,8 @@ they may be affected by renaming (which isn't fully worked out yet). \begin{code} module RnBinds ( - rnTopBinds, rnTopMonoBinds, - rnMethodBinds, renameSigs, renameSigsFVs, - rnBinds, - unknownSigErr + rnTopMonoBinds, rnMonoBinds, rnMethodBinds, + renameSigs, renameSigsFVs, unknownSigErr ) where #include "HsVersions.h" @@ -23,11 +21,11 @@ import HsSyn import HsBinds ( eqHsSig, sigName, hsSigDoc ) import RdrHsSyn import RnHsSyn -import RnMonad +import TcRnMonad import RnTypes ( rnHsSigType, rnHsType ) import RnExpr ( rnMatch, rnGRHSs, rnPat, checkPrecMatch ) import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupInstDeclBndr, - lookupSigOccRn, bindPatSigTyVars, extendNestedFixityEnv, + lookupSigOccRn, bindPatSigTyVars, bindLocalFixities, warnUnusedLocalBinds, mapFvRn, extendTyVarEnvFVRn, ) import CmdLineOpts ( DynFlag(..) ) @@ -35,7 +33,7 @@ import Digraph ( stronglyConnComp, SCC(..) ) import Name ( Name, nameOccName, nameSrcLoc ) import NameSet import RdrName ( RdrName, rdrNameOcc ) -import BasicTypes ( RecFlag(..) ) +import BasicTypes ( RecFlag(..), FixitySig(..) ) import List ( partition ) import Outputable import PrelNames ( isUnboundName ) @@ -150,35 +148,28 @@ it expects the global environment to contain bindings for the binders %* * %************************************************************************ -@rnTopBinds@ assumes that the environment already +@rnTopMonoBinds@ assumes that the environment already contains bindings for the binders of this particular binding. \begin{code} -rnTopBinds :: RdrNameHsBinds -> RnMS (RenamedHsBinds, FreeVars) - -rnTopBinds EmptyBinds = returnRn (EmptyBinds, emptyFVs) -rnTopBinds (MonoBind bind sigs _) = rnTopMonoBinds bind sigs - -- The parser doesn't produce other forms - - rnTopMonoBinds mbinds sigs - = mapRn lookupBndrRn binder_rdr_names `thenRn` \ binder_names -> + = mappM lookupBndrRn binder_rdr_names `thenM` \ binder_names -> bindPatSigTyVars (collectSigTysFromMonoBinds mbinds) $ let bndr_name_set = mkNameSet binder_names in - renameSigsFVs (okBindSig bndr_name_set) sigs `thenRn` \ (siglist, sig_fvs) -> + renameSigsFVs (okBindSig bndr_name_set) sigs `thenM` \ (siglist, sig_fvs) -> - ifOptRn Opt_WarnMissingSigs ( + ifOptM Opt_WarnMissingSigs ( let type_sig_vars = [n | Sig n _ _ <- siglist] un_sigd_binders = nameSetToList (delListFromNameSet bndr_name_set type_sig_vars) in - mapRn_ missingSigWarn un_sigd_binders - ) `thenRn_` + mappM_ missingSigWarn un_sigd_binders + ) `thenM_` - rn_mono_binds siglist mbinds `thenRn` \ (final_binds, bind_fvs) -> - returnRn (final_binds, bind_fvs `plusFV` sig_fvs) + rn_mono_binds siglist mbinds `thenM` \ (final_binds, bind_fvs) -> + returnM (final_binds, bind_fvs `plusFV` sig_fvs) where binder_rdr_names = collectMonoBinders mbinds \end{code} @@ -200,19 +191,10 @@ rnTopMonoBinds mbinds sigs \end{itemize} % \begin{code} -rnBinds :: RdrNameHsBinds - -> (RenamedHsBinds -> RnMS (result, FreeVars)) - -> RnMS (result, FreeVars) - -rnBinds EmptyBinds thing_inside = thing_inside EmptyBinds -rnBinds (MonoBind bind sigs _) thing_inside = rnMonoBinds bind sigs thing_inside - -- the parser doesn't produce other forms - - rnMonoBinds :: RdrNameMonoBinds -> [RdrNameSig] - -> (RenamedHsBinds -> RnMS (result, FreeVars)) - -> RnMS (result, FreeVars) + -> (RenamedHsBinds -> RnM (result, FreeVars)) + -> RnM (result, FreeVars) rnMonoBinds mbinds sigs thing_inside -- Non-empty monobinds = -- Extract all the binders in this group, @@ -224,27 +206,24 @@ rnMonoBinds mbinds sigs thing_inside -- Non-empty monobinds binder_set = mkNameSet new_mbinders in -- Rename the signatures - renameSigsFVs (okBindSig binder_set) sigs `thenRn` \ (siglist, sig_fvs) -> + renameSigsFVs (okBindSig binder_set) sigs `thenM` \ (siglist, sig_fvs) -> -- Report the fixity declarations in this group that -- don't refer to any of the group's binders. -- Then install the fixity declarations that do apply here -- Notice that they scope over thing_inside too - let - fixity_sigs = [(name,sig) | FixSig sig@(FixitySig name _ _) <- siglist ] - in - extendNestedFixityEnv fixity_sigs $ + bindLocalFixities [sig | FixSig sig <- siglist ] $ - rn_mono_binds siglist mbinds `thenRn` \ (binds, bind_fvs) -> + rn_mono_binds siglist mbinds `thenM` \ (binds, bind_fvs) -> -- Now do the "thing inside", and deal with the free-variable calculations - thing_inside binds `thenRn` \ (result,result_fvs) -> + thing_inside binds `thenM` \ (result,result_fvs) -> let all_fvs = result_fvs `plusFV` bind_fvs `plusFV` sig_fvs unused_binders = nameSetToList (binder_set `minusNameSet` all_fvs) in - warnUnusedLocalBinds unused_binders `thenRn_` - returnRn (result, delListFromNameSet all_fvs new_mbinders) + warnUnusedLocalBinds unused_binders `thenM_` + returnM (result, delListFromNameSet all_fvs new_mbinders) where mbinders_w_srclocs = collectLocatedMonoBinders mbinds doc = text "In the binding group for" <+> pp_bndrs mbinders_w_srclocs @@ -267,7 +246,7 @@ This is done {\em either} by pass 3 (for the top-level bindings), \begin{code} rn_mono_binds :: [RenamedSig] -- Signatures attached to this group -> RdrNameMonoBinds - -> RnMS (RenamedHsBinds, -- Dependency analysed + -> RnM (RenamedHsBinds, -- Dependency analysed FreeVars) -- Free variables rn_mono_binds siglist mbinds @@ -275,7 +254,7 @@ rn_mono_binds siglist mbinds -- Rename the bindings, returning a MonoBindsInfo -- which is a list of indivisible vertices so far as -- the strongly-connected-components (SCC) analysis is concerned - flattenMonoBinds siglist mbinds `thenRn` \ mbinds_info -> + flattenMonoBinds siglist mbinds `thenM` \ mbinds_info -> -- Do the SCC analysis let @@ -286,7 +265,7 @@ rn_mono_binds siglist mbinds -- Deal with bound and free-var calculation rhs_fvs = plusFVs [fvs | (_,fvs,_,_) <- mbinds_info] in - returnRn (final_binds, rhs_fvs) + returnM (final_binds, rhs_fvs) \end{code} @flattenMonoBinds@ is ever-so-slightly magical in that it sticks @@ -298,26 +277,26 @@ in case any of them \fbox{\ ???\ } \begin{code} flattenMonoBinds :: [RenamedSig] -- Signatures -> RdrNameMonoBinds - -> RnMS [FlatMonoBindsInfo] + -> RnM [FlatMonoBindsInfo] -flattenMonoBinds sigs EmptyMonoBinds = returnRn [] +flattenMonoBinds sigs EmptyMonoBinds = returnM [] flattenMonoBinds sigs (AndMonoBinds bs1 bs2) - = flattenMonoBinds sigs bs1 `thenRn` \ flat1 -> - flattenMonoBinds sigs bs2 `thenRn` \ flat2 -> - returnRn (flat1 ++ flat2) + = flattenMonoBinds sigs bs1 `thenM` \ flat1 -> + flattenMonoBinds sigs bs2 `thenM` \ flat2 -> + returnM (flat1 ++ flat2) flattenMonoBinds sigs (PatMonoBind pat grhss locn) - = pushSrcLocRn locn $ - rnPat pat `thenRn` \ (pat', pat_fvs) -> + = addSrcLoc locn $ + rnPat pat `thenM` \ (pat', pat_fvs) -> -- Find which things are bound in this group let names_bound_here = mkNameSet (collectPatBinders pat') in - sigsForMe names_bound_here sigs `thenRn` \ sigs_for_me -> - rnGRHSs grhss `thenRn` \ (grhss', fvs) -> - returnRn + sigsForMe names_bound_here sigs `thenM` \ sigs_for_me -> + rnGRHSs grhss `thenM` \ (grhss', fvs) -> + returnM [(names_bound_here, fvs `plusFV` pat_fvs, PatMonoBind pat' grhss' locn, @@ -325,15 +304,15 @@ flattenMonoBinds sigs (PatMonoBind pat grhss locn) )] flattenMonoBinds sigs (FunMonoBind name inf matches locn) - = pushSrcLocRn locn $ - lookupBndrRn name `thenRn` \ new_name -> + = addSrcLoc locn $ + lookupBndrRn name `thenM` \ new_name -> let names_bound_here = unitNameSet new_name in - sigsForMe names_bound_here sigs `thenRn` \ sigs_for_me -> - mapFvRn (rnMatch (FunRhs name)) matches `thenRn` \ (new_matches, fvs) -> - mapRn_ (checkPrecMatch inf new_name) new_matches `thenRn_` - returnRn + sigsForMe names_bound_here sigs `thenM` \ sigs_for_me -> + mapFvRn (rnMatch (FunRhs name)) matches `thenM` \ (new_matches, fvs) -> + mappM_ (checkPrecMatch inf new_name) new_matches `thenM_` + returnM [(unitNameSet new_name, fvs, FunMonoBind new_name inf new_matches locn, @@ -342,12 +321,12 @@ flattenMonoBinds sigs (FunMonoBind name inf matches locn) sigsForMe names_bound_here sigs - = foldlRn check [] (filter (sigForThisGroup names_bound_here) sigs) + = foldlM check [] (filter (sigForThisGroup names_bound_here) sigs) where check sigs sig = case filter (eqHsSig sig) sigs of - [] -> returnRn (sig:sigs) - other -> dupSigDeclErr sig `thenRn_` - returnRn sigs + [] -> returnM (sig:sigs) + other -> dupSigDeclErr sig `thenM_` + returnM sigs \end{code} @@ -370,28 +349,28 @@ a binder. rnMethodBinds :: Name -- Class name -> [Name] -- Names for generic type variables -> RdrNameMonoBinds - -> RnMS (RenamedMonoBinds, FreeVars) + -> RnM (RenamedMonoBinds, FreeVars) -rnMethodBinds cls gen_tyvars EmptyMonoBinds = returnRn (EmptyMonoBinds, emptyFVs) +rnMethodBinds cls gen_tyvars EmptyMonoBinds = returnM (EmptyMonoBinds, emptyFVs) rnMethodBinds cls gen_tyvars (AndMonoBinds mb1 mb2) - = rnMethodBinds cls gen_tyvars mb1 `thenRn` \ (mb1', fvs1) -> - rnMethodBinds cls gen_tyvars mb2 `thenRn` \ (mb2', fvs2) -> - returnRn (mb1' `AndMonoBinds` mb2', fvs1 `plusFV` fvs2) + = rnMethodBinds cls gen_tyvars mb1 `thenM` \ (mb1', fvs1) -> + rnMethodBinds cls gen_tyvars mb2 `thenM` \ (mb2', fvs2) -> + returnM (mb1' `AndMonoBinds` mb2', fvs1 `plusFV` fvs2) rnMethodBinds cls gen_tyvars (FunMonoBind name inf matches locn) - = pushSrcLocRn locn $ + = addSrcLoc locn $ - lookupInstDeclBndr cls name `thenRn` \ sel_name -> + lookupInstDeclBndr cls name `thenM` \ sel_name -> -- We use the selector name as the binder - mapFvRn rn_match matches `thenRn` \ (new_matches, fvs) -> - mapRn_ (checkPrecMatch inf sel_name) new_matches `thenRn_` - returnRn (FunMonoBind sel_name inf new_matches locn, fvs `addOneFV` sel_name) + mapFvRn rn_match matches `thenM` \ (new_matches, fvs) -> + mappM_ (checkPrecMatch inf sel_name) new_matches `thenM_` + returnM (FunMonoBind sel_name inf new_matches locn, fvs `addOneFV` sel_name) where -- Gruesome; bring into scope the correct members of the generic type variables -- See comments in RnSource.rnSourceDecl(ClassDecl) - rn_match match@(Match (TypePatIn ty : _) _ _) + rn_match match@(Match (TypePat ty : _) _ _) = extendTyVarEnvFVRn gen_tvs (rnMatch (FunRhs name) match) where tvs = map rdrNameOcc (extractHsTyRdrNames ty) @@ -402,8 +381,8 @@ rnMethodBinds cls gen_tyvars (FunMonoBind name inf matches locn) -- Can't handle method pattern-bindings which bind multiple methods. rnMethodBinds cls gen_tyvars mbind@(PatMonoBind other_pat _ locn) - = pushSrcLocRn locn $ - failWithRn (EmptyMonoBinds, emptyFVs) (methodBindErr mbind) + = addSrcLoc locn (addErr (methodBindErr mbind)) `thenM_` + returnM (EmptyMonoBinds, emptyFVs) \end{code} @@ -482,18 +461,18 @@ signatures. We'd only need this if we wanted to report unused tyvars. \begin{code} renameSigsFVs ok_sig sigs - = renameSigs ok_sig sigs `thenRn` \ sigs' -> - returnRn (sigs', hsSigsFVs sigs') + = renameSigs ok_sig sigs `thenM` \ sigs' -> + returnM (sigs', hsSigsFVs sigs') renameSigs :: (RenamedSig -> Bool) -- OK-sig predicate -> [RdrNameSig] - -> RnMS [RenamedSig] + -> RnM [RenamedSig] -renameSigs ok_sig [] = returnRn [] +renameSigs ok_sig [] = returnM [] renameSigs ok_sig sigs = -- Rename the signatures - mapRn renameSig sigs `thenRn` \ sigs' -> + mappM renameSig sigs `thenM` \ sigs' -> -- Check for (a) duplicate signatures -- (b) signatures for things not in this group @@ -504,8 +483,8 @@ renameSigs ok_sig sigs Nothing -> True (goods, bads) = partition ok_sig in_scope in - mapRn_ unknownSigErr bads `thenRn_` - returnRn goods + mappM_ unknownSigErr bads `thenM_` + returnM goods -- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory -- because this won't work for: @@ -516,34 +495,34 @@ renameSigs ok_sig sigs -- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.) -- Doesn't seem worth much trouble to sort this. -renameSig :: Sig RdrName -> RnMS (Sig Name) +renameSig :: Sig RdrName -> RnM (Sig Name) -- ClassOpSig is renamed elsewhere. renameSig (Sig v ty src_loc) - = pushSrcLocRn src_loc $ - lookupSigOccRn v `thenRn` \ new_v -> - rnHsSigType (quotes (ppr v)) ty `thenRn` \ new_ty -> - returnRn (Sig new_v new_ty src_loc) + = addSrcLoc src_loc $ + lookupSigOccRn v `thenM` \ new_v -> + rnHsSigType (quotes (ppr v)) ty `thenM` \ new_ty -> + returnM (Sig new_v new_ty src_loc) renameSig (SpecInstSig ty src_loc) - = pushSrcLocRn src_loc $ - rnHsType (text "A SPECIALISE instance pragma") ty `thenRn` \ new_ty -> - returnRn (SpecInstSig new_ty src_loc) + = addSrcLoc src_loc $ + rnHsType (text "A SPECIALISE instance pragma") ty `thenM` \ new_ty -> + returnM (SpecInstSig new_ty src_loc) renameSig (SpecSig v ty src_loc) - = pushSrcLocRn src_loc $ - lookupSigOccRn v `thenRn` \ new_v -> - rnHsSigType (quotes (ppr v)) ty `thenRn` \ new_ty -> - returnRn (SpecSig new_v new_ty src_loc) + = addSrcLoc src_loc $ + lookupSigOccRn v `thenM` \ new_v -> + rnHsSigType (quotes (ppr v)) ty `thenM` \ new_ty -> + returnM (SpecSig new_v new_ty src_loc) renameSig (FixSig (FixitySig v fix src_loc)) - = pushSrcLocRn src_loc $ - lookupSigOccRn v `thenRn` \ new_v -> - returnRn (FixSig (FixitySig new_v fix src_loc)) + = addSrcLoc src_loc $ + lookupSigOccRn v `thenM` \ new_v -> + returnM (FixSig (FixitySig new_v fix src_loc)) renameSig (InlineSig b v p src_loc) - = pushSrcLocRn src_loc $ - lookupSigOccRn v `thenRn` \ new_v -> - returnRn (InlineSig b new_v p src_loc) + = addSrcLoc src_loc $ + lookupSigOccRn v `thenM` \ new_v -> + returnM (InlineSig b new_v p src_loc) \end{code} @@ -555,22 +534,22 @@ renameSig (InlineSig b v p src_loc) \begin{code} dupSigDeclErr sig - = pushSrcLocRn loc $ - addErrRn (sep [ptext SLIT("Duplicate") <+> what_it_is <> colon, + = addSrcLoc loc $ + addErr (sep [ptext SLIT("Duplicate") <+> what_it_is <> colon, ppr sig]) where (what_it_is, loc) = hsSigDoc sig unknownSigErr sig - = pushSrcLocRn loc $ - addErrRn (sep [ptext SLIT("Misplaced") <+> what_it_is <> colon, + = addSrcLoc loc $ + addErr (sep [ptext SLIT("Misplaced") <+> what_it_is <> colon, ppr sig]) where (what_it_is, loc) = hsSigDoc sig missingSigWarn var - = pushSrcLocRn (nameSrcLoc var) $ - addWarnRn (sep [ptext SLIT("Definition but no type signature for"), quotes (ppr var)]) + = addSrcLoc (nameSrcLoc var) $ + addWarn (sep [ptext SLIT("Definition but no type signature for"), quotes (ppr var)]) methodBindErr mbind = hang (ptext SLIT("Can't handle multiple methods defined by one pattern binding")) diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 3e8dd5ba0e..4c91b1b0e9 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -13,41 +13,35 @@ import {-# SOURCE #-} RnHiFiles( loadInterface ) import FlattenInfo ( namesNeededForFlattening ) import HsSyn import RnHsSyn ( RenamedFixitySig ) -import RdrHsSyn ( RdrNameIE, RdrNameHsType, RdrNameFixitySig, extractHsTyRdrTyVars ) +import RdrHsSyn ( RdrNameHsType, extractHsTyRdrTyVars ) import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig, - mkRdrUnqual, mkRdrQual, setRdrNameOcc, - lookupRdrEnv, foldRdrEnv, rdrEnvToList, elemRdrEnv, - unqualifyRdrName + mkRdrUnqual, mkRdrQual, setRdrNameSpace, rdrNameOcc, + lookupRdrEnv, rdrEnvToList, elemRdrEnv, + extendRdrEnv, addListToRdrEnv, emptyRdrEnv, + isExact_maybe, unqualifyRdrName ) import HsTypes ( hsTyVarName, replaceTyVarName ) import HscTypes ( Provenance(..), pprNameProvenance, hasBetterProv, - ImportReason(..), GlobalRdrEnv, GlobalRdrElt(..), AvailEnv, - AvailInfo, Avails, GenAvailInfo(..), NameSupply(..), - ModIface(..), GhciMode(..), - Deprecations(..), lookupDeprec, - extendLocalRdrEnv, lookupFixity + ImportReason(..), GlobalRdrEnv, GlobalRdrElt(..), + GenAvailInfo(..), AvailInfo, Avails, + ModIface(..), NameCache(..), + Deprecations(..), lookupDeprec, isLocalGRE, + extendLocalRdrEnv, availName, availNames, + lookupFixity ) -import RnMonad -import Name ( Name, - getSrcLoc, nameIsLocalOrFrom, - mkInternalName, mkExternalName, - mkIPName, nameOccName, nameModule_maybe, - setNameModuleAndLoc, nameModule - ) -import NameEnv +import TcRnMonad +import Name ( Name, getName, getSrcLoc, nameIsLocalOrFrom, isWiredInName, + mkInternalName, mkExternalName, mkIPName, + nameOccName, setNameModuleAndLoc, nameModule ) import NameSet -import OccName ( OccName, occNameUserString, occNameFlavour, - isDataSymOcc, setOccNameSpace, tcName ) -import Module ( ModuleName, moduleName, mkVanillaModule, - mkSysModuleNameFS, moduleNameFS, WhereFrom(..) ) -import PrelNames ( mkUnboundName, - derivingOccurrences, - mAIN_Name, main_RDR_Unqual, - runIOName, intTyConName, +import OccName ( OccName, tcName, isDataOcc, occNameUserString, occNameFlavour ) +import Module ( Module, ModuleName, moduleName, mkVanillaModule ) +import PrelNames ( mkUnboundName, intTyConName, qTyConName, boolTyConName, funTyConName, unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name, eqStringName, printName, - bindIOName, returnIOName, failIOName, thenIOName + bindIOName, returnIOName, failIOName, thenIOName, + templateHaskellNames ) import TysWiredIn ( unitTyCon ) -- A little odd import FiniteMap @@ -55,12 +49,8 @@ import UniqSupply import SrcLoc ( SrcLoc, noSrcLoc ) import Outputable import ListSetOps ( removeDups, equivClasses ) -import Util ( sortLt ) -import BasicTypes ( mapIPName, defaultFixity ) +import BasicTypes ( mapIPName, FixitySig(..) ) import List ( nub ) -import UniqFM ( lookupWithDefaultUFM ) -import Maybe ( mapMaybe ) -import Maybes ( orElse, catMaybes ) import CmdLineOpts import FastString ( FastString ) \end{code} @@ -72,7 +62,7 @@ import FastString ( FastString ) %********************************************************* \begin{code} -newTopBinder :: Module -> RdrName -> SrcLoc -> RnM d Name +newTopBinder :: Module -> RdrName -> SrcLoc -> TcRn m Name -- newTopBinder puts into the cache the binder with the -- module information set correctly. When the decl is later renamed, -- the binding site will thereby get the correct module. @@ -81,17 +71,12 @@ newTopBinder :: Module -> RdrName -> SrcLoc -> RnM d Name -- the occurrences, so that doesn't matter newTopBinder mod rdr_name loc - = -- First check the cache + | Just name <- isExact_maybe rdr_name + = returnM name - -- There should never be a qualified name in a binding position (except in instance decls) - -- The parser doesn't check this because the same parser parses instance decls - (if isQual rdr_name then - qualNameErr (text "In its declaration") (rdr_name,loc) - else - returnRn () - ) `thenRn_` - - getNameSupplyRn `thenRn` \ name_supply -> + | otherwise + = -- First check the cache + getNameCache `thenM` \ name_supply -> let occ = rdrNameOcc rdr_name key = (moduleName mod, occ) @@ -106,30 +91,25 @@ newTopBinder mod rdr_name loc -- b) its defining SrcLoc -- So we update this info - Just name -> let - new_name = setNameModuleAndLoc name mod loc - new_cache = addToFM cache key new_name - in - setNameSupplyRn (name_supply {nsNames = new_cache}) `thenRn_` --- traceRn (text "newTopBinder: overwrite" <+> ppr new_name) `thenRn_` - returnRn new_name + Just name + | isWiredInName name -> returnM name + -- Don't mess with wired-in names. Apart from anything + -- else, their wired-in-ness is in the SrcLoca + | otherwise + -> let + new_name = setNameModuleAndLoc name mod loc + new_cache = addToFM cache key new_name + in + setNameCache (name_supply {nsNames = new_cache}) `thenM_` + returnM new_name -- Miss in the cache! -- Build a completely new Name, and put it in the cache -- Even for locally-defined names we use implicitImportProvenance; -- updateProvenances will set it to rights - Nothing -> let - (us', us1) = splitUniqSupply (nsUniqs name_supply) - uniq = uniqFromSupply us1 - new_name = mkExternalName uniq mod occ loc - new_cache = addToFM cache key new_name - in - setNameSupplyRn (name_supply {nsUniqs = us', nsNames = new_cache}) `thenRn_` --- traceRn (text "newTopBinder: new" <+> ppr new_name) `thenRn_` - returnRn new_name - - -newGlobalName :: ModuleName -> OccName -> RnM d Name + Nothing -> addNewName name_supply key mod occ loc + +newGlobalName :: ModuleName -> OccName -> TcRn m Name -- Used for *occurrences*. We make a place-holder Name, really just -- to agree on its unique, which gets overwritten when we read in -- the binding occurence later (newTopBinder) @@ -148,34 +128,46 @@ newGlobalName :: ModuleName -> OccName -> RnM d Name -- (but since it affects DLL-ery it does matter that we get it right -- in the end). newGlobalName mod_name occ - = getNameSupplyRn `thenRn` \ name_supply -> + = getNameCache `thenM` \ name_supply -> let key = (mod_name, occ) cache = nsNames name_supply in case lookupFM cache key of - Just name -> -- traceRn (text "newGlobalName: hit" <+> ppr name) `thenRn_` - returnRn name - - Nothing -> setNameSupplyRn (name_supply {nsUniqs = us', nsNames = new_cache}) `thenRn_` - -- traceRn (text "newGlobalName: new" <+> ppr name) `thenRn_` - returnRn name - where - (us', us1) = splitUniqSupply (nsUniqs name_supply) - uniq = uniqFromSupply us1 - mod = mkVanillaModule mod_name - name = mkExternalName uniq mod occ noSrcLoc - new_cache = addToFM cache key name + Just name -> -- traceRn (text "newGlobalName: hit" <+> ppr name) `thenM_` + returnM name + + Nothing -> -- traceRn (text "newGlobalName: new" <+> ppr name) `thenM_` + addNewName name_supply key (mkVanillaModule mod_name) occ noSrcLoc + +-- Look up a "system name" in the name cache. +-- This is done by the type checker... +-- For *source* declarations, this will put the thing into the name cache +-- For *interface* declarations, RnHiFiles.getSysBinders will already have +-- put it into the cache. +lookupSysName :: Name -- Base name + -> (OccName -> OccName) -- Occurrence name modifier + -> TcRn m Name -- System name +lookupSysName base_name mk_sys_occ + = getNameCache `thenM` \ name_supply -> + let + mod = nameModule base_name + occ = mk_sys_occ (nameOccName base_name) + key = (moduleName mod, occ) + in + case lookupFM (nsNames name_supply) key of + Just name -> returnM name + Nothing -> addNewName name_supply key mod occ noSrcLoc newIPName rdr_name_ip - = getNameSupplyRn `thenRn` \ name_supply -> + = getNameCache `thenM` \ name_supply -> let ipcache = nsIPs name_supply in case lookupFM ipcache key of - Just name_ip -> returnRn name_ip - Nothing -> setNameSupplyRn new_ns `thenRn_` - returnRn name_ip + Just name_ip -> returnM name_ip + Nothing -> setNameCache new_ns `thenM_` + returnM name_ip where (us', us1) = splitUniqSupply (nsUniqs name_supply) uniq = uniqFromSupply us1 @@ -185,6 +177,21 @@ newIPName rdr_name_ip new_ns = name_supply {nsUniqs = us', nsIPs = new_ipcache} where key = rdr_name_ip -- Ensures that ?x and %x get distinct Names + +addNewName :: NameCache -> (ModuleName,OccName) + -> Module -> OccName -> SrcLoc -> TcRn m Name +-- Internal function: extend the name cache, dump it back into +-- the monad, and return the new name +-- (internal, hence the rather redundant interface) +addNewName name_supply key mod occ loc + = setNameCache new_name_supply `thenM_` + returnM name + where + (us', us1) = splitUniqSupply (nsUniqs name_supply) + uniq = uniqFromSupply us1 + name = mkExternalName uniq mod occ loc + new_cache = addToFM (nsNames name_supply) key name + new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache} \end{code} %********************************************************* @@ -197,9 +204,9 @@ Looking up a name in the RnEnv. \begin{code} lookupBndrRn rdr_name - = getLocalNameEnv `thenRn` \ local_env -> + = getLocalRdrEnv `thenM` \ local_env -> case lookupRdrEnv local_env rdr_name of - Just name -> returnRn name + Just name -> returnM name Nothing -> lookupTopBndrRn rdr_name lookupTopBndrRn rdr_name @@ -209,47 +216,66 @@ lookupTopBndrRn rdr_name -- A separate function (importsFromLocalDecls) reports duplicate top level -- decls, so here it's safe just to choose an arbitrary one. - | isOrig rdr_name + -- There should never be a qualified name in a binding position + -- The parser could check this, but doesn't (yet) + | isQual rdr_name + = getSrcLocM `thenM` \ loc -> + qualNameErr (text "In its declaration") (rdr_name,loc) `thenM_` + returnM (mkUnboundName rdr_name) + + | otherwise + = ASSERT( not (isOrig rdr_name) ) + -- Original names are used only for occurrences, + -- not binding sites + + getModeRn `thenM` \ mode -> + case mode of + InterfaceMode mod -> + getSrcLocM `thenM` \ loc -> + newTopBinder mod rdr_name loc + + other -> lookupTopSrcBndr rdr_name + +lookupTopSrcBndr :: RdrName -> TcRn m Name +lookupTopSrcBndr rdr_name + = lookupTopSrcBndr_maybe rdr_name `thenM` \ maybe_name -> + case maybe_name of + Just name -> returnM name + Nothing -> unboundName rdr_name + + +lookupTopSrcBndr_maybe :: RdrName -> TcRn m (Maybe Name) +-- Look up a source-code binder + +-- Ignores imported names; for example, this is OK: +-- import Foo( f ) +-- infix 9 f -- The 'f' here does not need to be qualified +-- f x = x -- Nor here, of course + +lookupTopSrcBndr_maybe rdr_name + | Just name <- isExact_maybe rdr_name -- This is here just to catch the PrelBase defn of (say) [] and similar - -- The parser reads the special syntax and returns an Orig RdrName + -- The parser reads the special syntax and returns an Exact RdrName -- But the global_env contains only Qual RdrNames, so we won't -- find it there; instead just get the name via the Orig route -- - = -- This is a binding site for the name, so check first that it + -- We are at a binding site for the name, so check first that it -- the current module is the correct one; otherwise GHC can get -- very confused indeed. This test rejects code like -- data T = (,) Int Int -- unless we are in GHC.Tup - getModuleRn `thenRn` \ mod -> - checkRn (moduleName mod == rdrNameModule rdr_name) - (badOrigBinding rdr_name) `thenRn_` - lookupOrigName rdr_name + = getModule `thenM` \ mod -> + checkErr (moduleName mod == moduleName (nameModule name)) + (badOrigBinding rdr_name) `thenM_` + returnM (Just name) | otherwise - = getModeRn `thenRn` \ mode -> - if isInterfaceMode mode - then lookupSysBinder rdr_name - -- lookupSysBinder uses the Module in the monad to set - -- the correct module for the binder. This is important because - -- when GHCi is reading in an old interface, it just sucks it - -- in entire (Rename.loadHomeDecls) which uses lookupTopBndrRn - -- rather than via the iface file cache which uses newTopBndrRn - -- We must get the correct Module into the thing. - - else - getModuleRn `thenRn` \ mod -> - getGlobalNameEnv `thenRn` \ global_env -> - case lookup_local mod global_env rdr_name of - Just name -> returnRn name - Nothing -> failWithRn (mkUnboundName rdr_name) - (unknownNameErr rdr_name) - -lookup_local mod global_env rdr_name - = case lookupRdrEnv global_env rdr_name of - Nothing -> Nothing - Just gres -> case [n | GRE n _ _ <- gres, nameIsLocalOrFrom mod n] of - [] -> Nothing - (n:ns) -> Just n + = getGlobalRdrEnv `thenM` \ global_env -> + case lookupRdrEnv global_env rdr_name of + Nothing -> returnM Nothing + Just gres -> case [gre_name gre | gre <- gres, isLocalGRE gre] of + [] -> returnM Nothing + (n:ns) -> returnM (Just n) -- lookupSigOccRn is used for type signatures and pragmas @@ -262,42 +288,73 @@ lookup_local mod global_env rdr_name -- The Haskell98 report does not stipulate this, but it will! -- So we must treat the 'f' in the signature in the same way -- as the binding occurrence of 'f', using lookupBndrRn -lookupSigOccRn :: RdrName -> RnMS Name +lookupSigOccRn :: RdrName -> RnM Name lookupSigOccRn = lookupBndrRn -- lookupInstDeclBndr is used for the binders in an -- instance declaration. Here we use the class name to -- disambiguate. -lookupInstDeclBndr :: Name -> RdrName -> RnMS Name +lookupInstDeclBndr :: Name -> RdrName -> RnM Name -- We use the selector name as the binder lookupInstDeclBndr cls_name rdr_name - | isOrig rdr_name -- Occurs in derived instances, where we just - -- refer diectly to the right method - = lookupOrigName rdr_name - - | otherwise - = getGlobalAvails `thenRn` \ avail_env -> - case lookupNameEnv avail_env cls_name of - -- The class itself isn't in scope, so cls_name is unboundName - -- e.g. import Prelude hiding( Ord ) - -- instance Ord T where ... - -- The program is wrong, but that should not cause a crash. - Nothing -> returnRn (mkUnboundName rdr_name) + | isUnqual rdr_name + = -- Find all the things the class op name maps to + -- and pick the one with the right parent name + getGblEnv `thenM` \ gbl_env -> + let + avail_env = imp_env (tcg_imports gbl_env) + in + case lookupAvailEnv avail_env cls_name of + Nothing -> + -- If the class itself isn't in scope, then cls_name will + -- be unboundName, and there'll already be an error for + -- that in the error list. Example: + -- e.g. import Prelude hiding( Ord ) + -- instance Ord T where ... + -- The program is wrong, but that should not cause a crash. + returnM (mkUnboundName rdr_name) + Just (AvailTC _ ns) -> case [n | n <- ns, nameOccName n == occ] of - (n:ns)-> ASSERT( null ns ) returnRn n - [] -> failWithRn (mkUnboundName rdr_name) - (unknownNameErr rdr_name) + (n:ns)-> ASSERT( null ns ) returnM n + [] -> unboundName rdr_name + other -> pprPanic "lookupInstDeclBndr" (ppr cls_name) + + | isQual rdr_name -- Should never have a qualified name in a binding position + = getSrcLocM `thenM` \ loc -> + qualNameErr (text "In an instance method") (rdr_name,loc) `thenM_` + returnM (mkUnboundName rdr_name) + + | otherwise -- Occurs in derived instances, where we just + -- refer directly to the right method, and avail_env + -- isn't available + = ASSERT2( not (isQual rdr_name), ppr rdr_name ) + lookupOrigName rdr_name + where occ = rdrNameOcc rdr_name +lookupSysBndr :: RdrName -> RnM Name +-- Used for the 'system binders' in a data type or class declaration +-- Do *not* look up in the RdrEnv; these system binders are never in scope +-- Instead, get the module from the monad... but remember that +-- where the module is depends on whether we are renaming source or +-- interface file stuff +lookupSysBndr rdr_name + = getSrcLocM `thenM` \ loc -> + getModeRn `thenM` \ mode -> + case mode of + InterfaceMode mod -> newTopBinder mod rdr_name loc + other -> getModule `thenM` \ mod -> + newTopBinder mod rdr_name loc + -- lookupOccRn looks up an occurrence of a RdrName -lookupOccRn :: RdrName -> RnMS Name +lookupOccRn :: RdrName -> RnM Name lookupOccRn rdr_name - = getLocalNameEnv `thenRn` \ local_env -> + = getLocalRdrEnv `thenM` \ local_env -> case lookupRdrEnv local_env rdr_name of - Just name -> returnRn name + Just name -> returnM name Nothing -> lookupGlobalOccRn rdr_name -- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global @@ -306,18 +363,14 @@ lookupOccRn rdr_name -- class op names in class and instance decls lookupGlobalOccRn rdr_name - = getModeRn `thenRn` \ mode -> - if (isInterfaceMode mode) - then lookupIfaceName rdr_name - else + = getModeRn `thenM` \ mode -> + case mode of + InterfaceMode mod -> lookupIfaceName mod rdr_name + SourceMode -> lookupSrcName rdr_name - getGlobalNameEnv `thenRn` \ global_env -> - case mode of - SourceMode -> lookupSrcName global_env rdr_name - - CmdLineMode + CmdLineMode | not (isQual rdr_name) -> - lookupSrcName global_env rdr_name + lookupSrcName rdr_name -- We allow qualified names on the command line to refer to -- *any* name exported by any module in scope, just as if @@ -328,105 +381,120 @@ lookupGlobalOccRn rdr_name -- it isn't there, we manufacture a new occurrence of an -- original name. | otherwise -> - case lookupRdrEnv global_env rdr_name of - Just _ -> lookupSrcName global_env rdr_name - Nothing -> lookupQualifiedName rdr_name + lookupSrcName_maybe rdr_name `thenM` \ mb_name -> + case mb_name of + Just name -> returnM name + Nothing -> lookupQualifiedName rdr_name --- a qualified name on the command line can refer to any module at all: we +-- A qualified name on the command line can refer to any module at all: we -- try to load the interface if we don't already have it. -lookupQualifiedName :: RdrName -> RnM d Name +lookupQualifiedName :: RdrName -> TcRn m Name lookupQualifiedName rdr_name = let mod = rdrNameModule rdr_name occ = rdrNameOcc rdr_name in - loadInterface (ppr rdr_name) mod ImportByUser `thenRn` \ iface -> + loadInterface (ppr rdr_name) mod (ImportByUser False) `thenM` \ iface -> case [ name | (_,avails) <- mi_exports iface, avail <- avails, name <- availNames avail, nameOccName name == occ ] of - (n:ns) -> ASSERT (null ns) returnRn n - _ -> failWithRn (mkUnboundName rdr_name) (unknownNameErr rdr_name) - -lookupSrcName :: GlobalRdrEnv -> RdrName -> RnM d Name --- NB: passed GlobalEnv explicitly, not necessarily in RnMS monad -lookupSrcName global_env rdr_name - | isOrig rdr_name -- Can occur in source code too - = lookupOrigName rdr_name + (n:ns) -> ASSERT (null ns) returnM n + _ -> unboundName rdr_name + +lookupSrcName :: RdrName -> TcRn m Name +lookupSrcName rdr_name + = lookupSrcName_maybe rdr_name `thenM` \ mb_name -> + case mb_name of + Nothing -> unboundName rdr_name + Just name -> returnM name + +lookupSrcName_maybe :: RdrName -> TcRn m (Maybe Name) +lookupSrcName_maybe rdr_name + | Just name <- isExact_maybe rdr_name -- Can occur in source code too + = returnM (Just name) + + | isOrig rdr_name -- An original name + = newGlobalName (rdrNameModule rdr_name) + (rdrNameOcc rdr_name) `thenM` \ name -> + returnM (Just name) | otherwise - = case lookupRdrEnv global_env rdr_name of - Just [GRE name _ Nothing] -> returnRn name - Just [GRE name _ (Just deprec)] -> warnDeprec name deprec `thenRn_` - returnRn name - Just stuff@(GRE name _ _ : _) -> addNameClashErrRn rdr_name stuff `thenRn_` - returnRn name - Nothing -> failWithRn (mkUnboundName rdr_name) - (unknownNameErr rdr_name) - -lookupOrigName :: RdrName -> RnM d Name -lookupOrigName rdr_name - = -- NO: ASSERT( isOrig rdr_name ) - -- Now that .hi-boot files are read by the main parser, they contain - -- ordinary qualified names (which we treat as Orig names here). - newGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name) - -lookupIfaceUnqual :: RdrName -> RnM d Name -lookupIfaceUnqual rdr_name - = ASSERT( isUnqual rdr_name ) + = lookupGRE rdr_name `thenM` \ mb_gre -> + case mb_gre of + Nothing -> returnM Nothing + Just gre -> returnM (Just (gre_name gre)) + +lookupGRE :: RdrName -> TcRn m (Maybe GlobalRdrElt) +lookupGRE rdr_name + = getGlobalRdrEnv `thenM` \ global_env -> + case lookupRdrEnv global_env rdr_name of + Just [gre] -> case gre_deprec gre of + Nothing -> returnM (Just gre) + Just _ -> warnDeprec gre `thenM_` + returnM (Just gre) + Just stuff@(gre : _) -> addNameClashErrRn rdr_name stuff `thenM_` + returnM (Just gre) + Nothing -> return Nothing + +lookupIfaceName :: Module -> RdrName -> TcRn m Name -- An Unqual is allowed; interface files contain -- unqualified names for locally-defined things, such as -- constructors of a data type. - getModuleRn `thenRn ` \ mod -> - newGlobalName (moduleName mod) (rdrNameOcc rdr_name) - -lookupIfaceName :: RdrName -> RnM d Name -lookupIfaceName rdr_name - | isUnqual rdr_name = lookupIfaceUnqual rdr_name +lookupIfaceName mod rdr_name + | isUnqual rdr_name = newGlobalName (moduleName mod) (rdrNameOcc rdr_name) | otherwise = lookupOrigName rdr_name -\end{code} -@lookupOrigName@ takes an RdrName representing an {\em original} -name, and adds it to the occurrence pool so that it'll be loaded -later. This is used when language constructs (such as monad -comprehensions, overloaded literals, or deriving clauses) require some -stuff to be loaded that isn't explicitly mentioned in the code. - -This doesn't apply in interface mode, where everything is explicit, -but we don't check for this case: it does no harm to record an -``extra'' occurrence and @lookupOrigNames@ isn't used much in -interface mode (it's only the @Nothing@ clause of @rnDerivs@ that -calls it at all I think). - - \fbox{{\em Jan 98: this comment is wrong: @rnHsType@ uses it quite a bit.}} - -\begin{code} -lookupOrigNames :: [RdrName] -> RnM d NameSet -lookupOrigNames rdr_names - = mapRn lookupOrigName rdr_names `thenRn` \ names -> - returnRn (mkNameSet names) +lookupOrigName :: RdrName -> TcRn m Name + -- Just for original or exact names +lookupOrigName rdr_name + | Just n <- isExact_maybe rdr_name + -- This happens in derived code, which we + -- rename in InterfaceMode + = returnM n + + | otherwise -- Usually Orig, but can be a Qual when + -- we are reading a .hi-boot file + = newGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name) + + +dataTcOccs :: RdrName -> [RdrName] +-- If the input is a data constructor, return both it and a type +-- constructor. This is useful when we aren't sure which we are +-- looking at +dataTcOccs rdr_name + | isDataOcc occ = [rdr_name, rdr_name_tc] + | otherwise = [rdr_name] + where + occ = rdrNameOcc rdr_name + rdr_name_tc = setRdrNameSpace rdr_name tcName \end{code} -lookupSysBinder is used for the "system binders" of a type, class, or -instance decl. It ensures that the module is set correctly in the -name cache, and sets the provenance on the returned name too. The -returned name will end up actually in the type, class, or instance. - \begin{code} -lookupSysBinder rdr_name - = ASSERT( isUnqual rdr_name ) - getModuleRn `thenRn` \ mod -> - getSrcLocRn `thenRn` \ loc -> - newTopBinder mod rdr_name loc +unboundName rdr_name = addErr (unknownNameErr rdr_name) `thenM_` + returnM (mkUnboundName rdr_name) \end{code} - %********************************************************* %* * -\subsection{Looking up fixities} + Fixities %* * %********************************************************* +\begin{code} +-------------------------------- +bindLocalFixities :: [RenamedFixitySig] -> RnM a -> RnM a +-- Used for nested fixity decls +-- No need to worry about type constructors here, +-- Should check for duplicates but we don't +bindLocalFixities fixes thing_inside + | null fixes = thing_inside + | otherwise = extendFixityEnv new_bit thing_inside + where + new_bit = [(n,s) | s@(FixitySig n _ _) <- fixes] +\end{code} + +-------------------------------- lookupFixity is a bit strange. * Nested local fixity decls are put in the local fixity env, which we @@ -441,13 +509,13 @@ lookupFixity is a bit strange. We put them all in the local fixity environment \begin{code} -lookupFixityRn :: Name -> RnMS Fixity +lookupFixityRn :: Name -> RnM Fixity lookupFixityRn name - = getModuleRn `thenRn` \ this_mod -> + = getModule `thenM` \ this_mod -> if nameIsLocalOrFrom this_mod name then -- It's defined in this module - getFixityEnv `thenRn` \ local_fix_env -> - returnRn (lookupLocalFixity local_fix_env name) + getFixityEnv `thenM` \ local_fix_env -> + returnM (lookupFixity local_fix_env name) else -- It's imported -- For imported names, we have to get their fixities by doing a @@ -463,59 +531,11 @@ lookupFixityRn name -- nothing from B will be used). When we come across a use of -- 'f', we need to know its fixity, and it's then, and only -- then, that we load B.hi. That is what's happening here. - loadInterface doc name_mod ImportBySystem `thenRn` \ iface -> - returnRn (lookupFixity (mi_fixities iface) name) + loadInterface doc name_mod ImportBySystem `thenM` \ iface -> + returnM (lookupFixity (mi_fixities iface) name) where doc = ptext SLIT("Checking fixity for") <+> ppr name name_mod = moduleName (nameModule name) - --------------------------------- -lookupLocalFixity :: LocalFixityEnv -> Name -> Fixity -lookupLocalFixity env name - = case lookupNameEnv env name of - Just (FixitySig _ fix _) -> fix - Nothing -> defaultFixity - -extendNestedFixityEnv :: [(Name, RenamedFixitySig)] -> RnMS a -> RnMS a --- Used for nested fixity decls --- No need to worry about type constructors here, --- Should check for duplicates but we don't -extendNestedFixityEnv fixes enclosed_scope - = getFixityEnv `thenRn` \ fix_env -> - let - new_fix_env = extendNameEnvList fix_env fixes - in - setFixityEnv new_fix_env enclosed_scope - -mkTopFixityEnv :: GlobalRdrEnv -> [RdrNameFixitySig] -> RnMG LocalFixityEnv -mkTopFixityEnv gbl_env fix_sigs - = getModuleRn `thenRn` \ mod -> - let - -- GHC extension: look up both the tycon and data con - -- for con-like things - -- If neither are in scope, report an error; otherwise - -- add both to the fixity env - go fix_env (FixitySig rdr_name fixity loc) - = case catMaybes (map (lookup_local mod gbl_env) rdr_names) of - [] -> pushSrcLocRn loc $ - addErrRn (unknownNameErr rdr_name) `thenRn_` - returnRn fix_env - ns -> foldlRn add fix_env ns - - where - add fix_env name - = case lookupNameEnv fix_env name of - Just (FixitySig _ _ loc') -> addErrRn (dupFixityDecl rdr_name loc loc') `thenRn_` - returnRn fix_env - Nothing -> returnRn (extendNameEnv fix_env name (FixitySig name fixity loc)) - - rdr_names | isDataSymOcc occ = [rdr_name, rdr_name_tc] - | otherwise = [rdr_name] - - occ = rdrNameOcc rdr_name - rdr_name_tc = setRdrNameOcc rdr_name (setOccNameSpace occ tcName) - in - foldlRn go emptyLocalFixityEnv fix_sigs \end{code} @@ -529,65 +549,42 @@ mkTopFixityEnv gbl_env fix_sigs mentioned explicitly, but which might be needed by the type checker. \begin{code} -getImplicitStmtFVs -- Compiling a statement - = returnRn (mkFVs [printName, bindIOName, thenIOName, - returnIOName, failIOName] - `plusFV` ubiquitousNames) +implicitStmtFVs source_fvs -- Compiling a statement + = stmt_fvs `plusFV` implicitModuleFVs source_fvs + where + stmt_fvs = mkFVs [printName, bindIOName, thenIOName, returnIOName, failIOName] -- These are all needed implicitly when compiling a statement -- See TcModule.tc_stmts -getImplicitModuleFVs decls -- Compiling a module - = lookupOrigNames deriv_occs `thenRn` \ deriving_names -> - returnRn (deriving_names `plusFV` ubiquitousNames) - where - -- deriv_classes is now a list of HsTypes, so a "normal" one - -- appears as a (HsClassP c []). The non-normal ones for the new - -- newtype-deriving extension, and they don't require any - -- implicit names, so we can silently filter them out. - deriv_occs = [occ | TyClD (TyData {tcdDerivs = Just deriv_classes}) <- decls, - HsClassP cls [] <- deriv_classes, - occ <- lookupWithDefaultUFM derivingOccurrences [] cls ] +implicitModuleFVs source_fvs + = mkTemplateHaskellFVs source_fvs `plusFV` + namesNeededForFlattening `plusFV` + ubiquitousNames + + -- This is a bit of a hack. When we see the Template-Haskell construct + -- [| expr |] + -- we are going to need lots of the ``smart constructors'' defined in + -- the main Template Haskell data type module. Rather than treat them + -- all as free vars at every occurrence site, we just make the Q type + -- consructor a free var.... and then use that here to haul in the others +mkTemplateHaskellFVs source_fvs +#ifdef GHCI + -- Only if Template Haskell is enabled + | qTyConName `elemNameSet` source_fvs = templateHaskellNames +#endif + | otherwise = emptyFVs -- ubiquitous_names are loaded regardless, because -- they are needed in virtually every program ubiquitousNames = mkFVs [unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name, eqStringName] - -- Virtually every program has error messages in it somewhere - - `plusFV` + -- Virtually every program has error messages in it somewhere + `plusFV` mkFVs [getName unitTyCon, funTyConName, boolTyConName, intTyConName] - -- Add occurrences for very frequently used types. - -- (e.g. we don't want to be bothered with making funTyCon a - -- free var at every function application!) - `plusFV` - namesNeededForFlattening - -- this will be empty unless flattening is activated - -checkMain ghci_mode mod_name gbl_env - -- LOOKUP main IF WE'RE IN MODULE Main - -- The main point of this is to drag in the declaration for 'main', - -- its in another module, and for the Prelude function 'runIO', - -- so that the type checker will find them - -- - -- We have to return the main_name separately, because it's a - -- bona fide 'use', and should be recorded as such, but the others - -- aren't - | mod_name /= mAIN_Name - = returnRn (Nothing, emptyFVs, emptyFVs) - - | not (main_RDR_Unqual `elemRdrEnv` gbl_env) - = complain_no_main `thenRn_` - returnRn (Nothing, emptyFVs, emptyFVs) - - | otherwise - = lookupSrcName gbl_env main_RDR_Unqual `thenRn` \ main_name -> - returnRn (Just main_name, unitFV main_name, unitFV runIOName) - - where - complain_no_main | ghci_mode == Interactive = addWarnRn noMainMsg - | otherwise = addErrRn noMainMsg - -- In interactive mode, only warn about the absence of main + -- Add occurrences for very frequently used types. + -- (e.g. we don't want to be bothered with making + -- funTyCon a free var at every function application!) \end{code} %************************************************************************ @@ -625,22 +622,23 @@ checks the type of the user thing against the type of the standard thing. \begin{code} lookupSyntaxName :: Name -- The standard name - -> RnMS (Name, FreeVars) -- Possibly a non-standard name + -> RnM (Name, FreeVars) -- Possibly a non-standard name lookupSyntaxName std_name - = getModeRn `thenRn` \ mode -> - case mode of { - InterfaceMode -> returnRn (std_name, unitFV std_name) ; + = getModeRn `thenM` \ mode -> + if isInterfaceMode mode then + returnM (std_name, unitFV std_name) -- Happens for 'derived' code -- where we don't want to rebind - other -> + else - doptRn Opt_NoImplicitPrelude `thenRn` \ no_prelude -> + doptM Opt_NoImplicitPrelude `thenM` \ no_prelude -> if not no_prelude then - returnRn (std_name, unitFV std_name) -- Normal case + returnM (std_name, unitFV std_name) -- Normal case + else -- Get the similarly named thing from the local environment - lookupOccRn (mkRdrUnqual (nameOccName std_name)) `thenRn` \ usr_name -> - returnRn (usr_name, mkFVs [usr_name, std_name]) } + lookupOccRn (mkRdrUnqual (nameOccName std_name)) `thenM` \ usr_name -> + returnM (usr_name, mkFVs [usr_name, std_name]) \end{code} @@ -652,55 +650,53 @@ lookupSyntaxName std_name \begin{code} newLocalsRn :: [(RdrName,SrcLoc)] - -> RnMS [Name] + -> RnM [Name] newLocalsRn rdr_names_w_loc - = getNameSupplyRn `thenRn` \ name_supply -> + = newUniqueSupply `thenM` \ us -> let - (us', us1) = splitUniqSupply (nsUniqs name_supply) - uniqs = uniqsFromSupply us1 + uniqs = uniqsFromSupply us names = [ mkInternalName uniq (rdrNameOcc rdr_name) loc | ((rdr_name,loc), uniq) <- rdr_names_w_loc `zip` uniqs ] in - setNameSupplyRn (name_supply {nsUniqs = us'}) `thenRn_` - returnRn names + returnM names bindLocatedLocalsRn :: SDoc -- Documentation string for error message -> [(RdrName,SrcLoc)] - -> ([Name] -> RnMS a) - -> RnMS a + -> ([Name] -> RnM a) + -> RnM a bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope - = getModeRn `thenRn` \ mode -> - getLocalNameEnv `thenRn` \ local_env -> - getGlobalNameEnv `thenRn` \ global_env -> + = getModeRn `thenM` \ mode -> + getLocalRdrEnv `thenM` \ local_env -> + getGlobalRdrEnv `thenM` \ global_env -> -- Check for duplicate names - checkDupOrQualNames doc_str rdr_names_w_loc `thenRn_` + checkDupOrQualNames doc_str rdr_names_w_loc `thenM_` -- Warn about shadowing, but only in source modules let check_shadow (rdr_name,loc) | rdr_name `elemRdrEnv` local_env || rdr_name `elemRdrEnv` global_env - = pushSrcLocRn loc $ addWarnRn (shadowedNameWarn rdr_name) + = addSrcLoc loc $ addWarn (shadowedNameWarn rdr_name) | otherwise - = returnRn () + = returnM () in (case mode of - SourceMode -> ifOptRn Opt_WarnNameShadowing $ - mapRn_ check_shadow rdr_names_w_loc - other -> returnRn () - ) `thenRn_` + SourceMode -> ifOptM Opt_WarnNameShadowing $ + mappM_ check_shadow rdr_names_w_loc + other -> returnM () + ) `thenM_` - newLocalsRn rdr_names_w_loc `thenRn` \ names -> + newLocalsRn rdr_names_w_loc `thenM` \ names -> let new_local_env = addListToRdrEnv local_env (map fst rdr_names_w_loc `zip` names) in - setLocalNameEnv new_local_env (enclosed_scope names) + setLocalRdrEnv new_local_env (enclosed_scope names) -bindCoreLocalRn :: RdrName -> (Name -> RnMS a) -> RnMS a +bindCoreLocalRn :: RdrName -> (Name -> RnM a) -> RnM a -- A specialised variant when renaming stuff from interface -- files (of which there is a lot) -- * one at a time @@ -708,19 +704,14 @@ bindCoreLocalRn :: RdrName -> (Name -> RnMS a) -> RnMS a -- * always imported -- * deal with free vars bindCoreLocalRn rdr_name enclosed_scope - = getSrcLocRn `thenRn` \ loc -> - getLocalNameEnv `thenRn` \ name_env -> - getNameSupplyRn `thenRn` \ name_supply -> - let - (us', us1) = splitUniqSupply (nsUniqs name_supply) - uniq = uniqFromSupply us1 - name = mkInternalName uniq (rdrNameOcc rdr_name) loc - in - setNameSupplyRn (name_supply {nsUniqs = us'}) `thenRn_` + = getSrcLocM `thenM` \ loc -> + getLocalRdrEnv `thenM` \ name_env -> + newUnique `thenM` \ uniq -> let + name = mkInternalName uniq (rdrNameOcc rdr_name) loc new_name_env = extendRdrEnv name_env rdr_name name in - setLocalNameEnv new_name_env (enclosed_scope name) + setLocalRdrEnv new_name_env (enclosed_scope name) bindCoreLocalsRn [] thing_inside = thing_inside [] bindCoreLocalsRn (b:bs) thing_inside = bindCoreLocalRn b $ \ name' -> @@ -728,25 +719,25 @@ bindCoreLocalsRn (b:bs) thing_inside = bindCoreLocalRn b $ \ name' -> thing_inside (name':names') bindLocalNames names enclosed_scope - = getLocalNameEnv `thenRn` \ name_env -> - setLocalNameEnv (extendLocalRdrEnv name_env names) + = getLocalRdrEnv `thenM` \ name_env -> + setLocalRdrEnv (extendLocalRdrEnv name_env names) enclosed_scope bindLocalNamesFV names enclosed_scope = bindLocalNames names $ - enclosed_scope `thenRn` \ (thing, fvs) -> - returnRn (thing, delListFromNameSet fvs names) + enclosed_scope `thenM` \ (thing, fvs) -> + returnM (thing, delListFromNameSet fvs names) ------------------------------------- bindLocalRn doc rdr_name enclosed_scope - = getSrcLocRn `thenRn` \ loc -> + = getSrcLocM `thenM` \ loc -> bindLocatedLocalsRn doc [(rdr_name,loc)] $ \ (n:ns) -> ASSERT( null ns ) enclosed_scope n bindLocalsRn doc rdr_names enclosed_scope - = getSrcLocRn `thenRn` \ loc -> + = getSrcLocM `thenM` \ loc -> bindLocatedLocalsRn doc (rdr_names `zip` repeat loc) enclosed_scope @@ -755,21 +746,21 @@ bindLocalsRn doc rdr_names enclosed_scope -- except that it deals with free vars bindLocalsFVRn doc rdr_names enclosed_scope = bindLocalsRn doc rdr_names $ \ names -> - enclosed_scope names `thenRn` \ (thing, fvs) -> - returnRn (thing, delListFromNameSet fvs names) + enclosed_scope names `thenM` \ (thing, fvs) -> + returnM (thing, delListFromNameSet fvs names) ------------------------------------- -extendTyVarEnvFVRn :: [Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars) +extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) -- This tiresome function is used only in rnSourceDecl on InstDecl extendTyVarEnvFVRn tyvars enclosed_scope - = bindLocalNames tyvars enclosed_scope `thenRn` \ (thing, fvs) -> - returnRn (thing, delListFromNameSet fvs tyvars) + = bindLocalNames tyvars enclosed_scope `thenM` \ (thing, fvs) -> + returnM (thing, delListFromNameSet fvs tyvars) bindTyVarsRn :: SDoc -> [HsTyVarBndr RdrName] - -> ([HsTyVarBndr Name] -> RnMS a) - -> RnMS a + -> ([HsTyVarBndr Name] -> RnM a) + -> RnM a bindTyVarsRn doc_str tyvar_names enclosed_scope - = getSrcLocRn `thenRn` \ loc -> + = getSrcLocM `thenM` \ loc -> let located_tyvars = [(hsTyVarName tv, loc) | tv <- tyvar_names] in @@ -777,14 +768,14 @@ bindTyVarsRn doc_str tyvar_names enclosed_scope enclosed_scope (zipWith replaceTyVarName tyvar_names names) bindPatSigTyVars :: [RdrNameHsType] - -> RnMS (a, FreeVars) - -> RnMS (a, FreeVars) + -> RnM (a, FreeVars) + -> RnM (a, FreeVars) -- Find the type variables in the pattern type -- signatures that must be brought into scope bindPatSigTyVars tys enclosed_scope - = getLocalNameEnv `thenRn` \ name_env -> - getSrcLocRn `thenRn` \ loc -> + = getLocalRdrEnv `thenM` \ name_env -> + getSrcLocM `thenM` \ loc -> let forall_tyvars = nub [ tv | ty <- tys, tv <- extractHsTyRdrTyVars ty, @@ -798,26 +789,26 @@ bindPatSigTyVars tys enclosed_scope doc_sig = text "In a pattern type-signature" in bindLocatedLocalsRn doc_sig located_tyvars $ \ names -> - enclosed_scope `thenRn` \ (thing, fvs) -> - returnRn (thing, delListFromNameSet fvs names) + enclosed_scope `thenM` \ (thing, fvs) -> + returnM (thing, delListFromNameSet fvs names) ------------------------------------- checkDupOrQualNames, checkDupNames :: SDoc -> [(RdrName, SrcLoc)] - -> RnM d () + -> TcRn m () -- Works in any variant of the renamer monad checkDupOrQualNames doc_str rdr_names_w_loc = -- Check for use of qualified names - mapRn_ (qualNameErr doc_str) quals `thenRn_` + mappM_ (qualNameErr doc_str) quals `thenM_` checkDupNames doc_str rdr_names_w_loc where quals = filter (isQual . fst) rdr_names_w_loc checkDupNames doc_str rdr_names_w_loc = -- Check for duplicated names in a binding group - mapRn_ (dupNamesErr doc_str) dups + mappM_ (dupNamesErr doc_str) dups where (_, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `compare` n2) rdr_names_w_loc \end{code} @@ -864,13 +855,17 @@ mkGlobalRdrEnv this_mod unqual_imp mk_provenance avails deprecs -- duplicates. So the simple thing is to do the fold. add_avail :: GlobalRdrEnv -> AvailInfo -> GlobalRdrEnv - add_avail env avail = foldl add_name env (availNames avail) + add_avail env avail = foldl (add_name (availName avail)) env (availNames avail) - add_name env name -- Add qualified name only - = addOneToGlobalRdrEnv env (mkRdrQual this_mod occ) elt + add_name parent env name -- Add qualified name only + = addOneToGlobalRdrEnv env (mkRdrQual this_mod occ) elt where occ = nameOccName name - elt = GRE name (mk_provenance name) (lookupDeprec deprecs name) + elt = GRE {gre_name = name, + gre_parent = parent, + gre_prov = mk_provenance name, + gre_deprec = lookupDeprec deprecs name} + \end{code} \begin{code} @@ -895,11 +890,12 @@ combine_globals ns_old ns_new -- ns_new is often short choose n m | n `beats` m = n | otherwise = m - (GRE n pn _) `beats` (GRE m pm _) = n==m && pn `hasBetterProv` pm + g1 `beats` g2 = gre_name g1 == gre_name g2 && + gre_prov g1 `hasBetterProv` gre_prov g2 is_duplicate :: GlobalRdrElt -> GlobalRdrElt -> Bool - is_duplicate (GRE n1 LocalDef _) (GRE n2 LocalDef _) = False - is_duplicate (GRE n1 _ _) (GRE n2 _ _) = n1 == n2 + is_duplicate g1 g2 | isLocalGRE g1 && isLocalGRE g2 = False + is_duplicate g1 g2 = gre_name g1 == gre_name g2 \end{code} We treat two bindings of a locally-defined name as a duplicate, @@ -915,159 +911,6 @@ defn of the same name; in this case the names will compare as equal, but will still have different provenances. -@unQualInScope@ returns a function that takes a @Name@ and tells whether -its unqualified name is in scope. This is put as a boolean flag in -the @Name@'s provenance to guide whether or not to print the name qualified -in error messages. - -\begin{code} -unQualInScope :: GlobalRdrEnv -> Name -> Bool --- True if 'f' is in scope, and has only one binding, --- and the thing it is bound to is the name we are looking for --- (i.e. false if A.f and B.f are both in scope as unqualified 'f') --- --- This fn is only efficient if the shared --- partial application is used a lot. -unQualInScope env - = (`elemNameSet` unqual_names) - where - unqual_names :: NameSet - unqual_names = foldRdrEnv add emptyNameSet env - add rdr_name [GRE name _ _] unquals | isUnqual rdr_name = addOneToNameSet unquals name - add _ _ unquals = unquals -\end{code} - - -%************************************************************************ -%* * -\subsection{Avails} -%* * -%************************************************************************ - -\begin{code} -plusAvail (Avail n1) (Avail n2) = Avail n1 -plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n2 (nub (ns1 ++ ns2)) --- Added SOF 4/97 -#ifdef DEBUG -plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2]) -#endif - -addAvail :: AvailEnv -> AvailInfo -> AvailEnv -addAvail avails avail = extendNameEnv_C plusAvail avails (availName avail) avail - -unitAvailEnv :: AvailInfo -> AvailEnv -unitAvailEnv a = unitNameEnv (availName a) a - -plusAvailEnv :: AvailEnv -> AvailEnv -> AvailEnv -plusAvailEnv = plusNameEnv_C plusAvail - -availEnvElts = nameEnvElts - -addAvailToNameSet :: NameSet -> AvailInfo -> NameSet -addAvailToNameSet names avail = addListToNameSet names (availNames avail) - -availsToNameSet :: [AvailInfo] -> NameSet -availsToNameSet avails = foldl addAvailToNameSet emptyNameSet avails - -availName :: GenAvailInfo name -> name -availName (Avail n) = n -availName (AvailTC n _) = n - -availNames :: GenAvailInfo name -> [name] -availNames (Avail n) = [n] -availNames (AvailTC n ns) = ns - -------------------------------------- -filterAvail :: RdrNameIE -- Wanted - -> AvailInfo -- Available - -> Maybe AvailInfo -- Resulting available; - -- Nothing if (any of the) wanted stuff isn't there - -filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns) - | sub_names_ok = Just (AvailTC n (filter is_wanted ns)) - | otherwise = Nothing - where - is_wanted name = nameOccName name `elem` wanted_occs - sub_names_ok = all (`elem` avail_occs) wanted_occs - avail_occs = map nameOccName ns - wanted_occs = map rdrNameOcc (want:wants) - -filterAvail (IEThingAbs _) (AvailTC n ns) = ASSERT( n `elem` ns ) - Just (AvailTC n [n]) - -filterAvail (IEThingAbs _) avail@(Avail n) = Just avail -- Type synonyms - -filterAvail (IEVar _) avail@(Avail n) = Just avail -filterAvail (IEVar v) avail@(AvailTC n ns) = Just (AvailTC n (filter wanted ns)) - where - wanted n = nameOccName n == occ - occ = rdrNameOcc v - -- The second equation happens if we import a class op, thus - -- import A( op ) - -- where op is a class operation - -filterAvail (IEThingAll _) avail@(AvailTC _ _) = Just avail - -- We don't complain even if the IE says T(..), but - -- no constrs/class ops of T are available - -- Instead that's caught with a warning by the caller - -filterAvail ie avail = Nothing - -------------------------------------- -groupAvails :: Module -> Avails -> [(ModuleName, Avails)] - -- Group by module and sort by occurrence - -- This keeps the list in canonical order -groupAvails this_mod avails - = [ (mkSysModuleNameFS fs, sortLt lt avails) - | (fs,avails) <- fmToList groupFM - ] - where - groupFM :: FiniteMap FastString Avails - -- Deliberately use the FastString so we - -- get a canonical ordering - groupFM = foldl add emptyFM avails - - add env avail = addToFM_C combine env mod_fs [avail'] - where - mod_fs = moduleNameFS (moduleName avail_mod) - avail_mod = case nameModule_maybe (availName avail) of - Just m -> m - Nothing -> this_mod - combine old _ = avail':old - avail' = sortAvail avail - - a1 `lt` a2 = occ1 < occ2 - where - occ1 = nameOccName (availName a1) - occ2 = nameOccName (availName a2) - -sortAvail :: AvailInfo -> AvailInfo --- Sort the sub-names into canonical order. --- The canonical order has the "main name" at the beginning --- (if it's there at all) -sortAvail (Avail n) = Avail n -sortAvail (AvailTC n ns) | n `elem` ns = AvailTC n (n : sortLt lt (filter (/= n) ns)) - | otherwise = AvailTC n ( sortLt lt ns) - where - n1 `lt` n2 = nameOccName n1 < nameOccName n2 -\end{code} - -\begin{code} -pruneAvails :: (Name -> Bool) -- Keep if this is True - -> [AvailInfo] - -> [AvailInfo] -pruneAvails keep avails - = mapMaybe del avails - where - del :: AvailInfo -> Maybe AvailInfo -- Nothing => nothing left! - del (Avail n) | keep n = Just (Avail n) - | otherwise = Nothing - del (AvailTC n ns) | null ns' = Nothing - | otherwise = Just (AvailTC n ns') - where - ns' = filter keep ns -\end{code} - %************************************************************************ %* * \subsection{Free variable manipulation} @@ -1076,11 +919,11 @@ pruneAvails keep avails \begin{code} -- A useful utility -mapFvRn f xs = mapRn f xs `thenRn` \ stuff -> +mapFvRn f xs = mappM f xs `thenM` \ stuff -> let (ys, fvs_s) = unzip stuff in - returnRn (ys, plusFVs fvs_s) + returnM (ys, plusFVs fvs_s) \end{code} @@ -1091,31 +934,31 @@ mapFvRn f xs = mapRn f xs `thenRn` \ stuff -> %************************************************************************ \begin{code} -warnUnusedModules :: [ModuleName] -> RnM d () +warnUnusedModules :: [ModuleName] -> TcRn m () warnUnusedModules mods - = ifOptRn Opt_WarnUnusedImports (mapRn_ (addWarnRn . unused_mod) mods) + = ifOptM Opt_WarnUnusedImports (mappM_ (addWarn . unused_mod) mods) where unused_mod m = vcat [ptext SLIT("Module") <+> quotes (ppr m) <+> text "is imported, but nothing from it is used", - parens (ptext SLIT("except perhaps to re-export instances visible in") <+> + parens (ptext SLIT("except perhaps instances visible in") <+> quotes (ppr m))] -warnUnusedImports :: [(Name,Provenance)] -> RnM d () -warnUnusedImports names - = ifOptRn Opt_WarnUnusedImports (warnUnusedBinds names) +warnUnusedImports, warnUnusedTopBinds :: [GlobalRdrElt] -> TcRn m () +warnUnusedImports gres = ifOptM Opt_WarnUnusedImports (warnUnusedGREs gres) +warnUnusedTopBinds gres = ifOptM Opt_WarnUnusedBinds (warnUnusedGREs gres) -warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> RnM d () -warnUnusedLocalBinds names - = ifOptRn Opt_WarnUnusedBinds (warnUnusedBinds [(n,LocalDef) | n<-names]) - -warnUnusedMatches names - = ifOptRn Opt_WarnUnusedMatches (warnUnusedGroup [(n,LocalDef) | n<-names]) +warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> TcRn m () +warnUnusedLocalBinds names = ifOptM Opt_WarnUnusedBinds (warnUnusedLocals names) +warnUnusedMatches names = ifOptM Opt_WarnUnusedMatches (warnUnusedLocals names) ------------------------- +-- Helpers +warnUnusedGREs gres = warnUnusedBinds [(n,p) | GRE {gre_name = n, gre_prov = p} <- gres] +warnUnusedLocals names = warnUnusedBinds [(n,LocalDef) | n<-names] -warnUnusedBinds :: [(Name,Provenance)] -> RnM d () +warnUnusedBinds :: [(Name,Provenance)] -> TcRn m () warnUnusedBinds names - = mapRn_ warnUnusedGroup groups + = mappM_ warnUnusedGroup groups where -- Group by provenance groups = equivClasses cmp names @@ -1124,13 +967,13 @@ warnUnusedBinds names ------------------------- -warnUnusedGroup :: [(Name,Provenance)] -> RnM d () +warnUnusedGroup :: [(Name,Provenance)] -> TcRn m () warnUnusedGroup names - | null filtered_names = returnRn () - | not is_local = returnRn () + | null filtered_names = returnM () + | not is_local = returnM () | otherwise - = pushSrcLocRn def_loc $ - addWarnRn $ + = addSrcLoc def_loc $ + addWarn $ sep [msg <> colon, nest 4 (fsep (punctuate comma (map (ppr.fst) filtered_names)))] where filtered_names = filter reportable names @@ -1151,20 +994,18 @@ warnUnusedGroup names \begin{code} addNameClashErrRn rdr_name (np1:nps) - = addErrRn (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name), + = addErr (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name), ptext SLIT("It could refer to") <+> vcat (msg1 : msgs)]) where msg1 = ptext SLIT("either") <+> mk_ref np1 msgs = [ptext SLIT(" or") <+> mk_ref np | np <- nps] - mk_ref (GRE name prov _) = quotes (ppr name) <> comma <+> pprNameProvenance name prov + mk_ref gre = quotes (ppr (gre_name gre)) <> comma <+> pprNameProvenance gre shadowedNameWarn shadow = hsep [ptext SLIT("This binding for"), quotes (ppr shadow), ptext SLIT("shadows an existing binding")] -noMainMsg = ptext SLIT("No 'main' defined in module Main") - unknownNameErr name = sep [text flavour, ptext SLIT("not in scope:"), quotes (ppr name)] where @@ -1175,26 +1016,21 @@ badOrigBinding name -- The rdrNameOcc is because we don't want to print Prelude.(,) qualNameErr descriptor (name,loc) - = pushSrcLocRn loc $ - addErrRn (vcat [ ptext SLIT("Invalid use of qualified name") <+> quotes (ppr name), + = addSrcLoc loc $ + addErr (vcat [ ptext SLIT("Invalid use of qualified name") <+> quotes (ppr name), descriptor]) dupNamesErr descriptor ((name,loc) : dup_things) - = pushSrcLocRn loc $ - addErrRn ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name)) + = addSrcLoc loc $ + addErr ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name)) $$ descriptor) -warnDeprec :: Name -> DeprecTxt -> RnM d () -warnDeprec name txt - = ifOptRn Opt_WarnDeprecations $ - addWarnRn (sep [ text (occNameFlavour (nameOccName name)) <+> +warnDeprec :: GlobalRdrElt -> TcRn m () +warnDeprec (GRE {gre_name = name, gre_deprec = Just txt}) + = ifOptM Opt_WarnDeprecations $ + addWarn (sep [ text (occNameFlavour (nameOccName name)) <+> quotes (ppr name) <+> text "is deprecated:", nest 4 (ppr txt) ]) - -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] \end{code} diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index f48d7326b8..a4d6a35cec 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -11,18 +11,18 @@ free variables. \begin{code} module RnExpr ( - rnMatch, rnGRHSs, rnPat, rnExpr, rnExprs, rnStmt, - checkPrecMatch + rnMatch, rnGRHSs, rnPat, rnExpr, rnExprs, + rnStmt, rnStmts, checkPrecMatch ) where #include "HsVersions.h" -import {-# SOURCE #-} RnBinds ( rnBinds ) +import {-# SOURCE #-} RnSource ( rnSrcDecls, rnBinds ) import HsSyn import RdrHsSyn import RnHsSyn -import RnMonad +import TcRnMonad import RnEnv import RnTypes ( rnHsTypeFVs, precParseErr, sectionPrecErr ) import CmdLineOpts ( DynFlag(..), opt_IgnoreAsserts ) @@ -32,20 +32,19 @@ import BasicTypes ( Fixity(..), FixityDirection(..), IPName(..), import PrelNames ( hasKey, assertIdKey, eqClassName, foldrName, buildName, eqStringName, cCallableClassName, cReturnableClassName, - monadClassName, enumClassName, ordClassName, + enumClassName, ordClassName, ratioDataConName, splitName, fstName, sndName, ioDataConName, plusIntegerName, timesIntegerName, - assertErr_RDR, replicatePName, mapPName, filterPName, - falseDataConName, trueDataConName, crossPName, - zipPName, lengthPName, indexPName, toPName, - enumFromToPName, enumFromThenToPName, + crossPName, zipPName, lengthPName, indexPName, toPName, + enumFromToPName, enumFromThenToPName, assertName, fromIntegerName, fromRationalName, minusName, negateName, - monadNames ) + qTyConName, monadNames ) import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon, floatPrimTyCon, doublePrimTyCon ) import TysWiredIn ( intTyCon ) -import Name ( NamedThing(..), mkSystemName, nameSrcLoc ) +import RdrName ( RdrName ) +import Name ( Name, NamedThing(..), mkSystemName, nameSrcLoc, nameOccName ) import NameSet import UnicodeUtil ( stringToUtf8 ) import UniqFM ( isNullUFM ) @@ -64,111 +63,116 @@ import FastString ********************************************************* \begin{code} -rnPat :: RdrNamePat -> RnMS (RenamedPat, FreeVars) +rnPat :: RdrNamePat -> RnM (RenamedPat, FreeVars) -rnPat WildPatIn = returnRn (WildPatIn, emptyFVs) +rnPat (WildPat _) = returnM (WildPat placeHolderType, emptyFVs) -rnPat (VarPatIn name) - = lookupBndrRn name `thenRn` \ vname -> - returnRn (VarPatIn vname, emptyFVs) +rnPat (VarPat name) + = lookupBndrRn name `thenM` \ vname -> + returnM (VarPat vname, emptyFVs) rnPat (SigPatIn pat ty) - = doptRn Opt_GlasgowExts `thenRn` \ glaExts -> + = doptM Opt_GlasgowExts `thenM` \ glaExts -> if glaExts - then rnPat pat `thenRn` \ (pat', fvs1) -> - rnHsTypeFVs doc ty `thenRn` \ (ty', fvs2) -> - returnRn (SigPatIn pat' ty', fvs1 `plusFV` fvs2) + then rnPat pat `thenM` \ (pat', fvs1) -> + rnHsTypeFVs doc ty `thenM` \ (ty', fvs2) -> + returnM (SigPatIn pat' ty', fvs1 `plusFV` fvs2) - else addErrRn (patSigErr ty) `thenRn_` + else addErr (patSigErr ty) `thenM_` rnPat pat where - doc = text "a pattern type-signature" + doc = text "In a pattern type-signature" -rnPat (LitPatIn s@(HsString _)) - = returnRn (LitPatIn s, unitFV eqStringName) +rnPat (LitPat s@(HsString _)) + = returnM (LitPat s, unitFV eqStringName) -rnPat (LitPatIn lit) - = litFVs lit `thenRn` \ fvs -> - returnRn (LitPatIn lit, fvs) +rnPat (LitPat lit) + = litFVs lit `thenM` \ fvs -> + returnM (LitPat lit, fvs) rnPat (NPatIn lit mb_neg) - = rnOverLit lit `thenRn` \ (lit', fvs1) -> + = rnOverLit lit `thenM` \ (lit', fvs1) -> (case mb_neg of - Nothing -> returnRn (Nothing, emptyFVs) - Just _ -> lookupSyntaxName negateName `thenRn` \ (neg, fvs) -> - returnRn (Just neg, fvs) - ) `thenRn` \ (mb_neg', fvs2) -> - returnRn (NPatIn lit' mb_neg', + Nothing -> returnM (Nothing, emptyFVs) + Just _ -> lookupSyntaxName negateName `thenM` \ (neg, fvs) -> + returnM (Just neg, fvs) + ) `thenM` \ (mb_neg', fvs2) -> + returnM (NPatIn lit' mb_neg', fvs1 `plusFV` fvs2 `addOneFV` eqClassName) -- Needed to find equality on pattern rnPat (NPlusKPatIn name lit _) - = rnOverLit lit `thenRn` \ (lit', fvs1) -> - lookupBndrRn name `thenRn` \ name' -> - lookupSyntaxName minusName `thenRn` \ (minus, fvs2) -> - returnRn (NPlusKPatIn name' lit' minus, + = rnOverLit lit `thenM` \ (lit', fvs1) -> + lookupBndrRn name `thenM` \ name' -> + lookupSyntaxName minusName `thenM` \ (minus, fvs2) -> + returnM (NPlusKPatIn name' lit' minus, fvs1 `plusFV` fvs2 `addOneFV` ordClassName) -rnPat (LazyPatIn pat) - = rnPat pat `thenRn` \ (pat', fvs) -> - returnRn (LazyPatIn pat', fvs) +rnPat (LazyPat pat) + = rnPat pat `thenM` \ (pat', fvs) -> + returnM (LazyPat pat', fvs) -rnPat (AsPatIn name pat) - = rnPat pat `thenRn` \ (pat', fvs) -> - lookupBndrRn name `thenRn` \ vname -> - returnRn (AsPatIn vname pat', fvs) +rnPat (AsPat name pat) + = rnPat pat `thenM` \ (pat', fvs) -> + lookupBndrRn name `thenM` \ vname -> + returnM (AsPat vname pat', fvs) -rnPat (ConPatIn con pats) - = lookupOccRn con `thenRn` \ con' -> - mapFvRn rnPat pats `thenRn` \ (patslist, fvs) -> - returnRn (ConPatIn con' patslist, fvs `addOneFV` con') +rnPat (ConPatIn con stuff) = rnConPat con stuff -rnPat (ConOpPatIn pat1 con _ pat2) - = rnPat pat1 `thenRn` \ (pat1', fvs1) -> - lookupOccRn con `thenRn` \ con' -> - rnPat pat2 `thenRn` \ (pat2', fvs2) -> - getModeRn `thenRn` \ mode -> - -- See comments with rnExpr (OpApp ...) - (if isInterfaceMode mode - then returnRn (ConOpPatIn pat1' con' defaultFixity pat2') - else lookupFixityRn con' `thenRn` \ fixity -> - mkConOpPatRn pat1' con' fixity pat2' - ) `thenRn` \ pat' -> - returnRn (pat', fvs1 `plusFV` fvs2 `addOneFV` con') - -rnPat (ParPatIn pat) - = rnPat pat `thenRn` \ (pat', fvs) -> - returnRn (ParPatIn pat', fvs) - -rnPat (ListPatIn pats) - = mapFvRn rnPat pats `thenRn` \ (patslist, fvs) -> - returnRn (ListPatIn patslist, fvs `addOneFV` listTyCon_name) - -rnPat (PArrPatIn pats) - = mapFvRn rnPat pats `thenRn` \ (patslist, fvs) -> - returnRn (PArrPatIn patslist, +rnPat (ParPat pat) + = rnPat pat `thenM` \ (pat', fvs) -> + returnM (ParPat pat', fvs) + +rnPat (ListPat pats _) + = mapFvRn rnPat pats `thenM` \ (patslist, fvs) -> + returnM (ListPat patslist placeHolderType, fvs `addOneFV` listTyCon_name) + +rnPat (PArrPat pats _) + = mapFvRn rnPat pats `thenM` \ (patslist, fvs) -> + returnM (PArrPat patslist placeHolderType, fvs `plusFV` implicit_fvs `addOneFV` parrTyCon_name) where implicit_fvs = mkFVs [lengthPName, indexPName] -rnPat (TuplePatIn pats boxed) - = mapFvRn rnPat pats `thenRn` \ (patslist, fvs) -> - returnRn (TuplePatIn patslist boxed, fvs `addOneFV` tycon_name) +rnPat (TuplePat pats boxed) + = mapFvRn rnPat pats `thenM` \ (patslist, fvs) -> + returnM (TuplePat patslist boxed, fvs `addOneFV` tycon_name) where tycon_name = tupleTyCon_name boxed (length pats) -rnPat (RecPatIn con rpats) - = lookupOccRn con `thenRn` \ con' -> - rnRpats rpats `thenRn` \ (rpats', fvs) -> - returnRn (RecPatIn con' rpats', fvs `addOneFV` con') +rnPat (TypePat name) = + rnHsTypeFVs (text "In a type pattern") name `thenM` \ (name', fvs) -> + returnM (TypePat name', fvs) + +------------------------------ +rnConPat con (PrefixCon pats) + = lookupOccRn con `thenM` \ con' -> + mapFvRn rnPat pats `thenM` \ (pats', fvs) -> + returnM (ConPatIn con' (PrefixCon pats'), fvs `addOneFV` con') -rnPat (TypePatIn name) - = rnHsTypeFVs (text "type pattern") name `thenRn` \ (name', fvs) -> - returnRn (TypePatIn name', fvs) +rnConPat con (RecCon rpats) + = lookupOccRn con `thenM` \ con' -> + rnRpats rpats `thenM` \ (rpats', fvs) -> + returnM (ConPatIn con' (RecCon rpats'), fvs `addOneFV` con') + +rnConPat con (InfixCon pat1 pat2) + = lookupOccRn con `thenM` \ con' -> + rnPat pat1 `thenM` \ (pat1', fvs1) -> + rnPat pat2 `thenM` \ (pat2', fvs2) -> + + getModeRn `thenM` \ mode -> + -- See comments with rnExpr (OpApp ...) + (if isInterfaceMode mode + then returnM (ConPatIn con' (InfixCon pat1' pat2')) + else lookupFixityRn con' `thenM` \ fixity -> + mkConOpPatRn con' fixity pat1' pat2' + ) `thenM` \ pat' -> + returnM (pat', fvs1 `plusFV` fvs2 `addOneFV` con') \end{code} + ************************************************************************ * * \subsection{Match} @@ -176,10 +180,10 @@ rnPat (TypePatIn name) ************************************************************************ \begin{code} -rnMatch :: HsMatchContext RdrName -> RdrNameMatch -> RnMS (RenamedMatch, FreeVars) +rnMatch :: HsMatchContext RdrName -> RdrNameMatch -> RnM (RenamedMatch, FreeVars) rnMatch ctxt match@(Match pats maybe_rhs_sig grhss) - = pushSrcLocRn (getMatchLoc match) $ + = addSrcLoc (getMatchLoc match) $ -- Bind pattern-bound type variables let @@ -197,25 +201,25 @@ rnMatch ctxt match@(Match pats maybe_rhs_sig grhss) -- f x x = 1 bindLocalsFVRn doc_pat (collectPatsBinders pats) $ \ new_binders -> - mapFvRn rnPat pats `thenRn` \ (pats', pat_fvs) -> - rnGRHSs grhss `thenRn` \ (grhss', grhss_fvs) -> - doptRn Opt_GlasgowExts `thenRn` \ opt_GlasgowExts -> + mapFvRn rnPat pats `thenM` \ (pats', pat_fvs) -> + rnGRHSs grhss `thenM` \ (grhss', grhss_fvs) -> + doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts -> (case maybe_rhs_sig of - Nothing -> returnRn (Nothing, emptyFVs) - Just ty | opt_GlasgowExts -> rnHsTypeFVs doc_sig ty `thenRn` \ (ty', ty_fvs) -> - returnRn (Just ty', ty_fvs) - | otherwise -> addErrRn (patSigErr ty) `thenRn_` - returnRn (Nothing, emptyFVs) - ) `thenRn` \ (maybe_rhs_sig', ty_fvs) -> + Nothing -> returnM (Nothing, emptyFVs) + Just ty | opt_GlasgowExts -> rnHsTypeFVs doc_sig ty `thenM` \ (ty', ty_fvs) -> + returnM (Just ty', ty_fvs) + | otherwise -> addErr (patSigErr ty) `thenM_` + returnM (Nothing, emptyFVs) + ) `thenM` \ (maybe_rhs_sig', ty_fvs) -> let binder_set = mkNameSet new_binders unused_binders = nameSetToList (binder_set `minusNameSet` grhss_fvs) all_fvs = grhss_fvs `plusFV` pat_fvs `plusFV` ty_fvs in - warnUnusedMatches unused_binders `thenRn_` + warnUnusedMatches unused_binders `thenM_` - returnRn (Match pats' maybe_rhs_sig' grhss', all_fvs) + returnM (Match pats' maybe_rhs_sig' grhss', all_fvs) -- The bindLocals and bindTyVars will remove the bound FVs \end{code} @@ -227,24 +231,24 @@ rnMatch ctxt match@(Match pats maybe_rhs_sig grhss) %************************************************************************ \begin{code} -rnGRHSs :: RdrNameGRHSs -> RnMS (RenamedGRHSs, FreeVars) +rnGRHSs :: RdrNameGRHSs -> RnM (RenamedGRHSs, FreeVars) rnGRHSs (GRHSs grhss binds _) = rnBinds binds $ \ binds' -> - mapFvRn rnGRHS grhss `thenRn` \ (grhss', fvGRHSs) -> - returnRn (GRHSs grhss' binds' placeHolderType, fvGRHSs) + mapFvRn rnGRHS grhss `thenM` \ (grhss', fvGRHSs) -> + returnM (GRHSs grhss' binds' placeHolderType, fvGRHSs) rnGRHS (GRHS guarded locn) - = doptRn Opt_GlasgowExts `thenRn` \ opt_GlasgowExts -> - pushSrcLocRn locn $ + = doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts -> + addSrcLoc locn $ (if not (opt_GlasgowExts || is_standard_guard guarded) then - addWarnRn (nonStdGuardErr guarded) + addWarn (nonStdGuardErr guarded) else - returnRn () - ) `thenRn_` + returnM () + ) `thenM_` - rnStmts guarded `thenRn` \ ((_, guarded'), fvs) -> - returnRn (GRHS guarded' locn, fvs) + rnStmts guarded `thenM` \ ((_, guarded'), fvs) -> + returnM (GRHS guarded' locn, fvs) where -- Standard Haskell 1.4 guards are just a single boolean -- expression, rather than a list of qualifiers as in the @@ -261,20 +265,20 @@ rnGRHS (GRHS guarded locn) %************************************************************************ \begin{code} -rnExprs :: [RdrNameHsExpr] -> RnMS ([RenamedHsExpr], FreeVars) +rnExprs :: [RdrNameHsExpr] -> RnM ([RenamedHsExpr], FreeVars) rnExprs ls = rnExprs' ls emptyUniqSet where - rnExprs' [] acc = returnRn ([], acc) + rnExprs' [] acc = returnM ([], acc) rnExprs' (expr:exprs) acc - = rnExpr expr `thenRn` \ (expr', fvExpr) -> + = rnExpr expr `thenM` \ (expr', fvExpr) -> -- Now we do a "seq" on the free vars because typically it's small -- or empty, especially in very long lists of constants let acc' = acc `plusFV` fvExpr in - (grubby_seqNameSet acc' rnExprs') exprs acc' `thenRn` \ (exprs', fvExprs) -> - returnRn (expr':exprs', fvExprs) + (grubby_seqNameSet acc' rnExprs') exprs acc' `thenM` \ (exprs', fvExprs) -> + returnM (expr':exprs', fvExprs) -- Grubby little function to do "seq" on namesets; replace by proper seq when GHC can do seq grubby_seqNameSet ns result | isNullUFM ns = result @@ -284,216 +288,227 @@ grubby_seqNameSet ns result | isNullUFM ns = result Variables. We look up the variable and return the resulting name. \begin{code} -rnExpr :: RdrNameHsExpr -> RnMS (RenamedHsExpr, FreeVars) +rnExpr :: RdrNameHsExpr -> RnM (RenamedHsExpr, FreeVars) rnExpr (HsVar v) - = lookupOccRn v `thenRn` \ name -> + = lookupOccRn v `thenM` \ name -> if name `hasKey` assertIdKey then -- We expand it to (GHCerr.assert__ location) mkAssertExpr else -- The normal case - returnRn (HsVar name, unitFV name) + returnM (HsVar name, unitFV name) rnExpr (HsIPVar v) - = newIPName v `thenRn` \ name -> + = newIPName v `thenM` \ name -> let fvs = case name of Linear _ -> mkFVs [splitName, fstName, sndName] Dupable _ -> emptyFVs in - returnRn (HsIPVar name, fvs) + returnM (HsIPVar name, fvs) rnExpr (HsLit lit) - = litFVs lit `thenRn` \ fvs -> - returnRn (HsLit lit, fvs) + = litFVs lit `thenM` \ fvs -> + returnM (HsLit lit, fvs) rnExpr (HsOverLit lit) - = rnOverLit lit `thenRn` \ (lit', fvs) -> - returnRn (HsOverLit lit', fvs) + = rnOverLit lit `thenM` \ (lit', fvs) -> + returnM (HsOverLit lit', fvs) rnExpr (HsLam match) - = rnMatch LambdaExpr match `thenRn` \ (match', fvMatch) -> - returnRn (HsLam match', fvMatch) + = rnMatch LambdaExpr match `thenM` \ (match', fvMatch) -> + returnM (HsLam match', fvMatch) rnExpr (HsApp fun arg) - = rnExpr fun `thenRn` \ (fun',fvFun) -> - rnExpr arg `thenRn` \ (arg',fvArg) -> - returnRn (HsApp fun' arg', fvFun `plusFV` fvArg) + = rnExpr fun `thenM` \ (fun',fvFun) -> + rnExpr arg `thenM` \ (arg',fvArg) -> + returnM (HsApp fun' arg', fvFun `plusFV` fvArg) rnExpr (OpApp e1 op _ e2) - = rnExpr e1 `thenRn` \ (e1', fv_e1) -> - rnExpr e2 `thenRn` \ (e2', fv_e2) -> - rnExpr op `thenRn` \ (op'@(HsVar op_name), fv_op) -> + = rnExpr e1 `thenM` \ (e1', fv_e1) -> + rnExpr e2 `thenM` \ (e2', fv_e2) -> + rnExpr op `thenM` \ (op'@(HsVar op_name), fv_op) -> -- Deal with fixity -- When renaming code synthesised from "deriving" declarations -- we're in Interface mode, and we should ignore fixity; assume -- that the deriving code generator got the association correct -- Don't even look up the fixity when in interface mode - getModeRn `thenRn` \ mode -> + getModeRn `thenM` \ mode -> (if isInterfaceMode mode - then returnRn (OpApp e1' op' defaultFixity e2') - else lookupFixityRn op_name `thenRn` \ fixity -> + then returnM (OpApp e1' op' defaultFixity e2') + else lookupFixityRn op_name `thenM` \ fixity -> mkOpAppRn e1' op' fixity e2' - ) `thenRn` \ final_e -> + ) `thenM` \ final_e -> - returnRn (final_e, + returnM (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) rnExpr (NegApp e _) - = rnExpr e `thenRn` \ (e', fv_e) -> - lookupSyntaxName negateName `thenRn` \ (neg_name, fv_neg) -> - mkNegAppRn e' neg_name `thenRn` \ final_e -> - returnRn (final_e, fv_e `plusFV` fv_neg) + = rnExpr e `thenM` \ (e', fv_e) -> + lookupSyntaxName negateName `thenM` \ (neg_name, fv_neg) -> + mkNegAppRn e' neg_name `thenM` \ final_e -> + returnM (final_e, fv_e `plusFV` fv_neg) rnExpr (HsPar e) - = rnExpr e `thenRn` \ (e', fvs_e) -> - returnRn (HsPar e', fvs_e) + = rnExpr e `thenM` \ (e', fvs_e) -> + returnM (HsPar e', fvs_e) + +-- Template Haskell extensions +rnExpr (HsBracket br_body) + = checkGHCI (thErr "bracket") `thenM_` + rnBracket br_body `thenM` \ (body', fvs_e) -> + returnM (HsBracket body', fvs_e `addOneFV` qTyConName) + -- We use the Q tycon as a proxy to haul in all the smart + -- constructors; see the hack in RnIfaces + +rnExpr (HsSplice n e) + = checkGHCI (thErr "splice") `thenM_` + getSrcLocM `thenM` \ loc -> + newLocalsRn [(n,loc)] `thenM` \ [n'] -> + rnExpr e `thenM` \ (e', fvs_e) -> + returnM (HsSplice n' e', fvs_e) rnExpr section@(SectionL expr op) - = rnExpr expr `thenRn` \ (expr', fvs_expr) -> - rnExpr op `thenRn` \ (op', fvs_op) -> - checkSectionPrec InfixL section op' expr' `thenRn_` - returnRn (SectionL expr' op', fvs_op `plusFV` fvs_expr) + = rnExpr expr `thenM` \ (expr', fvs_expr) -> + rnExpr op `thenM` \ (op', fvs_op) -> + checkSectionPrec InfixL section op' expr' `thenM_` + returnM (SectionL expr' op', fvs_op `plusFV` fvs_expr) rnExpr section@(SectionR op expr) - = rnExpr op `thenRn` \ (op', fvs_op) -> - rnExpr expr `thenRn` \ (expr', fvs_expr) -> - checkSectionPrec InfixR section op' expr' `thenRn_` - returnRn (SectionR op' expr', fvs_op `plusFV` fvs_expr) + = rnExpr op `thenM` \ (op', fvs_op) -> + rnExpr expr `thenM` \ (expr', fvs_expr) -> + checkSectionPrec InfixR section op' expr' `thenM_` + returnM (SectionR op' expr', fvs_op `plusFV` fvs_expr) rnExpr (HsCCall fun args may_gc is_casm _) -- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls - = lookupOrigNames [] `thenRn` \ implicit_fvs -> - rnExprs args `thenRn` \ (args', fvs_args) -> - returnRn (HsCCall fun args' may_gc is_casm placeHolderType, + = rnExprs args `thenM` \ (args', fvs_args) -> + returnM (HsCCall fun args' may_gc is_casm placeHolderType, fvs_args `plusFV` mkFVs [cCallableClassName, cReturnableClassName, ioDataConName]) rnExpr (HsSCC lbl expr) - = rnExpr expr `thenRn` \ (expr', fvs_expr) -> - returnRn (HsSCC lbl expr', fvs_expr) + = rnExpr expr `thenM` \ (expr', fvs_expr) -> + returnM (HsSCC lbl expr', fvs_expr) rnExpr (HsCase expr ms src_loc) - = pushSrcLocRn src_loc $ - rnExpr expr `thenRn` \ (new_expr, e_fvs) -> - mapFvRn (rnMatch CaseAlt) ms `thenRn` \ (new_ms, ms_fvs) -> - returnRn (HsCase new_expr new_ms src_loc, e_fvs `plusFV` ms_fvs) + = addSrcLoc src_loc $ + rnExpr expr `thenM` \ (new_expr, e_fvs) -> + mapFvRn (rnMatch CaseAlt) ms `thenM` \ (new_ms, ms_fvs) -> + returnM (HsCase new_expr new_ms src_loc, e_fvs `plusFV` ms_fvs) rnExpr (HsLet binds expr) = rnBinds binds $ \ binds' -> - rnExpr expr `thenRn` \ (expr',fvExpr) -> - returnRn (HsLet binds' expr', fvExpr) + rnExpr expr `thenM` \ (expr',fvExpr) -> + returnM (HsLet binds' expr', fvExpr) rnExpr (HsWith expr binds is_with) - = warnCheckRn (not is_with) withWarning `thenRn_` - rnExpr expr `thenRn` \ (expr',fvExpr) -> - rnIPBinds binds `thenRn` \ (binds',fvBinds) -> - returnRn (HsWith expr' binds' is_with, fvExpr `plusFV` fvBinds) + = warnIf is_with withWarning `thenM_` + rnExpr expr `thenM` \ (expr',fvExpr) -> + rnIPBinds binds `thenM` \ (binds',fvBinds) -> + returnM (HsWith expr' binds' is_with, fvExpr `plusFV` fvBinds) rnExpr e@(HsDo do_or_lc stmts _ ty src_loc) - = pushSrcLocRn src_loc $ - rnStmts stmts `thenRn` \ ((_, stmts'), fvs) -> + = addSrcLoc src_loc $ + rnStmts stmts `thenM` \ ((_, stmts'), fvs) -> -- Check the statement list ends in an expression case last stmts' of { - ResultStmt _ _ -> returnRn () ; - _ -> addErrRn (doStmtListErr e) - } `thenRn_` + ResultStmt _ _ -> returnM () ; + _ -> addErr (doStmtListErr e) + } `thenM_` -- Generate the rebindable syntax for the monad (case do_or_lc of - DoExpr -> mapAndUnzipRn lookupSyntaxName monadNames - other -> returnRn ([], []) - ) `thenRn` \ (monad_names', monad_fvs) -> + DoExpr -> mapAndUnzipM lookupSyntaxName monadNames + other -> returnM ([], []) + ) `thenM` \ (monad_names', monad_fvs) -> - returnRn (HsDo do_or_lc stmts' monad_names' placeHolderType src_loc, + returnM (HsDo do_or_lc stmts' monad_names' placeHolderType src_loc, fvs `plusFV` implicit_fvs `plusFV` plusFVs monad_fvs) where implicit_fvs = case do_or_lc of PArrComp -> mkFVs [replicatePName, mapPName, filterPName, - falseDataConName, trueDataConName, crossPName, - zipPName] + crossPName, zipPName] ListComp -> mkFVs [foldrName, buildName] - other -> emptyFVs - -- monadClassName pulls in the standard names - -- Monad stuff should not be necessary for a list comprehension - -- but the typechecker looks up the bind and return Ids anyway - -- Oh well. + DoExpr -> emptyFVs rnExpr (ExplicitList _ exps) - = rnExprs exps `thenRn` \ (exps', fvs) -> - returnRn (ExplicitList placeHolderType exps', fvs `addOneFV` listTyCon_name) + = rnExprs exps `thenM` \ (exps', fvs) -> + returnM (ExplicitList placeHolderType exps', fvs `addOneFV` listTyCon_name) rnExpr (ExplicitPArr _ exps) - = rnExprs exps `thenRn` \ (exps', fvs) -> - returnRn (ExplicitPArr placeHolderType exps', + = rnExprs exps `thenM` \ (exps', fvs) -> + returnM (ExplicitPArr placeHolderType exps', fvs `addOneFV` toPName `addOneFV` parrTyCon_name) rnExpr (ExplicitTuple exps boxity) - = rnExprs exps `thenRn` \ (exps', fvs) -> - returnRn (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name) + = rnExprs exps `thenM` \ (exps', fvs) -> + returnM (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name) where tycon_name = tupleTyCon_name boxity (length exps) rnExpr (RecordCon con_id rbinds) - = lookupOccRn con_id `thenRn` \ conname -> - rnRbinds "construction" rbinds `thenRn` \ (rbinds', fvRbinds) -> - returnRn (RecordCon conname rbinds', fvRbinds `addOneFV` conname) + = lookupOccRn con_id `thenM` \ conname -> + rnRbinds "construction" rbinds `thenM` \ (rbinds', fvRbinds) -> + returnM (RecordCon conname rbinds', fvRbinds `addOneFV` conname) rnExpr (RecordUpd expr rbinds) - = rnExpr expr `thenRn` \ (expr', fvExpr) -> - rnRbinds "update" rbinds `thenRn` \ (rbinds', fvRbinds) -> - returnRn (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds) + = rnExpr expr `thenM` \ (expr', fvExpr) -> + rnRbinds "update" rbinds `thenM` \ (rbinds', fvRbinds) -> + returnM (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds) rnExpr (ExprWithTySig expr pty) - = rnExpr expr `thenRn` \ (expr', fvExpr) -> - rnHsTypeFVs (text "an expression type signature") pty `thenRn` \ (pty', fvTy) -> - returnRn (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) + = rnExpr expr `thenM` \ (expr', fvExpr) -> + rnHsTypeFVs doc pty `thenM` \ (pty', fvTy) -> + returnM (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) + where + doc = text "In an expression type signature" rnExpr (HsIf p b1 b2 src_loc) - = pushSrcLocRn src_loc $ - rnExpr p `thenRn` \ (p', fvP) -> - rnExpr b1 `thenRn` \ (b1', fvB1) -> - rnExpr b2 `thenRn` \ (b2', fvB2) -> - returnRn (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2]) + = addSrcLoc src_loc $ + rnExpr p `thenM` \ (p', fvP) -> + rnExpr b1 `thenM` \ (b1', fvB1) -> + rnExpr b2 `thenM` \ (b2', fvB2) -> + returnM (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2]) rnExpr (HsType a) - = rnHsTypeFVs doc a `thenRn` \ (t, fvT) -> - returnRn (HsType t, fvT) + = rnHsTypeFVs doc a `thenM` \ (t, fvT) -> + returnM (HsType t, fvT) where - doc = text "in a type argument" + doc = text "In a type argument" rnExpr (ArithSeqIn seq) - = rn_seq seq `thenRn` \ (new_seq, fvs) -> - returnRn (ArithSeqIn new_seq, fvs `addOneFV` enumClassName) + = rn_seq seq `thenM` \ (new_seq, fvs) -> + returnM (ArithSeqIn new_seq, fvs `addOneFV` enumClassName) where rn_seq (From expr) - = rnExpr expr `thenRn` \ (expr', fvExpr) -> - returnRn (From expr', fvExpr) + = rnExpr expr `thenM` \ (expr', fvExpr) -> + returnM (From expr', fvExpr) rn_seq (FromThen expr1 expr2) - = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) -> - rnExpr expr2 `thenRn` \ (expr2', fvExpr2) -> - returnRn (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2) + = rnExpr expr1 `thenM` \ (expr1', fvExpr1) -> + rnExpr expr2 `thenM` \ (expr2', fvExpr2) -> + returnM (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2) rn_seq (FromTo expr1 expr2) - = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) -> - rnExpr expr2 `thenRn` \ (expr2', fvExpr2) -> - returnRn (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) + = rnExpr expr1 `thenM` \ (expr1', fvExpr1) -> + rnExpr expr2 `thenM` \ (expr2', fvExpr2) -> + returnM (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) rn_seq (FromThenTo expr1 expr2 expr3) - = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) -> - rnExpr expr2 `thenRn` \ (expr2', fvExpr2) -> - rnExpr expr3 `thenRn` \ (expr3', fvExpr3) -> - returnRn (FromThenTo expr1' expr2' expr3', + = rnExpr expr1 `thenM` \ (expr1', fvExpr1) -> + rnExpr expr2 `thenM` \ (expr2', fvExpr2) -> + rnExpr expr3 `thenM` \ (expr3', fvExpr3) -> + returnM (FromThenTo expr1' expr2' expr3', plusFVs [fvExpr1, fvExpr2, fvExpr3]) rnExpr (PArrSeqIn seq) - = rn_seq seq `thenRn` \ (new_seq, fvs) -> - returnRn (PArrSeqIn new_seq, + = rn_seq seq `thenM` \ (new_seq, fvs) -> + returnM (PArrSeqIn new_seq, fvs `plusFV` mkFVs [enumFromToPName, enumFromThenToPName]) where @@ -503,14 +518,14 @@ rnExpr (PArrSeqIn seq) rn_seq (FromThen _ _) = panic "RnExpr.rnExpr: Infinite parallel array!" rn_seq (FromTo expr1 expr2) - = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) -> - rnExpr expr2 `thenRn` \ (expr2', fvExpr2) -> - returnRn (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) + = rnExpr expr1 `thenM` \ (expr1', fvExpr1) -> + rnExpr expr2 `thenM` \ (expr2', fvExpr2) -> + returnM (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) rn_seq (FromThenTo expr1 expr2 expr3) - = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) -> - rnExpr expr2 `thenRn` \ (expr2', fvExpr2) -> - rnExpr expr3 `thenRn` \ (expr3', fvExpr3) -> - returnRn (FromThenTo expr1' expr2' expr3', + = rnExpr expr1 `thenM` \ (expr1', fvExpr1) -> + rnExpr expr2 `thenM` \ (expr2', fvExpr2) -> + rnExpr expr3 `thenM` \ (expr3', fvExpr3) -> + returnM (FromThenTo expr1' expr2' expr3', plusFVs [fvExpr1, fvExpr2, fvExpr3]) \end{code} @@ -519,14 +534,14 @@ Since all the symbols are reservedops we can simply reject them. We return a (bogus) EWildPat in each case. \begin{code} -rnExpr e@EWildPat = addErrRn (patSynErr e) `thenRn_` - returnRn (EWildPat, emptyFVs) +rnExpr e@EWildPat = addErr (patSynErr e) `thenM_` + returnM (EWildPat, emptyFVs) -rnExpr e@(EAsPat _ _) = addErrRn (patSynErr e) `thenRn_` - returnRn (EWildPat, emptyFVs) +rnExpr e@(EAsPat _ _) = addErr (patSynErr e) `thenM_` + returnM (EWildPat, emptyFVs) -rnExpr e@(ELazyPat _) = addErrRn (patSynErr e) `thenRn_` - returnRn (EWildPat, emptyFVs) +rnExpr e@(ELazyPat _) = addErr (patSynErr e) `thenM_` + returnM (EWildPat, emptyFVs) \end{code} @@ -539,32 +554,32 @@ rnExpr e@(ELazyPat _) = addErrRn (patSynErr e) `thenRn_` \begin{code} rnRbinds str rbinds - = mapRn_ field_dup_err dup_fields `thenRn_` - mapFvRn rn_rbind rbinds `thenRn` \ (rbinds', fvRbind) -> - returnRn (rbinds', fvRbind) + = mappM_ field_dup_err dup_fields `thenM_` + mapFvRn rn_rbind rbinds `thenM` \ (rbinds', fvRbind) -> + returnM (rbinds', fvRbind) where - (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rbinds ] + (_, dup_fields) = removeDups compare [ f | (f,_) <- rbinds ] - field_dup_err dups = addErrRn (dupFieldErr str dups) + field_dup_err dups = addErr (dupFieldErr str dups) - rn_rbind (field, expr, pun) - = lookupGlobalOccRn field `thenRn` \ fieldname -> - rnExpr expr `thenRn` \ (expr', fvExpr) -> - returnRn ((fieldname, expr', pun), fvExpr `addOneFV` fieldname) + rn_rbind (field, expr) + = lookupGlobalOccRn field `thenM` \ fieldname -> + rnExpr expr `thenM` \ (expr', fvExpr) -> + returnM ((fieldname, expr'), fvExpr `addOneFV` fieldname) rnRpats rpats - = mapRn_ field_dup_err dup_fields `thenRn_` - mapFvRn rn_rpat rpats `thenRn` \ (rpats', fvs) -> - returnRn (rpats', fvs) + = mappM_ field_dup_err dup_fields `thenM_` + mapFvRn rn_rpat rpats `thenM` \ (rpats', fvs) -> + returnM (rpats', fvs) where - (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rpats ] + (_, dup_fields) = removeDups compare [ f | (f,_) <- rpats ] - field_dup_err dups = addErrRn (dupFieldErr "pattern" dups) + field_dup_err dups = addErr (dupFieldErr "pattern" dups) - rn_rpat (field, pat, pun) - = lookupGlobalOccRn field `thenRn` \ fieldname -> - rnPat pat `thenRn` \ (pat', fvs) -> - returnRn ((fieldname, pat', pun), fvs `addOneFV` fieldname) + rn_rpat (field, pat) + = lookupGlobalOccRn field `thenM` \ fieldname -> + rnPat pat `thenM` \ (pat', fvs) -> + returnM ((fieldname, pat'), fvs `addOneFV` fieldname) \end{code} %************************************************************************ @@ -574,13 +589,34 @@ rnRpats rpats %************************************************************************ \begin{code} -rnIPBinds [] = returnRn ([], emptyFVs) +rnIPBinds [] = returnM ([], emptyFVs) rnIPBinds ((n, expr) : binds) - = newIPName n `thenRn` \ name -> - rnExpr expr `thenRn` \ (expr',fvExpr) -> - rnIPBinds binds `thenRn` \ (binds',fvBinds) -> - returnRn ((name, expr') : binds', fvExpr `plusFV` fvBinds) + = newIPName n `thenM` \ name -> + rnExpr expr `thenM` \ (expr',fvExpr) -> + rnIPBinds binds `thenM` \ (binds',fvBinds) -> + returnM ((name, expr') : binds', fvExpr `plusFV` fvBinds) + +\end{code} + +%************************************************************************ +%* * + Template Haskell brackets +%* * +%************************************************************************ +\begin{code} +rnBracket (ExpBr e) = rnExpr e `thenM` \ (e', fvs) -> + returnM (ExpBr e', fvs) +rnBracket (PatBr p) = rnPat p `thenM` \ (p', fvs) -> + returnM (PatBr p', fvs) +rnBracket (TypBr t) = rnHsTypeFVs doc t `thenM` \ (t', fvs) -> + returnM (TypBr t', fvs) + where + doc = ptext SLIT("In a Template-Haskell quoted type") +rnBracket (DecBr ds) = rnSrcDecls ds `thenM` \ (tcg_env, ds', fvs) -> + -- Discard the tcg_env; it contains the extended global RdrEnv + -- because there is no scope that these decls cover (yet!) + returnM (DecBr ds', fvs) \end{code} %************************************************************************ @@ -599,66 +635,66 @@ Quals. \begin{code} rnStmts :: [RdrNameStmt] - -> RnMS (([Name], [RenamedStmt]), FreeVars) + -> RnM (([Name], [RenamedStmt]), FreeVars) rnStmts [] - = returnRn (([], []), emptyFVs) + = returnM (([], []), emptyFVs) rnStmts (stmt:stmts) - = getLocalNameEnv `thenRn` \ name_env -> + = getLocalRdrEnv `thenM` \ name_env -> rnStmt stmt $ \ stmt' -> - rnStmts stmts `thenRn` \ ((binders, stmts'), fvs) -> - returnRn ((binders, stmt' : stmts'), fvs) + rnStmts stmts `thenM` \ ((binders, stmts'), fvs) -> + returnM ((binders, stmt' : stmts'), fvs) rnStmt :: RdrNameStmt - -> (RenamedStmt -> RnMS (([Name], a), FreeVars)) - -> RnMS (([Name], a), FreeVars) + -> (RenamedStmt -> RnM (([Name], a), FreeVars)) + -> RnM (([Name], a), FreeVars) -- The thing list of names returned is the list returned by the -- thing_inside, plus the binders of the arguments stmt rnStmt (ParStmt stmtss) thing_inside - = mapFvRn rnStmts stmtss `thenRn` \ (bndrstmtss, fv_stmtss) -> + = mapFvRn rnStmts stmtss `thenM` \ (bndrstmtss, fv_stmtss) -> let binderss = map fst bndrstmtss checkBndrs all_bndrs bndrs - = checkRn (null (intersectBy eqOcc all_bndrs bndrs)) err `thenRn_` - returnRn (bndrs ++ all_bndrs) + = checkErr (null (intersectBy eqOcc all_bndrs bndrs)) err `thenM_` + returnM (bndrs ++ all_bndrs) eqOcc n1 n2 = nameOccName n1 == nameOccName n2 err = text "duplicate binding in parallel list comprehension" in - foldlRn checkBndrs [] binderss `thenRn` \ new_binders -> + foldlM checkBndrs [] binderss `thenM` \ new_binders -> bindLocalNamesFV new_binders $ - thing_inside (ParStmtOut bndrstmtss)`thenRn` \ ((rest_bndrs, result), fv_rest) -> - returnRn ((new_binders ++ rest_bndrs, result), fv_stmtss `plusFV` fv_rest) + thing_inside (ParStmtOut bndrstmtss)`thenM` \ ((rest_bndrs, result), fv_rest) -> + returnM ((new_binders ++ rest_bndrs, result), fv_stmtss `plusFV` fv_rest) rnStmt (BindStmt pat expr src_loc) thing_inside - = pushSrcLocRn src_loc $ - rnExpr expr `thenRn` \ (expr', fv_expr) -> + = addSrcLoc src_loc $ + rnExpr expr `thenM` \ (expr', fv_expr) -> bindPatSigTyVars (collectSigTysFromPat pat) $ bindLocalsFVRn doc (collectPatBinders pat) $ \ new_binders -> - rnPat pat `thenRn` \ (pat', fv_pat) -> - thing_inside (BindStmt pat' expr' src_loc) `thenRn` \ ((rest_binders, result), fvs) -> - returnRn ((new_binders ++ rest_binders, result), + rnPat pat `thenM` \ (pat', fv_pat) -> + thing_inside (BindStmt pat' expr' src_loc) `thenM` \ ((rest_binders, result), fvs) -> + returnM ((new_binders ++ rest_binders, result), fv_expr `plusFV` fvs `plusFV` fv_pat) where doc = text "In a pattern in 'do' binding" rnStmt (ExprStmt expr _ src_loc) thing_inside - = pushSrcLocRn src_loc $ - rnExpr expr `thenRn` \ (expr', fv_expr) -> - thing_inside (ExprStmt expr' placeHolderType src_loc) `thenRn` \ (result, fvs) -> - returnRn (result, fv_expr `plusFV` fvs) + = addSrcLoc src_loc $ + rnExpr expr `thenM` \ (expr', fv_expr) -> + thing_inside (ExprStmt expr' placeHolderType src_loc) `thenM` \ (result, fvs) -> + returnM (result, fv_expr `plusFV` fvs) rnStmt (ResultStmt expr src_loc) thing_inside - = pushSrcLocRn src_loc $ - rnExpr expr `thenRn` \ (expr', fv_expr) -> - thing_inside (ResultStmt expr' src_loc) `thenRn` \ (result, fvs) -> - returnRn (result, fv_expr `plusFV` fvs) + = addSrcLoc src_loc $ + rnExpr expr `thenM` \ (expr', fv_expr) -> + thing_inside (ResultStmt expr' src_loc) `thenM` \ (result, fvs) -> + returnM (result, fv_expr `plusFV` fvs) rnStmt (LetStmt binds) thing_inside = rnBinds binds $ \ binds' -> let new_binders = collectHsBinders binds' in - thing_inside (LetStmt binds') `thenRn` \ ((rest_binders, result), fvs) -> - returnRn ((new_binders ++ rest_binders, result), fvs ) + thing_inside (LetStmt binds') `thenM` \ ((rest_binders, result), fvs) -> + returnM ((new_binders ++ rest_binders, result), fvs ) \end{code} %************************************************************************ @@ -682,18 +718,18 @@ mkOpAppRn :: RenamedHsExpr -- Left operand; already rearranged -> RenamedHsExpr -> Fixity -- Operator and fixity -> RenamedHsExpr -- Right operand (not an OpApp, but might -- be a NegApp) - -> RnMS RenamedHsExpr + -> RnM RenamedHsExpr --------------------------- -- (e11 `op1` e12) `op2` e2 mkOpAppRn e1@(OpApp e11 op1 fix1 e12) op2 fix2 e2 | nofix_error - = addErrRn (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenRn_` - returnRn (OpApp e1 op2 fix2 e2) + = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_` + returnM (OpApp e1 op2 fix2 e2) | associate_right - = mkOpAppRn e12 op2 fix2 e2 `thenRn` \ new_e -> - returnRn (OpApp e11 op1 fix1 new_e) + = mkOpAppRn e12 op2 fix2 e2 `thenM` \ new_e -> + returnM (OpApp e11 op1 fix1 new_e) where (nofix_error, associate_right) = compareFixity fix1 fix2 @@ -701,12 +737,12 @@ mkOpAppRn e1@(OpApp e11 op1 fix1 e12) op2 fix2 e2 -- (- neg_arg) `op` e2 mkOpAppRn e1@(NegApp neg_arg neg_name) op2 fix2 e2 | nofix_error - = addErrRn (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2)) `thenRn_` - returnRn (OpApp e1 op2 fix2 e2) + = addErr (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2)) `thenM_` + returnM (OpApp e1 op2 fix2 e2) | associate_right - = mkOpAppRn neg_arg op2 fix2 e2 `thenRn` \ new_e -> - returnRn (NegApp new_e neg_name) + = mkOpAppRn neg_arg op2 fix2 e2 `thenM` \ new_e -> + returnM (NegApp new_e neg_name) where (nofix_error, associate_right) = compareFixity negateFixity fix2 @@ -714,8 +750,8 @@ mkOpAppRn e1@(NegApp neg_arg neg_name) op2 fix2 e2 -- e1 `op` - neg_arg mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg _) -- NegApp can occur on the right | not associate_right -- We *want* right association - = addErrRn (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) `thenRn_` - returnRn (OpApp e1 op1 fix1 e2) + = addErr (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) `thenM_` + returnM (OpApp e1 op1 fix1 e2) where (_, associate_right) = compareFixity fix1 negateFixity @@ -725,7 +761,7 @@ mkOpAppRn e1 op fix e2 -- Default case, no rearrangment = ASSERT2( right_op_ok fix e2, ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2 ) - returnRn (OpApp e1 op fix e2) + returnM (OpApp e1 op fix e2) -- Parser left-associates everything, but -- derived instances may have correctly-associated things to @@ -741,60 +777,62 @@ right_op_ok fix1 other mkNegAppRn neg_arg neg_name = #ifdef DEBUG - getModeRn `thenRn` \ mode -> + getModeRn `thenM` \ mode -> ASSERT( not_op_app mode neg_arg ) #endif - returnRn (NegApp neg_arg neg_name) + returnM (NegApp neg_arg neg_name) not_op_app SourceMode (OpApp _ _ _ _) = False not_op_app mode other = True \end{code} \begin{code} -mkConOpPatRn :: RenamedPat -> Name -> Fixity -> RenamedPat - -> RnMS RenamedPat +mkConOpPatRn :: Name -> Fixity -> RenamedPat -> RenamedPat + -> RnM RenamedPat -mkConOpPatRn p1@(ConOpPatIn p11 op1 fix1 p12) - op2 fix2 p2 - | nofix_error - = addErrRn (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenRn_` - returnRn (ConOpPatIn p1 op2 fix2 p2) - - | associate_right - = mkConOpPatRn p12 op2 fix2 p2 `thenRn` \ new_p -> - returnRn (ConOpPatIn p11 op1 fix1 new_p) - - where - (nofix_error, associate_right) = compareFixity fix1 fix2 +mkConOpPatRn op2 fix2 p1@(ConPatIn op1 (InfixCon p11 p12)) p2 + = lookupFixityRn op1 `thenM` \ fix1 -> + let + (nofix_error, associate_right) = compareFixity fix1 fix2 + in + if nofix_error then + addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_` + returnM (ConPatIn op2 (InfixCon p1 p2)) + else + if associate_right then + mkConOpPatRn op2 fix2 p12 p2 `thenM` \ new_p -> + returnM (ConPatIn op1 (InfixCon p11 new_p)) + else + returnM (ConPatIn op2 (InfixCon p1 p2)) -mkConOpPatRn p1 op fix p2 -- Default case, no rearrangment +mkConOpPatRn op fix p1 p2 -- Default case, no rearrangment = ASSERT( not_op_pat p2 ) - returnRn (ConOpPatIn p1 op fix p2) + returnM (ConPatIn op (InfixCon p1 p2)) -not_op_pat (ConOpPatIn _ _ _ _) = False -not_op_pat other = True +not_op_pat (ConPatIn _ (InfixCon _ _)) = False +not_op_pat other = True \end{code} \begin{code} -checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnMS () +checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnM () checkPrecMatch False fn match - = returnRn () + = returnM () checkPrecMatch True op (Match (p1:p2:_) _ _) -- True indicates an infix lhs - = getModeRn `thenRn` \ mode -> + = getModeRn `thenM` \ mode -> -- See comments with rnExpr (OpApp ...) if isInterfaceMode mode - then returnRn () - else checkPrec op p1 False `thenRn_` + then returnM () + else checkPrec op p1 False `thenM_` checkPrec op p2 True checkPrecMatch True op _ = panic "checkPrecMatch" -checkPrec op (ConOpPatIn _ op1 _ _) right - = lookupFixityRn op `thenRn` \ op_fix@(Fixity op_prec op_dir) -> - lookupFixityRn op1 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) -> +checkPrec op (ConPatIn op1 (InfixCon _ _)) right + = lookupFixityRn op `thenM` \ op_fix@(Fixity op_prec op_dir) -> + lookupFixityRn op1 `thenM` \ op1_fix@(Fixity op1_prec op1_dir) -> let inf_ok = op1_prec > op_prec || (op1_prec == op_prec && @@ -805,10 +843,10 @@ checkPrec op (ConOpPatIn _ op1 _ _) right info1 = (ppr_op op1, op1_fix) (infol, infor) = if right then (info, info1) else (info1, info) in - checkRn inf_ok (precParseErr infol infor) + checkErr inf_ok (precParseErr infol infor) checkPrec op pat right - = returnRn () + = returnM () -- Check precedence of (arg op) or (op arg) respectively -- If arg is itself an operator application, then either @@ -818,12 +856,12 @@ checkSectionPrec direction section op arg = case arg of OpApp _ op fix _ -> go_for_it (ppr_op op) fix NegApp _ _ -> go_for_it pp_prefix_minus negateFixity - other -> returnRn () + other -> returnM () where HsVar op_name = op go_for_it pp_arg_op arg_fix@(Fixity arg_prec assoc) - = lookupFixityRn op_name `thenRn` \ op_fix@(Fixity op_prec _) -> - checkRn (op_prec < arg_prec + = lookupFixityRn op_name `thenM` \ op_fix@(Fixity op_prec _) -> + checkErr (op_prec < arg_prec || op_prec == arg_prec && direction == assoc) (sectionPrecErr (ppr_op op_name, op_fix) (pp_arg_op, arg_fix) section) @@ -842,24 +880,24 @@ are made available. \begin{code} litFVs (HsChar c) - = checkRn (inCharRange c) (bogusCharError c) `thenRn_` - returnRn (unitFV charTyCon_name) - -litFVs (HsCharPrim c) = returnRn (unitFV (getName charPrimTyCon)) -litFVs (HsString s) = returnRn (mkFVs [listTyCon_name, charTyCon_name]) -litFVs (HsStringPrim s) = returnRn (unitFV (getName addrPrimTyCon)) -litFVs (HsInt i) = returnRn (unitFV (getName intTyCon)) -litFVs (HsIntPrim i) = returnRn (unitFV (getName intPrimTyCon)) -litFVs (HsFloatPrim f) = returnRn (unitFV (getName floatPrimTyCon)) -litFVs (HsDoublePrim d) = returnRn (unitFV (getName doublePrimTyCon)) -litFVs (HsLitLit l bogus_ty) = returnRn (unitFV cCallableClassName) + = checkErr (inCharRange c) (bogusCharError c) `thenM_` + returnM (unitFV charTyCon_name) + +litFVs (HsCharPrim c) = returnM (unitFV (getName charPrimTyCon)) +litFVs (HsString s) = returnM (mkFVs [listTyCon_name, charTyCon_name]) +litFVs (HsStringPrim s) = returnM (unitFV (getName addrPrimTyCon)) +litFVs (HsInt i) = returnM (unitFV (getName intTyCon)) +litFVs (HsIntPrim i) = returnM (unitFV (getName intPrimTyCon)) +litFVs (HsFloatPrim f) = returnM (unitFV (getName floatPrimTyCon)) +litFVs (HsDoublePrim d) = returnM (unitFV (getName doublePrimTyCon)) +litFVs (HsLitLit l bogus_ty) = returnM (unitFV cCallableClassName) litFVs lit = pprPanic "RnExpr.litFVs" (ppr lit) -- HsInteger and HsRat only appear -- in post-typechecker translations rnOverLit (HsIntegral i _) - = lookupSyntaxName fromIntegerName `thenRn` \ (from_integer_name, fvs) -> + = lookupSyntaxName fromIntegerName `thenM` \ (from_integer_name, fvs) -> if inIntRange i then - returnRn (HsIntegral i from_integer_name, fvs) + returnM (HsIntegral i from_integer_name, fvs) else let extra_fvs = mkFVs [plusIntegerName, timesIntegerName] -- Big integer literals are built, using + and *, @@ -868,10 +906,10 @@ rnOverLit (HsIntegral i _) -- they are used to construct the argument to fromInteger, -- which is the rebindable one.] in - returnRn (HsIntegral i from_integer_name, fvs `plusFV` extra_fvs) + returnM (HsIntegral i from_integer_name, fvs `plusFV` extra_fvs) rnOverLit (HsFractional i _) - = lookupSyntaxName fromRationalName `thenRn` \ (from_rat_name, fvs) -> + = lookupSyntaxName fromRationalName `thenM` \ (from_rat_name, fvs) -> let extra_fvs = mkFVs [ratioDataConName, plusIntegerName, timesIntegerName] -- We have to make sure that the Ratio type is imported with @@ -882,7 +920,7 @@ rnOverLit (HsFractional i _) -- The plus/times integer operations may be needed to construct the numerator -- and denominator (see DsUtils.mkIntegerLit) in - returnRn (HsFractional i from_rat_name, fvs `plusFV` extra_fvs) + returnM (HsFractional i from_rat_name, fvs `plusFV` extra_fvs) \end{code} %************************************************************************ @@ -892,30 +930,30 @@ rnOverLit (HsFractional i _) %************************************************************************ \begin{code} -mkAssertExpr :: RnMS (RenamedHsExpr, FreeVars) -mkAssertExpr = - lookupOrigName assertErr_RDR `thenRn` \ name -> - getSrcLocRn `thenRn` \ sloc -> +mkAssertExpr :: RnM (RenamedHsExpr, FreeVars) +mkAssertExpr + = getSrcLocM `thenM` \ sloc -> -- if we're ignoring asserts, return (\ _ e -> e) -- if not, return (assertError "src-loc") - if opt_IgnoreAsserts then - getUniqRn `thenRn` \ uniq -> - let - vname = mkSystemName uniq FSLIT("v") - expr = HsLam ignorePredMatch - loc = nameSrcLoc vname - ignorePredMatch = mkSimpleMatch [WildPatIn, VarPatIn vname] (HsVar vname) placeHolderType loc - in - returnRn (expr, unitFV name) - else - let - expr = - HsApp (HsVar name) + if opt_IgnoreAsserts then + newUnique `thenM` \ uniq -> + let + vname = mkSystemName uniq FSLIT("v") + expr = HsLam ignorePredMatch + loc = nameSrcLoc vname + ignorePredMatch = mkSimpleMatch [WildPat placeHolderType, VarPat vname] + (HsVar vname) placeHolderType loc + in + returnM (expr, emptyFVs) + else + let + expr = + HsApp (HsVar assertName) (HsLit (HsStringPrim (mkFastString (stringToUtf8 (showSDoc (ppr sloc)))))) - in - returnRn (expr, unitFV name) + in + returnM (expr, unitFV assertName) \end{code} %************************************************************************ @@ -946,6 +984,10 @@ patSynErr e = sep [ptext SLIT("Pattern syntax in expression context:"), nest 4 (ppr e)] +thErr what + = ptext SLIT("Template Haskell") <+> text what <+> + ptext SLIT("illegal in a stage-1 compiler") + doStmtListErr e = sep [ptext SLIT("`do' statements must end in expression:"), nest 4 (ppr e)] diff --git a/ghc/compiler/rename/RnHiFiles.hi-boot-5 b/ghc/compiler/rename/RnHiFiles.hi-boot-5 index da5dcc3c47..27817b05f6 100644 --- a/ghc/compiler/rename/RnHiFiles.hi-boot-5 +++ b/ghc/compiler/rename/RnHiFiles.hi-boot-5 @@ -1,3 +1,4 @@ __interface RnHiFiles 1 0 where __export RnHiFiles loadInterface; -1 loadInterface :: __forall [d] => Outputable.SDoc -> Module.ModuleName -> Module.WhereFrom -> RnMonad.RnM d HscTypes.ModIface; +1 loadInterface :: __forall [m] => Outputable.SDoc -> Module.ModuleName -> TcRnTypes.WhereFrom + -> TcRnTypes.TcRn m HscTypes.ModIface; diff --git a/ghc/compiler/rename/RnHiFiles.hi-boot-6 b/ghc/compiler/rename/RnHiFiles.hi-boot-6 index 2fe3df599f..2209be6fab 100644 --- a/ghc/compiler/rename/RnHiFiles.hi-boot-6 +++ b/ghc/compiler/rename/RnHiFiles.hi-boot-6 @@ -3,5 +3,5 @@ module RnHiFiles where loadInterface :: Outputable.SDoc -> Module.ModuleName - -> Module.WhereFrom - -> RnMonad.RnM d HscTypes.ModIface + -> TcRnTypes.WhereFrom + -> TcRnTypes.TcRn m HscTypes.ModIface diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs index bd414fb83c..931c5cf59e 100644 --- a/ghc/compiler/rename/RnHiFiles.lhs +++ b/ghc/compiler/rename/RnHiFiles.lhs @@ -5,11 +5,10 @@ \begin{code} module RnHiFiles ( - readIface, findAndReadIface, loadInterface, loadHomeInterface, - tryLoadInterface, loadOrphanModules, - loadExports, loadFixDecls, loadDeprecs, - - getTyClDeclBinders + readIface, loadInterface, loadHomeInterface, + loadOrphanModules, + loadOldIface, + ParsedIface(..) ) where #include "HsVersions.h" @@ -18,34 +17,45 @@ import DriverState ( v_GhcMode, isCompManagerMode ) import DriverUtil ( splitFilename ) import CmdLineOpts ( opt_IgnoreIfacePragmas ) import Parser ( parseIface ) -import HscTypes ( ModuleLocation(..), - ModIface(..), emptyModIface, +import HscTypes ( ModIface(..), emptyModIface, + ExternalPackageState(..), VersionInfo(..), ImportedModuleInfo, - lookupIfaceByModName, RdrExportItem, + lookupIfaceByModName, RdrExportItem, WhatsImported(..), ImportVersion, WhetherHasOrphans, IsBootInterface, - DeclsMap, GatedDecl, IfaceInsts, IfaceRules, - AvailInfo, GenAvailInfo(..), Avails, Deprecations(..) + DeclsMap, GatedDecl, IfaceInsts, IfaceRules, mkIfaceDecls, + AvailInfo, GenAvailInfo(..), ParsedIface(..), IfaceDeprecs, + Avails, availNames, availName, Deprecations(..) ) -import HsSyn ( TyClDecl(..), InstDecl(..), RuleDecl(..), - tyClDeclNames, tyClDeclSysNames, hsTyVarNames, - getHsInstHead, +import HsSyn ( TyClDecl(..), InstDecl(..), RuleDecl(..), ConDecl(..), + hsTyVarNames, splitHsInstDeclTy, tyClDeclName, tyClDeclNames ) import RdrHsSyn ( RdrNameTyClDecl, RdrNameInstDecl, RdrNameRuleDecl ) -import RnHsSyn ( extractHsTyNames_s ) -import BasicTypes ( Version ) +import RnHsSyn ( RenamedInstDecl, RenamedRuleDecl, RenamedTyClDecl, + extractHsTyNames_s ) +import BasicTypes ( Version, FixitySig(..), Fixity(..), FixityDirection(..) ) +import RnSource ( rnIfaceRuleDecl, rnTyClDecl, rnInstDecl ) import RnTypes ( rnHsType ) import RnEnv -import RnMonad +import TcRnMonad import PrelNames ( gHC_PRIM_Name, gHC_PRIM ) +import PrelInfo ( ghcPrimExports, cCallableClassDecl, cReturnableClassDecl, assertDecl ) import Name ( Name {-instance NamedThing-}, - nameModule, isInternalName - ) + nameModule, isInternalName ) import NameEnv import NameSet -import Module -import RdrName ( rdrNameOcc ) -import SrcLoc ( mkSrcLoc ) +import Id ( idName ) +import MkId ( seqId ) +import Packages ( preludePackage ) +import Module ( Module, ModuleName, ModLocation(ml_hi_file), + moduleName, isHomeModule, mkVanillaModule, + extendModuleEnv + ) +import RdrName ( RdrName, mkRdrUnqual, rdrNameOcc, nameRdrName ) +import OccName ( OccName, mkWorkerOcc, mkClassTyConOcc, mkClassDataConOcc, + mkSuperDictSelOcc, mkGenOcc1, mkGenOcc2 ) +import TyCon ( DataConDetails(..) ) +import SrcLoc ( noSrcLoc, mkSrcLoc ) import Maybes ( maybeToBool ) import StringBuffer ( hGetStringBuffer ) import FastString ( mkFastString ) @@ -56,17 +66,14 @@ import FiniteMap import ListSetOps ( minusList ) import Outputable import Bag -import BinIface ( {- just instances -} ) -import qualified Binary +import BinIface ( readBinIface ) import Panic import Config import EXCEPTION as Exception -import DYNAMIC ( fromDynamic ) import DATA_IOREF ( readIORef ) import Directory -import List ( isSuffixOf ) \end{code} @@ -77,53 +84,51 @@ import List ( isSuffixOf ) %********************************************************* \begin{code} -loadHomeInterface :: SDoc -> Name -> RnM d ModIface +loadHomeInterface :: SDoc -> Name -> TcRn m ModIface loadHomeInterface doc_str name = ASSERT2( not (isInternalName name), ppr name <+> parens doc_str ) loadInterface doc_str (moduleName (nameModule name)) ImportBySystem -loadOrphanModules :: [ModuleName] -> RnM d () +loadOrphanModules :: [ModuleName] -> TcRn m () loadOrphanModules mods - | null mods = returnRn () + | null mods = returnM () | otherwise = traceRn (text "Loading orphan modules:" <+> - fsep (map ppr mods)) `thenRn_` - mapRn_ load mods `thenRn_` - returnRn () + fsep (map ppr mods)) `thenM_` + mappM_ load mods `thenM_` + returnM () where load mod = loadInterface (mk_doc mod) mod ImportBySystem mk_doc mod = ppr mod <+> ptext SLIT("is a orphan-instance module") -loadInterface :: SDoc -> ModuleName -> WhereFrom -> RnM d ModIface -loadInterface doc mod from - = tryLoadInterface doc mod from `thenRn` \ (ifaces, maybe_err) -> - case maybe_err of - Nothing -> returnRn ifaces - Just err -> failWithRn ifaces (elaborate err) - where - elaborate err = hang (ptext SLIT("failed to load interface for") <+> quotes (ppr mod) <> colon) - 4 err - -tryLoadInterface :: SDoc -> ModuleName -> WhereFrom -> RnM d (ModIface, Maybe Message) - -- Returns (Just err) if an error happened - -- It *doesn't* add an error to the monad, because sometimes it's ok to fail... - -- Specifically, when we read the usage information from an interface file, - -- we try to read the interfaces it mentions. But it's OK to fail; perhaps - -- the module has changed, and that interface is no longer used. +loadInterface :: SDoc -> ModuleName -> WhereFrom -> TcRn m ModIface + -- Returns Nothing if failed + -- If we can't find an interface file, and we are doing ImportForUsage, + -- just fail in the monad, and modify anything else + -- Otherwise, if we can't find an interface file, + -- add an error message to the monad (the first time only) + -- and return emptyIface + -- The "first time only" part is done by modifying the PackageIfaceTable + -- to have an empty entry + -- + -- The ImportForUsage case is because when we read the usage information from + -- an interface file, we try to read the interfaces it mentions. + -- But it's OK to fail; perhaps the module has changed, and that interface + -- is no longer used. - -- tryLoadInterface guarantees to return with iImpModInfo m --> (..., True) + -- tryLoadInterface guarantees to return with eps_mod_info m --> (..., True) -- (If the load fails, we plug in a vanilla placeholder) -tryLoadInterface doc_str mod_name from - = getHomeIfaceTableRn `thenRn` \ hit -> - getModuleRn `thenRn` \ this_mod -> - getIfacesRn `thenRn` \ ifaces@(Ifaces { iPIT = pit }) -> +loadInterface doc_str mod_name from + = getHpt `thenM` \ hpt -> + getModule `thenM` \ this_mod -> + getEps `thenM` \ eps@(EPS { eps_PIT = pit }) -> -- CHECK WHETHER WE HAVE IT ALREADY - case lookupIfaceByModName hit pit mod_name of { + case lookupIfaceByModName hpt pit mod_name of { Just iface | case from of - ImportByUser -> not (mi_boot iface) - ImportByUserSource -> mi_boot iface - ImportBySystem -> True - -> returnRn (iface, Nothing) ; -- Already loaded + ImportByUser src_imp -> src_imp == mi_boot iface + ImportForUsage src_imp -> src_imp == mi_boot iface + ImportBySystem -> True + -> returnM iface ; -- Already loaded -- The not (mi_boot iface) test checks that the already-loaded -- interface isn't a boot iface. This can conceivably happen, -- if the version checking happened to load a boot interface @@ -131,13 +136,13 @@ tryLoadInterface doc_str mod_name from other -> let - mod_map = iImpModInfo ifaces + mod_map = eps_imp_mods eps mod_info = lookupFM mod_map mod_name hi_boot_file = case (from, mod_info) of - (ImportByUser, _) -> False -- Not hi-boot - (ImportByUserSource, _) -> True -- hi-boot + (ImportByUser is_boot, _) -> is_boot + (ImportForUsage is_boot, _) -> is_boot (ImportBySystem, Just (_, is_boot)) -> is_boot (ImportBySystem, Nothing) -> False -- We're importing a module we know absolutely @@ -147,41 +152,50 @@ tryLoadInterface doc_str mod_name from redundant_source_import = case (from, mod_info) of - (ImportByUserSource, Just (_,False)) -> True - other -> False + (ImportByUser True, Just (_,False)) -> True + other -> False in -- Issue a warning for a redundant {- SOURCE -} import -- NB that we arrange to read all the ordinary imports before -- any of the {- SOURCE -} imports - warnCheckRn (not redundant_source_import) - (warnRedundantSourceImport mod_name) `thenRn_` + warnIf redundant_source_import + (warnRedundantSourceImport mod_name) `thenM_` -- Check that we aren't importing ourselves. -- That only happens in Rename.checkOldIface, - -- which doesn't call tryLoadInterface - warnCheckRn - (not (isHomeModule this_mod) || moduleName this_mod /= mod_name) - (warnSelfImport this_mod) `thenRn_` + -- which doesn't call loadInterface + warnIf + (isHomeModule this_mod && moduleName this_mod == mod_name) + (warnSelfImport this_mod) `thenM_` -- READ THE MODULE IN findAndReadIface doc_str mod_name hi_boot_file - `thenRn` \ read_result -> + `thenM` \ read_result -> case read_result of { - Left err -> -- Not found, so add an empty export env to the Ifaces map - -- so that we don't look again - let - fake_mod = mkVanillaModule mod_name - fake_iface = emptyModIface fake_mod - new_ifaces = ifaces { iPIT = extendModuleEnv pit fake_mod fake_iface } - in - setIfacesRn new_ifaces `thenRn_` - returnRn (fake_iface, Just err) ; + Left err + | case from of { ImportForUsage _ -> True ; other -> False } + -> failM -- Fail with no error messages + + | otherwise + -> let -- Not found, so add an empty export env to + -- the EPS map so that we don't look again + fake_mod = mkVanillaModule mod_name + fake_iface = emptyModIface fake_mod + new_eps = eps { eps_PIT = extendModuleEnv pit fake_mod fake_iface } + in + setEps new_eps `thenM_` + addErr (elaborate err) `thenM_` + returnM fake_iface + where + elaborate err = hang (ptext SLIT("Failed to load interface for") <+> + quotes (ppr mod_name) <> colon) 4 err + ; -- Found and parsed! Right (mod, iface) -> - -- LOAD IT INTO Ifaces + -- LOAD IT INTO EPS -- NB: *first* we do loadDecl, so that the provenance of all the locally-defined --- names is done correctly (notably, whether this is an .hi file or .hi-boot file). @@ -196,13 +210,16 @@ tryLoadInterface doc_str mod_name from isHomeModule mod, ppr mod ) - loadDecls mod (iDecls ifaces) (pi_decls iface) `thenRn` \ (decls_vers, new_decls) -> - loadRules mod (iRules ifaces) (pi_rules iface) `thenRn` \ (rule_vers, new_rules) -> - loadInstDecls mod (iInsts ifaces) (pi_insts iface) `thenRn` \ new_insts -> - loadExports (pi_exports iface) `thenRn` \ (export_vers, avails) -> - loadFixDecls mod (pi_fixity iface) `thenRn` \ fix_env -> - loadDeprecs mod (pi_deprecs iface) `thenRn` \ deprec_env -> - let + initRn (InterfaceMode mod) $ + -- Set the module, for use when looking up occurrences + -- of names in interface decls and rules + loadDecls mod (eps_decls eps) (pi_decls iface) `thenM` \ (decls_vers, new_decls) -> + loadRules mod (eps_rules eps) (pi_rules iface) `thenM` \ (rule_vers, new_rules) -> + loadInstDecls mod (eps_insts eps) (pi_insts iface) `thenM` \ new_insts -> + loadExports (pi_exports iface) `thenM` \ (export_vers, avails) -> + loadFixDecls (pi_fixity iface) `thenM` \ fix_env -> + loadDeprecs (pi_deprecs iface) `thenM` \ deprec_env -> + let version = VersionInfo { vers_module = pi_vers iface, vers_exports = export_vers, vers_rules = rule_vers, @@ -211,14 +228,20 @@ tryLoadInterface doc_str mod_name from -- For an explicit user import, add to mod_map info about -- the things the imported module depends on, extracted -- from its usage info; and delete the module itself, which is now in the PIT + usages = pi_usages iface mod_map1 = case from of - ImportByUser -> addModDeps mod is_loaded (pi_usages iface) mod_map - other -> mod_map + ImportByUser _ -> addModDeps mod is_loaded usages mod_map + other -> mod_map mod_map2 = delFromFM mod_map1 mod_name + -- mod_deps is a pruned version of usages that records only what + -- module imported, but nothing about versions. + -- This info is used when demand-linking the dependencies + mod_deps = [ (mod,orph,boot,NothingAtAll) | (mod,orph,boot,_) <- usages] + this_mod_name = moduleName this_mod is_loaded m = m == this_mod_name - || maybeToBool (lookupIfaceByModName hit pit m) + || maybeToBool (lookupIfaceByModName hpt pit m) -- We treat the currently-being-compiled module as 'loaded' because -- even though it isn't yet in the HIT or PIT; otherwise it gets -- put into iImpModInfo, and then spat out into its own interface @@ -232,19 +255,20 @@ tryLoadInterface doc_str mod_name from mi_orphan = has_orphans, mi_boot = hi_boot_file, mi_exports = avails, mi_fixities = fix_env, mi_deprecs = deprec_env, - mi_usages = [], -- Will be filled in later - mi_decls = panic "No mi_decls in PIT", - mi_globals = Nothing + mi_usages = mod_deps, -- Used for demand-loading, + -- not for version info + mi_decls = panic "No mi_decls in PIT", + mi_globals = Nothing } - new_ifaces = ifaces { iPIT = new_pit, - iDecls = new_decls, - iInsts = new_insts, - iRules = new_rules, - iImpModInfo = mod_map2 } + new_eps = eps { eps_PIT = new_pit, + eps_decls = new_decls, + eps_insts = new_insts, + eps_rules = new_rules, + eps_imp_mods = mod_map2 } in - setIfacesRn new_ifaces `thenRn_` - returnRn (mod_iface, Nothing) + setEps new_eps `thenM_` + returnM mod_iface }} ----------------------------------------------------- @@ -284,24 +308,24 @@ addModDeps mod is_loaded new_deps mod_deps -- Loading the export list ----------------------------------------------------- -loadExports :: (Version, [RdrExportItem]) -> RnM d (Version, [(ModuleName,Avails)]) +loadExports :: (Version, [RdrExportItem]) -> TcRn m (Version, [(ModuleName,Avails)]) loadExports (vers, items) - = mapRn loadExport items `thenRn` \ avails_s -> - returnRn (vers, avails_s) + = mappM loadExport items `thenM` \ avails_s -> + returnM (vers, avails_s) -loadExport :: RdrExportItem -> RnM d (ModuleName, Avails) +loadExport :: RdrExportItem -> TcRn m (ModuleName, Avails) loadExport (mod, entities) - = mapRn (load_entity mod) entities `thenRn` \ avails -> - returnRn (mod, avails) + = mappM (load_entity mod) entities `thenM` \ avails -> + returnM (mod, avails) where load_entity mod (Avail occ) - = newGlobalName mod occ `thenRn` \ name -> - returnRn (Avail name) + = newGlobalName mod occ `thenM` \ name -> + returnM (Avail name) load_entity mod (AvailTC occ occs) - = newGlobalName mod occ `thenRn` \ name -> - mapRn (newGlobalName mod) occs `thenRn` \ names -> - returnRn (AvailTC name names) + = newGlobalName mod occ `thenM` \ name -> + mappM (newGlobalName mod) occs `thenM` \ names -> + returnM (AvailTC name names) ----------------------------------------------------- @@ -311,13 +335,14 @@ loadExport (mod, entities) loadDecls :: Module -> DeclsMap -> [(Version, RdrNameTyClDecl)] - -> RnM d (NameEnv Version, DeclsMap) + -> TcRn m (NameEnv Version, DeclsMap) loadDecls mod (decls_map, n_slurped) decls - = foldlRn (loadDecl mod) (emptyNameEnv, decls_map) decls `thenRn` \ (vers, decls_map') -> - returnRn (vers, (decls_map', n_slurped)) + = foldlM (loadDecl mod) (emptyNameEnv, decls_map) decls `thenM` \ (vers, decls_map') -> + returnM (vers, (decls_map', n_slurped)) loadDecl mod (version_map, decls_map) (version, decl) - = getTyClDeclBinders mod decl `thenRn` \ (avail, sys_names) -> + = getTyClDeclBinders mod decl `thenM` \ avail -> + getSysBinders mod decl `thenM` \ sys_names -> let full_avail = case avail of Avail n -> avail @@ -329,36 +354,85 @@ loadDecl mod (version_map, decls_map) (version, decl) new_version_map = extendNameEnv version_map main_name version in - traceRn (text "Loading" <+> ppr full_avail) `thenRn_` - returnRn (new_version_map, new_decls_map) + traceRn (text "Loading" <+> ppr full_avail) `thenM_` + returnM (new_version_map, new_decls_map) + + + +----------------- +getTyClDeclBinders :: Module -> RdrNameTyClDecl -> TcRn m AvailInfo + +getTyClDeclBinders mod (IfaceSig {tcdName = var, tcdLoc = src_loc}) + = newTopBinder mod var src_loc `thenM` \ var_name -> + returnM (Avail var_name) + +getTyClDeclBinders mod tycl_decl + = mapM new (tyClDeclNames tycl_decl) `thenM` \ names@(main_name:_) -> + returnM (AvailTC main_name names) + where + new (nm,loc) = newTopBinder mod nm loc + +-------------------------------- +-- The "system names" are extra implicit names *bound* by the decl. + +getSysBinders :: Module -> TyClDecl RdrName -> TcRn m [Name] +-- Similar to tyClDeclNames, but returns the "implicit" +-- or "system" names of the declaration. And it only works +-- on RdrNames, returning OccNames + +getSysBinders mod (ClassDecl {tcdName = cname, tcdCtxt = cxt, tcdLoc = loc}) + = sequenceM [new_sys_bndr mod n loc | n <- sys_occs] + where + -- C.f. TcClassDcl.tcClassDecl1 + sys_occs = tc_occ : data_occ : dw_occ : sc_sel_occs + cls_occ = rdrNameOcc cname + data_occ = mkClassDataConOcc cls_occ + dw_occ = mkWorkerOcc data_occ + tc_occ = mkClassTyConOcc cls_occ + sc_sel_occs = [mkSuperDictSelOcc n cls_occ | n <- [1..length cxt]] + +getSysBinders mod (TyData {tcdName = tc_name, tcdCons = DataCons cons, + tcdGeneric = Just want_generic, tcdLoc = loc}) + -- The 'Just' is because this is an interface-file decl + -- so it will say whether to derive generic stuff for it or not + = sequenceM ([new_sys_bndr mod n loc | n <- gen_occs] ++ + map con_sys_occ cons) + where + -- c.f. TcTyDecls.tcTyDecl + tc_occ = rdrNameOcc tc_name + gen_occs | want_generic = [mkGenOcc1 tc_occ, mkGenOcc2 tc_occ] + | otherwise = [] + con_sys_occ (ConDecl name _ _ _ loc) + = new_sys_bndr mod (mkWorkerOcc (rdrNameOcc name)) loc + +getSysBinders mod decl = returnM [] + +new_sys_bndr mod occ loc = newTopBinder mod (mkRdrUnqual occ) loc + ----------------------------------------------------- -- Loading fixity decls ----------------------------------------------------- -loadFixDecls mod decls - = mapRn (loadFixDecl mod_name) decls `thenRn` \ to_add -> - returnRn (mkNameEnv to_add) - where - mod_name = moduleName mod +loadFixDecls decls + = mappM loadFixDecl decls `thenM` \ to_add -> + returnM (mkNameEnv to_add) -loadFixDecl mod_name (rdr_name, fixity) - = newGlobalName mod_name (rdrNameOcc rdr_name) `thenRn` \ name -> - returnRn (name, fixity) +loadFixDecl (FixitySig rdr_name fixity loc) + = lookupGlobalOccRn rdr_name `thenM` \ name -> + returnM (name, FixitySig name fixity loc) ----------------------------------------------------- -- Loading instance decls ----------------------------------------------------- -loadInstDecls :: Module - -> IfaceInsts +loadInstDecls :: Module -> IfaceInsts -> [RdrNameInstDecl] - -> RnM d IfaceInsts + -> RnM IfaceInsts loadInstDecls mod (insts, n_slurped) decls - = setModuleRn mod $ - foldlRn (loadInstDecl mod) insts decls `thenRn` \ insts' -> - returnRn (insts', n_slurped) + = foldlM (loadInstDecl mod) insts decls `thenM` \ insts' -> + returnM (insts', n_slurped) loadInstDecl mod insts decl@(InstDecl inst_ty _ _ _ _) @@ -387,19 +461,19 @@ loadInstDecl mod insts decl@(InstDecl inst_ty _ _ _ _) -- NOTICE that we rename the type before extracting its free -- variables. The free-variable finder for a renamed HsType -- does the Right Thing for built-in syntax like [] and (,). - initIfaceRnMS mod ( - rnHsType (text "In an interface instance decl") inst_ty - ) `thenRn` \ inst_ty' -> + rnHsType (text "In an interface instance decl") inst_ty `thenM` \ inst_ty' -> let - (tvs,(cls,tys)) = getHsInstHead inst_ty' + (tvs,_,cls,tys) = splitHsInstDeclTy inst_ty' free_tcs = nameSetToList (extractHsTyNames_s tys) `minusList` hsTyVarNames tvs gate_fn vis_fn = vis_fn cls && (null free_tcs || any vis_fn free_tcs) + -- The 'vis_fn' returns True for visible names -- Here is the implementation of HOWEVER above -- (Note that we do let the inst decl in if it mentions -- no tycons at all. Hence the null free_ty_names.) in - returnRn ((gate_fn, (mod, decl)) `consBag` insts) + traceRn ((text "Load instance for" <+> ppr inst_ty') $$ ppr free_tcs) `thenM_` + returnM ((gate_fn, (mod, decl)) `consBag` insts) @@ -407,81 +481,121 @@ loadInstDecl mod insts decl@(InstDecl inst_ty _ _ _ _) -- Loading Rules ----------------------------------------------------- -loadRules :: Module -> IfaceRules +loadRules :: Module + -> IfaceRules -> (Version, [RdrNameRuleDecl]) - -> RnM d (Version, IfaceRules) + -> RnM (Version, IfaceRules) loadRules mod (rule_bag, n_slurped) (version, rules) | null rules || opt_IgnoreIfacePragmas - = returnRn (version, (rule_bag, n_slurped)) + = returnM (version, (rule_bag, n_slurped)) | otherwise - = setModuleRn mod $ - mapRn (loadRule mod) rules `thenRn` \ new_rules -> - returnRn (version, (rule_bag `unionBags` listToBag new_rules, n_slurped)) + = mappM (loadRule mod) rules `thenM` \ new_rules -> + returnM (version, (rule_bag `unionBags` listToBag new_rules, n_slurped)) -loadRule :: Module -> RdrNameRuleDecl -> RnM d (GatedDecl RdrNameRuleDecl) +loadRule :: Module -> RdrNameRuleDecl -> RnM (GatedDecl RdrNameRuleDecl) -- "Gate" the rule simply by whether the rule variable is -- needed. We can refine this later. loadRule mod decl@(IfaceRule _ _ _ var _ _ src_loc) - = lookupIfaceName var `thenRn` \ var_name -> - returnRn (\vis_fn -> vis_fn var_name, (mod, decl)) + = lookupGlobalOccRn var `thenM` \ var_name -> + returnM (\vis_fn -> vis_fn var_name, (mod, decl)) ----------------------------------------------------- -- Loading Deprecations ----------------------------------------------------- -loadDeprecs :: Module -> IfaceDeprecs -> RnM d Deprecations -loadDeprecs m Nothing = returnRn NoDeprecs -loadDeprecs m (Just (Left txt)) = returnRn (DeprecAll txt) -loadDeprecs m (Just (Right prs)) = setModuleRn m $ - foldlRn loadDeprec emptyNameEnv prs `thenRn` \ env -> - returnRn (DeprecSome env) +loadDeprecs :: IfaceDeprecs -> RnM Deprecations +loadDeprecs Nothing = returnM NoDeprecs +loadDeprecs (Just (Left txt)) = returnM (DeprecAll txt) +loadDeprecs (Just (Right prs)) = foldlM loadDeprec emptyNameEnv prs `thenM` \ env -> + returnM (DeprecSome env) loadDeprec deprec_env (n, txt) - = lookupIfaceName n `thenRn` \ name -> - traceRn (text "Loaded deprecation(s) for" <+> ppr name <> colon <+> ppr txt) `thenRn_` - returnRn (extendNameEnv deprec_env name (name,txt)) + = lookupGlobalOccRn n `thenM` \ name -> + traceRn (text "Loaded deprecation(s) for" <+> ppr name <> colon <+> ppr txt) `thenM_` + returnM (extendNameEnv deprec_env name (name,txt)) \end{code} -%********************************************************* +%******************************************************** %* * -\subsection{Getting binders out of a declaration} + Load the ParsedIface for the *current* module + into a ModIface; then it can be checked + for up-to-date-ness %* * -%********************************************************* - -@getDeclBinders@ returns the names for a @RdrNameHsDecl@. -It's used for both source code (from @availsFromDecl@) and interface files -(from @loadDecl@). - -It doesn't deal with source-code specific things: @ValD@, @DefD@. They -are handled by the sourc-code specific stuff in @RnNames@. - - *** See "THE NAMING STORY" in HsDecls **** - +%******************************************************** \begin{code} -getTyClDeclBinders - :: Module - -> RdrNameTyClDecl - -> RnM d (AvailInfo, [Name]) -- The [Name] are the system names - ------------------ -getTyClDeclBinders mod (IfaceSig {tcdName = var, tcdLoc = src_loc}) - = newTopBinder mod var src_loc `thenRn` \ var_name -> - returnRn (Avail var_name, []) +loadOldIface :: ParsedIface -> RnM ModIface + +loadOldIface iface + = loadHomeDecls (pi_decls iface) `thenM` \ (decls_vers, new_decls) -> + loadHomeRules (pi_rules iface) `thenM` \ (rule_vers, new_rules) -> + loadHomeInsts (pi_insts iface) `thenM` \ new_insts -> + mappM loadHomeUsage (pi_usages iface) `thenM` \ usages -> + loadExports (pi_exports iface) `thenM` \ (export_vers, avails) -> + loadFixDecls (pi_fixity iface) `thenM` \ fix_env -> + loadDeprecs (pi_deprecs iface) `thenM` \ deprec_env -> + + getModeRn `thenM` \ (InterfaceMode mod) -> + -- Caller sets the module before the call; also needed + -- by the newGlobalName stuff in some of the loadHomeX calls + let + version = VersionInfo { vers_module = pi_vers iface, + vers_exports = export_vers, + vers_rules = rule_vers, + vers_decls = decls_vers } -getTyClDeclBinders mod (CoreDecl {tcdName = var, tcdLoc = src_loc}) - = newTopBinder mod var src_loc `thenRn` \ var_name -> - returnRn (Avail var_name, []) + decls = mkIfaceDecls new_decls new_rules new_insts -getTyClDeclBinders mod tycl_decl - = new_top_bndrs mod (tyClDeclNames tycl_decl) `thenRn` \ names@(main_name:_) -> - new_top_bndrs mod (tyClDeclSysNames tycl_decl) `thenRn` \ sys_names -> - returnRn (AvailTC main_name names, sys_names) + mod_iface = ModIface { mi_module = mod, mi_package = pi_pkg iface, + mi_version = version, + mi_exports = avails, mi_usages = usages, + mi_boot = False, mi_orphan = pi_orphan iface, + mi_fixities = fix_env, mi_deprecs = deprec_env, + mi_decls = decls, + mi_globals = Nothing + } + in + returnM mod_iface +\end{code} ------------------ -new_top_bndrs mod names_w_locs - = sequenceRn [newTopBinder mod name loc | (name,loc) <- names_w_locs] +\begin{code} +loadHomeDecls :: [(Version, RdrNameTyClDecl)] + -> RnM (NameEnv Version, [RenamedTyClDecl]) +loadHomeDecls decls = foldlM loadHomeDecl (emptyNameEnv, []) decls + +loadHomeDecl :: (NameEnv Version, [RenamedTyClDecl]) + -> (Version, RdrNameTyClDecl) + -> RnM (NameEnv Version, [RenamedTyClDecl]) +loadHomeDecl (version_map, decls) (version, decl) + = rnTyClDecl decl `thenM` \ decl' -> + returnM (extendNameEnv version_map (tyClDeclName decl') version, decl':decls) + +------------------ +loadHomeRules :: (Version, [RdrNameRuleDecl]) + -> RnM (Version, [RenamedRuleDecl]) +loadHomeRules (version, rules) + = mappM rnIfaceRuleDecl rules `thenM` \ rules' -> + returnM (version, rules') + +------------------ +loadHomeInsts :: [RdrNameInstDecl] + -> RnM [RenamedInstDecl] +loadHomeInsts insts = mappM rnInstDecl insts + +------------------ +loadHomeUsage :: ImportVersion OccName + -> TcRn m (ImportVersion Name) +loadHomeUsage (mod_name, orphans, is_boot, whats_imported) + = rn_imps whats_imported `thenM` \ whats_imported' -> + returnM (mod_name, orphans, is_boot, whats_imported') + where + rn_imps NothingAtAll = returnM NothingAtAll + rn_imps (Everything v) = returnM (Everything v) + rn_imps (Specifically mv ev items rv) = mappM rn_imp items `thenM` \ items' -> + returnM (Specifically mv ev items' rv) + rn_imp (occ,vers) = newGlobalName mod_name occ `thenM` \ name -> + returnM (name,vers) \end{code} @@ -495,50 +609,39 @@ new_top_bndrs mod names_w_locs findAndReadIface :: SDoc -> ModuleName -> IsBootInterface -- True <=> Look for a .hi-boot file -- False <=> Look for .hi file - -> RnM d (Either Message (Module, ParsedIface)) + -> TcRn m (Either Message (Module, ParsedIface)) -- Nothing <=> file not found, or unreadable, or illegible -- Just x <=> successfully found and parsed + -- It *doesn't* add an error to the monad, because + -- sometimes it's ok to fail... see notes with loadInterface + findAndReadIface doc_str mod_name hi_boot_file - = traceRn trace_msg `thenRn_` + = traceRn trace_msg `thenM_` -- Check for GHC.Prim, and return its static interface if mod_name == gHC_PRIM_Name - then returnRn (Right (gHC_PRIM, ghcPrimIface)) + then returnM (Right (gHC_PRIM, ghcPrimIface)) else - -- In interactive or --make mode, we are *not allowed* to demand-load - -- a home package .hi file. So don't even look for them. - -- This helps in the case where you are sitting in eg. ghc/lib/std - -- and start up GHCi - it won't complain that all the modules it tries - -- to load are found in the home location. - ioToRnM_no_fail (readIORef v_GhcMode) `thenRn` \ mode -> - let home_allowed = hi_boot_file || not (isCompManagerMode mode) - in - - ioToRnM (if home_allowed - then findModule mod_name - else findPackageModule mod_name) `thenRn` \ maybe_found -> + ioToTcRn (findHiFile mod_name hi_boot_file) `thenM` \ maybe_found -> case maybe_found of + Nothing -> + traceRn (ptext SLIT("...not found")) `thenM_` + returnM (Left (noIfaceErr mod_name hi_boot_file)) - Right (Just (wanted_mod,locn)) - -> mkHiPath hi_boot_file locn `thenRn` \ file -> - readIface file `thenRn` \ read_result -> - case read_result of - Left bad -> returnRn (Left bad) - Right iface -> -- check that the module names agree - let read_mod_name = pi_mod iface - wanted_mod_name = moduleName wanted_mod - in - checkRn - (wanted_mod_name == read_mod_name) - (hiModuleNameMismatchWarn wanted_mod_name read_mod_name) - `thenRn_` - returnRn (Right (wanted_mod, iface)) - -- Can't find it - other -> traceRn (ptext SLIT("...not found")) `thenRn_` - returnRn (Left (noIfaceErr mod_name hi_boot_file)) + Just (wanted_mod, file_path) -> + traceRn (ptext SLIT("readIFace") <+> text file_path) `thenM_` + + readIface wanted_mod file_path hi_boot_file `thenM` \ read_result -> + -- Catch exceptions here + + case read_result of + Left exn -> returnM (Left (badIfaceFile file_path + (text (showException exn)))) + + Right iface -> returnM (Right (wanted_mod, iface)) where trace_msg = sep [hsep [ptext SLIT("Reading"), @@ -547,67 +650,105 @@ findAndReadIface doc_str mod_name hi_boot_file ppr mod_name <> semi], nest 4 (ptext SLIT("reason:") <+> doc_str)] -mkHiPath hi_boot_file locn - | hi_boot_file = - ioToRnM_no_fail (doesFileExist hi_boot_ver_path) `thenRn` \ b -> - if b then returnRn hi_boot_ver_path - else returnRn hi_boot_path - | otherwise = returnRn hi_path - where hi_path = ml_hi_file locn - (hi_base, _hi_suf) = splitFilename hi_path - hi_boot_path = hi_base ++ ".hi-boot" - hi_boot_ver_path = hi_base ++ ".hi-boot-" ++ cHscIfaceFileVersion +findHiFile :: ModuleName -> IsBootInterface -> IO (Maybe (Module, FilePath)) +findHiFile mod_name hi_boot_file + = do { + -- In interactive or --make mode, we are *not allowed* to demand-load + -- a home package .hi file. So don't even look for them. + -- This helps in the case where you are sitting in eg. ghc/lib/std + -- and start up GHCi - it won't complain that all the modules it tries + -- to load are found in the home location. + ghci_mode <- readIORef v_GhcMode ; + let { home_allowed = hi_boot_file || + not (isCompManagerMode ghci_mode) } ; + maybe_found <- if home_allowed + then findModule mod_name + else findPackageModule mod_name ; + + case maybe_found of { + Nothing -> return Nothing ; + + Just (mod,loc) -> do { + + -- Return the path to M.hi, M.hi-boot, or M.hi-boot-n as appropriate + let { hi_path = ml_hi_file loc ; + (hi_base, _hi_suf) = splitFilename hi_path ; + hi_boot_path = hi_base ++ ".hi-boot" ; + hi_boot_ver_path = hi_base ++ ".hi-boot-" ++ cHscIfaceFileVersion } ; + + if not hi_boot_file then + return (Just (mod, hi_path)) + else do { + hi_ver_exists <- doesFileExist hi_boot_ver_path ; + if hi_ver_exists then return (Just (mod, hi_boot_ver_path)) + else return (Just (mod, hi_boot_path)) + }}}} \end{code} @readIface@ tries just the one file. \begin{code} -readIface :: String -> RnM d (Either Message ParsedIface) +readIface :: Module -> String -> IsBootInterface -> TcRn m (Either IOError ParsedIface) -- Nothing <=> file not found, or unreadable, or illegible -- Just x <=> successfully found and parsed -readIface file_path - = --ioToRnM (putStrLn ("reading iface " ++ file_path)) `thenRn_` - traceRn (ptext SLIT("readIFace") <+> text file_path) `thenRn_` - - let hi_boot_ver = "hi-boot-" ++ cHscIfaceFileVersion in - if ".hi-boot" `isSuffixOf` file_path - || hi_boot_ver `isSuffixOf` file_path then - - ioToRnM (hGetStringBuffer file_path) `thenRn` \ read_result -> - case read_result of { - Left io_error -> bale_out (text (show io_error)); - Right contents -> - - case parseIface contents (mkPState loc exts) of { - POk _ iface -> returnRn (Right iface); - PFailed err -> bale_out err - }} - - else - ioToRnM_no_fail (myTry (Binary.getBinFileWithDict file_path)) - `thenRn` \ either_iface -> - - case either_iface of - Right iface -> returnRn (Right iface) - Left (DynException d) | Just e <- fromDynamic d - -> bale_out (text (show (e :: GhcException))) - - Left err -> bale_out (text (show err)) - where +readIface mod file_path is_hi_boot_file + = ioToTcRn_no_fail (read_iface mod file_path is_hi_boot_file) + +read_iface mod file_path is_hi_boot_file + | is_hi_boot_file -- Read ascii + = do { buffer <- hGetStringBuffer file_path ; + case parseIface buffer (mkPState loc exts) of + POk _ iface | wanted_mod_name == actual_mod_name + -> return iface + | otherwise + -> throwDyn (ProgramError (showSDoc err)) + -- 'showSDoc' is a bit yukky + where + wanted_mod_name = moduleName mod + actual_mod_name = pi_mod iface + err = hiModuleNameMismatchWarn wanted_mod_name actual_mod_name + + PFailed err -> throwDyn (ProgramError (showSDoc err)) + } + + | otherwise -- Read binary + = readBinIface file_path + + where exts = ExtFlags {glasgowExtsEF = True, ffiEF = True, withEF = True, parrEF = True} loc = mkSrcLoc (mkFastString file_path) 1 +\end{code} - bale_out err = returnRn (Left (badIfaceFile file_path err)) -#if __GLASGOW_HASKELL__ < 501 -myTry = Exception.tryAllIO -#else -myTry = Exception.try -#endif +%********************************************************* +%* * + Wired-in interface for GHC.Prim +%* * +%********************************************************* + +\begin{code} +ghcPrimIface :: ParsedIface +ghcPrimIface = ParsedIface { + pi_mod = gHC_PRIM_Name, + pi_pkg = preludePackage, + pi_vers = 1, + pi_orphan = False, + pi_usages = [], + pi_exports = (1, [(gHC_PRIM_Name, ghcPrimExports)]), + pi_decls = [(1,cCallableClassDecl), + (1,cReturnableClassDecl), + (1,assertDecl)], + pi_fixity = [FixitySig (nameRdrName (idName seqId)) + (Fixity 0 InfixR) noSrcLoc], + -- seq is infixr 0 + pi_insts = [], + pi_rules = (1,[]), + pi_deprecs = Nothing + } \end{code} %********************************************************* diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index 6b6d949d79..83a098a64d 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -11,39 +11,40 @@ module RnHsSyn where import HsSyn import HsCore import Class ( FunDep, DefMeth(..) ) -import TyCon ( visibleDataCons ) +import TyCon ( visibleDataCons, tyConName ) import TysWiredIn ( tupleTyCon, listTyCon, parrTyCon, charTyCon ) import Name ( Name, getName, isTyVarName ) import NameSet -import BasicTypes ( Boxity ) +import BasicTypes ( Boxity, FixitySig ) import Outputable \end{code} \begin{code} -type RenamedHsDecl = HsDecl Name RenamedPat -type RenamedArithSeqInfo = ArithSeqInfo Name RenamedPat +type RenamedHsDecl = HsDecl Name +type RenamedArithSeqInfo = ArithSeqInfo Name type RenamedClassOpSig = Sig Name type RenamedConDecl = ConDecl Name type RenamedContext = HsContext Name -type RenamedRuleDecl = RuleDecl Name RenamedPat -type RenamedTyClDecl = TyClDecl Name RenamedPat +type RenamedRuleDecl = RuleDecl Name +type RenamedTyClDecl = TyClDecl Name type RenamedDefaultDecl = DefaultDecl Name type RenamedForeignDecl = ForeignDecl Name -type RenamedGRHS = GRHS Name RenamedPat -type RenamedGRHSs = GRHSs Name RenamedPat -type RenamedHsBinds = HsBinds Name RenamedPat -type RenamedHsExpr = HsExpr Name RenamedPat -type RenamedInstDecl = InstDecl Name RenamedPat +type RenamedCoreDecl = CoreDecl Name +type RenamedGRHS = GRHS Name +type RenamedGRHSs = GRHSs Name +type RenamedHsBinds = HsBinds Name +type RenamedHsExpr = HsExpr Name +type RenamedInstDecl = InstDecl Name type RenamedMatchContext = HsMatchContext Name -type RenamedMatch = Match Name RenamedPat -type RenamedMonoBinds = MonoBinds Name RenamedPat +type RenamedMatch = Match Name +type RenamedMonoBinds = MonoBinds Name type RenamedPat = InPat Name type RenamedHsType = HsType Name type RenamedHsPred = HsPred Name -type RenamedRecordBinds = HsRecordBinds Name RenamedPat +type RenamedRecordBinds = HsRecordBinds Name type RenamedSig = Sig Name -type RenamedStmt = Stmt Name RenamedPat +type RenamedStmt = Stmt Name type RenamedFixitySig = FixitySig Name type RenamedDeprecation = DeprecDecl Name \end{code} @@ -125,6 +126,13 @@ In all cases this is set up for interface-file declarations: *** See "THE NAMING STORY" in HsDecls **** \begin{code} +---------------- +impDeclFVs :: RenamedHsDecl -> NameSet + -- Just the ones that come from imports +impDeclFVs (InstD d) = instDeclFVs d +impDeclFVs (TyClD d) = tyClDeclFVs d + +---------------- tyClDeclFVs :: RenamedTyClDecl -> NameSet tyClDeclFVs (ForeignType {}) = emptyFVs @@ -158,9 +166,6 @@ tyClDeclFVs (ClassDecl {tcdCtxt = context, tcdTyVars = tyvars, tcdFDs = fds, Just _ -> emptyFVs -- Source code, so the default methods -- are *bound* not *free* -tyClDeclFVs (CoreDecl {tcdType = ty, tcdRhs = rhs}) - = extractHsTyNames ty `plusFV` ufExprFVs rhs - ---------------- hsSigsFVs sigs = plusFVs (map hsSigFVs sigs) @@ -183,12 +188,12 @@ ruleDeclFVs (IfaceRule _ _ vars _ args rhs _) ufExprFVs rhs `plusFV` plusFVs (map ufExprFVs args) ---------------- -conDeclFVs (ConDecl _ _ tyvars context details _) +conDeclFVs (ConDecl _ tyvars context details _) = delFVs (map hsTyVarName tyvars) $ extractHsCtxtTyNames context `plusFV` conDetailsFVs details -conDetailsFVs (VanillaCon btys) = plusFVs (map bangTyFVs btys) +conDetailsFVs (PrefixCon btys) = plusFVs (map bangTyFVs btys) conDetailsFVs (InfixCon bty1 bty2) = bangTyFVs bty1 `plusFV` bangTyFVs bty2 conDetailsFVs (RecCon flds) = plusFVs [bangTyFVs bty | (_, bty) <- flds] @@ -228,9 +233,11 @@ ufConFVs other = emptyFVs ufNoteFVs (UfCoerce ty) = extractHsTyNames ty ufNoteFVs note = emptyFVs -hsTupConFVs (HsTupCon n _ _) = unitFV n +hsTupConFVs (HsTupCon bx n) = unitFV (tyConName (tupleTyCon bx n)) + -- Always return the TyCon; that'll suck in the data con \end{code} + %************************************************************************ %* * \subsection{A few functions on generic defintions @@ -245,7 +252,7 @@ maybeGenericMatch :: RenamedMatch -> Maybe (RenamedHsType, RenamedMatch) -- Tells whether a Match is for a generic definition -- and extract the type from a generic match and put it at the front -maybeGenericMatch (Match (TypePatIn ty : pats) sig_ty grhss) +maybeGenericMatch (Match (TypePat ty : pats) sig_ty grhss) = Just (ty, Match pats sig_ty grhss) maybeGenericMatch other_match = Nothing diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index c591bb3a17..9e7c53ad8d 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -1,17 +1,12 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -\section[RnIfaces]{Cacheing and Renaming of Interfaces} +section +\%[RnIfaces]{Cacheing and Renaming of Interfaces} \begin{code} module RnIfaces - ( - recordLocalSlurps, - mkImportInfo, - - slurpImpDecls, closeDecls, - - RecompileRequired, outOfDate, upToDate, recompileRequired + ( slurpImpDecls, importSupportingDecls, + RecompileRequired, outOfDate, upToDate, checkVersions ) where @@ -19,237 +14,40 @@ where import CmdLineOpts ( opt_IgnoreIfacePragmas, opt_NoPruneDecls ) import HscTypes -import HsSyn ( HsDecl(..), Sig(..), TyClDecl(..), ConDecl(..), ConDetails(..), +import HsSyn ( HsDecl(..), Sig(..), TyClDecl(..), ConDecl(..), HsConDetails(..), InstDecl(..), HsType(..), hsTyVarNames, getBangType ) -import HsImpExp ( ImportDecl(..) ) import RdrHsSyn ( RdrNameTyClDecl, RdrNameInstDecl, RdrNameRuleDecl ) import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, extractHsTyNames, extractHsCtxtTyNames, - tyClDeclFVs, ruleDeclFVs, instDeclFVs - ) -import RnHiFiles ( tryLoadInterface, loadHomeInterface, - loadOrphanModules + tyClDeclFVs, ruleDeclFVs, impDeclFVs ) +import RnHiFiles ( loadInterface, loadHomeInterface, loadOrphanModules ) import RnSource ( rnTyClDecl, rnInstDecl, rnIfaceRuleDecl ) -import RnEnv -import RnMonad +import TcEnv ( getInGlobalScope, tcLookupGlobal_maybe ) +import TcRnMonad import Id ( idType, idName, globalIdDetails ) import IdInfo ( GlobalIdDetails(..) ) -import TcType ( namesOfType ) +import TcType ( tyClsNamesOfType, classNamesOfTheta ) import FieldLabel ( fieldLabelTyCon ) import DataCon ( dataConTyCon ) import TyCon ( visibleDataCons, isSynTyCon, getSynTyConDefn, tyConClass_maybe, tyConName ) -import Class ( className ) -import Name ( Name {-instance NamedThing-}, nameOccName, - nameModule, isInternalName, NamedThing(..) +import Class ( className, classSCTheta ) +import Name ( Name {-instance NamedThing-}, isWiredInName, isInternalName, nameModule, NamedThing(..) ) -import NameEnv ( elemNameEnv, delFromNameEnv, lookupNameEnv ) +import NameEnv ( delFromNameEnv, lookupNameEnv ) import NameSet -import Module ( Module, ModuleEnv, - moduleName, isHomeModule, - ModuleName, WhereFrom(..), - emptyModuleEnv, - extendModuleEnv_C, foldModuleEnv, lookupModuleEnv, - elemModuleSet, extendModuleSet - ) -import PrelInfo ( wiredInThingEnv, hasKey, fractionalClassKey, numClassKey, +import Module ( Module, isHomeModule, extendModuleSet ) +import PrelInfo ( hasKey, fractionalClassKey, numClassKey, integerTyConName, doubleTyConName ) -import Maybe ( isJust ) import FiniteMap import Outputable import Bag -import Util ( sortLt, seqList ) +import Maybe( fromJust ) \end{code} %********************************************************* -%* * -\subsection{Keeping track of what we've slurped, and version numbers} -%* * -%********************************************************* - -mkImportInfo figures out what the ``usage information'' for this -moudule is; that is, what it must record in its interface file as the -things it uses. - -We produce a line for every module B below the module, A, currently being -compiled: - import B <n> ; -to record the fact that A does import B indirectly. This is used to decide -to look to look for B.hi rather than B.hi-boot when compiling a module that -imports A. This line says that A imports B, but uses nothing in it. -So we'll get an early bale-out when compiling A if B's version changes. - -The usage information records: - -\begin{itemize} -\item (a) anything reachable from its body code -\item (b) any module exported with a @module Foo@ -\item (c) anything reachable from an exported item -\end{itemize} - -Why (b)? Because if @Foo@ changes then this module's export list -will change, so we must recompile this module at least as far as -making a new interface file --- but in practice that means complete -recompilation. - -Why (c)? Consider this: -\begin{verbatim} - module A( f, g ) where | module B( f ) where - import B( f ) | f = h 3 - g = ... | h = ... -\end{verbatim} - -Here, @B.f@ isn't used in A. Should we nevertheless record @B.f@ in -@A@'s usages? Our idea is that we aren't going to touch A.hi if it is -*identical* to what it was before. If anything about @B.f@ changes -than anyone who imports @A@ should be recompiled in case they use -@B.f@ (they'll get an early exit if they don't). So, if anything -about @B.f@ changes we'd better make sure that something in A.hi -changes, and the convenient way to do that is to record the version -number @B.f@ in A.hi in the usage list. If B.f changes that'll force a -complete recompiation of A, which is overkill but it's the only way to -write a new, slightly different, A.hi. - -But the example is tricker. Even if @B.f@ doesn't change at all, -@B.h@ may do so, and this change may not be reflected in @f@'s version -number. But with -O, a module that imports A must be recompiled if -@B.h@ changes! So A must record a dependency on @B.h@. So we treat -the occurrence of @B.f@ in the export list *just as if* it were in the -code of A, and thereby haul in all the stuff reachable from it. - - *** Conclusion: if A mentions B.f in its export list, - behave just as if A mentioned B.f in its source code, - and slurp in B.f and all its transitive closure *** - -[NB: If B was compiled with -O, but A isn't, we should really *still* -haul in all the unfoldings for B, in case the module that imports A *is* -compiled with -O. I think this is the case.] - -\begin{code} -mkImportInfo :: ModuleName -- Name of this module - -> [ImportDecl n] -- The import decls - -> RnMG [ImportVersion Name] - -mkImportInfo this_mod imports - = getIfacesRn `thenRn` \ ifaces -> - getHomeIfaceTableRn `thenRn` \ hit -> - let - (imp_pkg_mods, imp_home_names) = iVSlurp ifaces - pit = iPIT ifaces - - import_all_mods :: [ModuleName] - -- Modules where we imported all the names - -- (apart from hiding some, perhaps) - import_all_mods = [ m | ImportDecl m _ _ _ imp_list _ <- imports, - import_all imp_list ] - where - import_all (Just (False, _)) = False -- Imports are spec'd explicitly - import_all other = True -- Everything is imported - - -- mv_map groups together all the things imported and used - -- from a particular module in this package - -- We use a finite map because we want the domain - mv_map :: ModuleEnv [Name] - mv_map = foldNameSet add_mv emptyModuleEnv imp_home_names - add_mv name mv_map = extendModuleEnv_C add_item mv_map mod [name] - where - mod = nameModule name - add_item names _ = name:names - - -- In our usage list we record - -- - -- a) Specifically: Detailed version info for imports - -- from modules in this package Gotten from iVSlurp plus - -- import_all_mods - -- - -- b) Everything: Just the module version for imports - -- from modules in other packages Gotten from iVSlurp plus - -- import_all_mods - -- - -- c) NothingAtAll: The name only of modules, Baz, in - -- this package that are 'below' us, but which we didn't need - -- at all (this is needed only to decide whether to open Baz.hi - -- or Baz.hi-boot higher up the tree). This happens when a - -- module, Foo, that we explicitly imported has 'import Baz' in - -- its interface file, recording that Baz is below Foo in the - -- module dependency hierarchy. We want to propagate this - -- info. These modules are in a combination of HIT/PIT and - -- iImpModInfo - -- - -- d) NothingAtAll: The name only of all orphan modules - -- we know of (this is needed so that anyone who imports us can - -- find the orphan modules) These modules are in a combination - -- of HIT/PIT and iImpModInfo - - import_info0 = foldModuleEnv mk_imp_info [] pit - import_info1 = foldModuleEnv mk_imp_info import_info0 hit - import_info = not_even_opened_imports ++ import_info1 - - -- Recall that iImpModInfo describes modules that have - -- been mentioned in the import lists of interfaces we - -- have opened, but which we have not even opened when - -- compiling this module - not_even_opened_imports = - [ (mod_name, orphans, is_boot, NothingAtAll) - | (mod_name, (orphans, is_boot)) <- fmToList (iImpModInfo ifaces) ] - - - mk_imp_info :: ModIface -> [ImportVersion Name] -> [ImportVersion Name] - mk_imp_info iface so_far - - | Just ns <- lookupModuleEnv mv_map mod -- Case (a) - = go_for_it (Specifically mod_vers maybe_export_vers - (mk_import_items ns) rules_vers) - - | mod `elemModuleSet` imp_pkg_mods -- Case (b) - = go_for_it (Everything mod_vers) - - | import_all_mod -- Case (a) and (b); the import-all part - = if is_home_pkg_mod then - go_for_it (Specifically mod_vers (Just export_vers) [] rules_vers) - -- Since the module isn't in the mv_map, presumably we - -- didn't actually import anything at all from it - else - go_for_it (Everything mod_vers) - - | is_home_pkg_mod || has_orphans -- Case (c) or (d) - = go_for_it NothingAtAll - - | otherwise = so_far - where - go_for_it exports = (mod_name, has_orphans, mi_boot iface, exports) : so_far - - mod = mi_module iface - mod_name = moduleName mod - is_home_pkg_mod = isHomeModule mod - version_info = mi_version iface - version_env = vers_decls version_info - mod_vers = vers_module version_info - rules_vers = vers_rules version_info - export_vers = vers_exports version_info - import_all_mod = mod_name `elem` import_all_mods - has_orphans = mi_orphan iface - - -- The sort is to put them into canonical order - mk_import_items ns = [(n,v) | n <- sortLt lt_occ ns, - let v = lookupVersion version_env n - ] - where - lt_occ n1 n2 = nameOccName n1 < nameOccName n2 - - maybe_export_vers | import_all_mod = Just (vers_exports version_info) - | otherwise = Nothing - in - - -- seq the list of ImportVersions returned: occasionally these - -- don't get evaluated for a while and we can end up hanging on to - -- the entire collection of Ifaces. - seqList import_info (returnRn import_info) -\end{code} - -%********************************************************* %* * \subsection{Slurping declarations} %* * @@ -257,27 +55,31 @@ mkImportInfo this_mod imports \begin{code} ------------------------------------------------------- +slurpImpDecls :: FreeVars -> TcRn m [RenamedHsDecl] slurpImpDecls source_fvs - = traceRn (text "slurpImp" <+> fsep (map ppr (nameSetToList source_fvs))) `thenRn_` + = traceRn (text "slurpImp" <+> fsep (map ppr (nameSetToList source_fvs))) `thenM_` - -- The current slurped-set records all local things - slurpSourceRefs source_fvs `thenRn` \ (decls, needed) -> + -- Slurp in things which might be 'gates' for instance + -- declarations, plus the instance declarations themselves + slurpSourceRefs source_fvs `thenM` \ (gate_decls, bndrs) -> -- Then get everything else - closeDecls decls needed + let + needed = foldr (plusFV . impDeclFVs) emptyFVs gate_decls + in + import_supporting_decls (gate_decls, bndrs) needed ------------------------------------------------------- slurpSourceRefs :: FreeVars -- Variables referenced in source - -> RnMG ([RenamedHsDecl], - FreeVars) -- Un-satisfied needs --- The declaration (and hence home module) of each gate has --- already been loaded + -> TcRn m ([RenamedHsDecl], -- Needed declarations + NameSet) -- Names bound by those declarations +-- Slurp imported declarations needed directly by the source code; +-- and some of the ones they need. The goal is to find all the 'gates' +-- for instance declarations. slurpSourceRefs source_fvs - = go_outer [] -- Accumulating decls - emptyFVs -- Unsatisfied needs - emptyFVs -- Accumulating gates + = go_outer [] emptyFVs -- Accumulating decls (nameSetToList source_fvs) -- Things whose defn hasn't been loaded yet where -- The outer loop repeatedly slurps the decls for the current gates @@ -294,137 +96,203 @@ slurpSourceRefs source_fvs -- so that its superclasses are discovered. The point is that Wib is a gate too. -- We do this for tycons too, so that we look through type synonyms. - go_outer decls fvs all_gates [] - = returnRn (decls, fvs) - - go_outer decls fvs all_gates refs -- refs are not necessarily slurped yet - = traceRn (text "go_outer" <+> ppr refs) `thenRn_` - foldlRn go_inner (decls, fvs, emptyFVs) refs `thenRn` \ (decls1, fvs1, gates1) -> - getImportedInstDecls (all_gates `plusFV` gates1) `thenRn` \ inst_decls -> - rnIfaceInstDecls decls1 fvs1 gates1 inst_decls `thenRn` \ (decls2, fvs2, gates2) -> - go_outer decls2 fvs2 (all_gates `plusFV` gates2) - (nameSetToList (gates2 `minusNameSet` all_gates)) - -- Knock out the all_gates because even if we don't slurp any new - -- decls we can get some apparently-new gates from wired-in names - -- and we get an infinite loop - - go_inner (decls, fvs, gates) wanted_name - = importDecl wanted_name `thenRn` \ import_result -> + go_outer decls bndrs [] = returnM (decls, bndrs) + + go_outer decls bndrs refs -- 'refs' are not necessarily slurped yet + = traceRn (text "go_outer" <+> ppr refs) `thenM_` + foldlM go_inner (decls, bndrs, emptyFVs) refs `thenM` \ (decls1, bndrs1, gates1) -> + getImportedInstDecls gates1 `thenM` \ (inst_decls, new_gates) -> + rnIfaceDecls rnInstDecl inst_decls `thenM` \ inst_decls' -> + go_outer (map InstD inst_decls' ++ decls1) + bndrs1 + (nameSetToList (new_gates `plusFV` plusFVs (map getInstDeclGates inst_decls'))) + -- NB: we go round again to fetch the decls for any gates of any decls + -- we have loaded. For example, if we mention + -- print :: Show a => a -> String + -- then we must load the decl for Show before stopping, to ensure + -- that instances from its home module are available + + go_inner (decls, bndrs, gates) wanted_name + = importDecl bndrs wanted_name `thenM` \ import_result -> case import_result of - AlreadySlurped -> returnRn (decls, fvs, gates) - InTypeEnv ty_thing -> returnRn (decls, fvs, gates `plusFV` getWiredInGates ty_thing) - - HereItIs decl -> rnIfaceTyClDecl decl `thenRn` \ (new_decl, fvs1) -> - returnRn (TyClD new_decl : decls, - fvs1 `plusFV` fvs, - gates `plusFV` getGates source_fvs new_decl) + AlreadySlurped -> returnM (decls, bndrs, gates) + + InTypeEnv ty_thing + -> returnM (decls, + bndrs `addOneFV` wanted_name, -- Avoid repeated calls to getWiredInGates + gates `plusFV` getWiredInGates ty_thing) + + HereItIs decl new_bndrs + -> rnIfaceDecl rnTyClDecl decl `thenM` \ new_decl -> + returnM (TyClD new_decl : decls, + bndrs `plusFV` new_bndrs, + gates `plusFV` getGates source_fvs new_decl) \end{code} - \begin{code} ------------------------------------------------------- --- closeDecls keeps going until the free-var set is empty -closeDecls decls needed - = slurpIfaceDecls decls needed `thenRn` \ decls1 -> - getImportedRules `thenRn` \ rule_decls -> +-- import_supporting_decls keeps going until the free-var set is empty +importSupportingDecls needed + = import_supporting_decls ([], emptyNameSet) needed + +import_supporting_decls + :: ([RenamedHsDecl], NameSet) -- Some imported decls, with their binders + -> FreeVars -- Remaining un-slurped names + -> TcRn m [RenamedHsDecl] +import_supporting_decls decls needed + = slurpIfaceDecls decls needed `thenM` \ (decls1, bndrs1) -> + getImportedRules bndrs1 `thenM` \ rule_decls -> case rule_decls of - [] -> returnRn decls1 -- No new rules, so we are done - other -> rnIfaceDecls rnIfaceRuleDecl rule_decls `thenRn` \ rule_decls' -> + [] -> returnM decls1 -- No new rules, so we are done + other -> rnIfaceDecls rnIfaceRuleDecl rule_decls `thenM` \ rule_decls' -> let - rule_fvs = plusFVs (map ruleDeclFVs rule_decls') + rule_fvs = plusFVs (map ruleDeclFVs rule_decls') + decls2 = decls1 ++ map RuleD rule_decls' in traceRn (text "closeRules" <+> ppr rule_decls' $$ - fsep (map ppr (nameSetToList rule_fvs))) `thenRn_` - closeDecls (map RuleD rule_decls' ++ decls1) rule_fvs - + fsep (map ppr (nameSetToList rule_fvs))) `thenM_` + import_supporting_decls (decls2, bndrs1) rule_fvs + ------------------------------------------------------- -- Augment decls with any decls needed by needed, -- and so on transitively -slurpIfaceDecls :: [RenamedHsDecl] -> FreeVars -> RnMG [RenamedHsDecl] -slurpIfaceDecls decls needed - = slurp decls (nameSetToList needed) +slurpIfaceDecls :: ([RenamedHsDecl], NameSet) -- Already slurped + -> FreeVars -- Still needed + -> TcRn m ([RenamedHsDecl], NameSet) +slurpIfaceDecls (decls, bndrs) needed + = slurp decls bndrs (nameSetToList needed) where - slurp decls [] = returnRn decls - slurp decls (n:ns) = slurp_one decls n `thenRn` \ decls1 -> - slurp decls1 ns - - slurp_one decls wanted_name - = importDecl wanted_name `thenRn` \ import_result -> + slurp decls bndrs [] = returnM (decls, bndrs) + slurp decls bndrs (n:ns) + = importDecl bndrs n `thenM` \ import_result -> case import_result of - HereItIs decl -> -- Found a declaration... rename it - -- and get the things it needs - rnIfaceTyClDecl decl `thenRn` \ (new_decl, fvs) -> - slurp (TyClD new_decl : decls) (nameSetToList fvs) + HereItIs decl new_bndrs -- Found a declaration... rename it + -> rnIfaceDecl rnTyClDecl decl `thenM` \ new_decl -> + slurp (TyClD new_decl : decls) + (bndrs `plusFV` new_bndrs) + (nameSetToList (tyClDeclFVs new_decl) ++ ns) other -> -- No declaration... (wired in thing, or deferred, - -- or already slurped) - returnRn decls - + -- or already slurped) + slurp decls (bndrs `addOneFV` n) ns ------------------------------------------------------- -rnIfaceDecls rn decls = mapRn (rnIfaceDecl rn) decls -rnIfaceDecl rn (mod, decl) = initIfaceRnMS mod (rn decl) +rnIfaceDecls rn decls = mappM (rnIfaceDecl rn) decls +rnIfaceDecl rn (mod, decl) = initRn (InterfaceMode mod) (rn decl) +\end{code} -rnIfaceInstDecls decls fvs gates inst_decls - = rnIfaceDecls rnInstDecl inst_decls `thenRn` \ inst_decls' -> - returnRn (map InstD inst_decls' ++ decls, - fvs `plusFV` plusFVs (map instDeclFVs inst_decls'), - gates `plusFV` plusFVs (map getInstDeclGates inst_decls')) -rnIfaceTyClDecl (mod, decl) = initIfaceRnMS mod (rnTyClDecl decl) `thenRn` \ decl' -> - returnRn (decl', tyClDeclFVs decl') +\begin{code} + -- Tiresomely, we must get the "main" name for the + -- thing, because that's what VSlurp contains, and what + -- is recorded in the usage information +get_main_name (AClass cl) = className cl +get_main_name (ATyCon tc) + | Just clas <- tyConClass_maybe tc = get_main_name (AClass clas) + | otherwise = tyConName tc +get_main_name (AnId id) + = case globalIdDetails id of + DataConId dc -> get_main_name (ATyCon (dataConTyCon dc)) + DataConWrapId dc -> get_main_name (ATyCon (dataConTyCon dc)) + RecordSelId lbl -> get_main_name (ATyCon (fieldLabelTyCon lbl)) + other -> idName id + + +recordUsage :: Name -> TcRn m () +-- Record that the Name has been used, for +-- later generation of usage info in the interface file +recordUsage name = updUsages (upd_usg name) + +upd_usg name usages + | isHomeModule mod = usages { usg_home = addOneToNameSet (usg_home usages) name } + | otherwise = usages { usg_ext = extendModuleSet (usg_ext usages) mod } + where + mod = nameModule name \end{code} +%********************************************************* +%* * +\subsection{Getting in a declaration} +%* * +%********************************************************* + \begin{code} -recordDeclSlurp ifaces@(Ifaces { iDecls = (decls_map, n_slurped), - iSlurp = slurped_names, - iVSlurp = vslurp }) - avail - = ASSERT2( not (isInternalName (availName avail)), ppr avail ) - ifaces { iDecls = (new_decls_map, n_slurped+1), - iSlurp = new_slurped_names, - iVSlurp = updateVSlurp vslurp (availName avail) } - where - new_decls_map = foldl delFromNameEnv decls_map (availNames avail) - new_slurped_names = addAvailToNameSet slurped_names avail +importDecl :: NameSet -> Name -> TcRn m ImportDeclResult +data ImportDeclResult + = AlreadySlurped + | InTypeEnv TyThing + | HereItIs (Module, RdrNameTyClDecl) NameSet + -- The NameSet is the bunch of names bound by this decl + +importDecl already_slurped name + = -- STEP 0: Check if it's from this module + -- Doing this catches a common case quickly + getModule `thenM` \ this_mod -> + if isInternalName name || nameModule name == this_mod then + -- Variables defined on the GHCi command line (e.g. let x = 3) + -- are Internal names (which don't have a Module) + returnM AlreadySlurped + else --- recordTypeEnvSlurp is used when we slurp something that's --- already in the type environment, that was not slurped in an earlier compilation. --- We record it in the iVSlurp set, because that's used to --- generate usage information + -- STEP 1: Check if we've slurped it in while compiling this module + if name `elemNameSet` already_slurped then + returnM AlreadySlurped + else -recordTypeEnvSlurp ifaces ty_thing - = ifaces { iVSlurp = updateVSlurp (iVSlurp ifaces) (get_main_name ty_thing) } - where - -- Tiresomely, we must get the "main" name for the - -- thing, because that's what VSlurp contains, and what - -- is recorded in the usage information - get_main_name (AClass cl) = className cl - get_main_name (ATyCon tc) - | Just clas <- tyConClass_maybe tc = get_main_name (AClass clas) - | otherwise = tyConName tc - get_main_name (AnId id) - = case globalIdDetails id of - DataConId dc -> get_main_name (ATyCon (dataConTyCon dc)) - DataConWrapId dc -> get_main_name (ATyCon (dataConTyCon dc)) - RecordSelId lbl -> get_main_name (ATyCon (fieldLabelTyCon lbl)) - other -> idName id - -updateVSlurp (imp_mods, imp_names) main_name - | isHomeModule mod = (imp_mods, addOneToNameSet imp_names main_name) - | otherwise = (extendModuleSet imp_mods mod, imp_names) + -- STEP 2: Check if it's already in the type environment + tcLookupGlobal_maybe name `thenM` \ maybe_thing -> + case maybe_thing of { + + Just ty_thing + | isWiredInName name + -> -- When we find a wired-in name we must load its home + -- module so that we find any instance decls lurking therein + loadHomeInterface wi_doc name `thenM_` + returnM (InTypeEnv ty_thing) + + | otherwise + -> -- We have slurp something that's already in the type environment, + -- that was not slurped in an earlier compilation. + -- Must still record it in the Usages info, because that's used to + -- generate usage information + + traceRn (text "not wired in" <+> ppr name) `thenM_` + recordUsage (get_main_name ty_thing) `thenM_` + returnM (InTypeEnv ty_thing) ; + + Nothing -> + + -- STEP 4: OK, we have to slurp it in from an interface file + -- First load the interface file + traceRn nd_doc `thenM_` + loadHomeInterface nd_doc name `thenM_` + + -- STEP 4: Get the declaration out + getEps `thenM` \ eps -> + let + (decls_map, n_slurped) = eps_decls eps + in + case lookupNameEnv decls_map name of + Just (avail,_,decl) -> setEps eps' `thenM_` + recordUsage (availName avail) `thenM_` + returnM (HereItIs decl (mkFVs avail_names)) + where + avail_names = availNames avail + new_decls_map = foldl delFromNameEnv decls_map avail_names + eps' = eps { eps_decls = (new_decls_map, n_slurped+1) } + + Nothing -> addErr (getDeclErr name) `thenM_` + returnM AlreadySlurped + } where - mod = nameModule main_name - -recordLocalSlurps new_names - = getIfacesRn `thenRn` \ ifaces -> - setIfacesRn (ifaces { iSlurp = iSlurp ifaces `unionNameSets` new_names }) -\end{code} + wi_doc = ptext SLIT("need home module for wired in thing") <+> ppr name + nd_doc = ptext SLIT("need decl for") <+> ppr name +\end{code} %********************************************************* @@ -449,7 +317,11 @@ Each has its set of 'gates': {C, T1, T2} in the above example. More precisely, the gates of a module are the types and classes that are mentioned in: - a) the source code + a) the source code [Note: in fact these don't seem + to be treated as gates, perhaps + because no imported instance decl + can mention them; mutter mutter + recursive modules.] b) the type of an Id that's mentioned in the source code [includes constructors and selectors] c) the RHS of a type synonym that is a gate @@ -458,28 +330,34 @@ that are mentioned in: We slurp in an instance decl from the gated instance pool iff - all its gates are either in the gates of the module, - or are a previously-loaded tycon or class. + all its gates are either in the gates of the module, + or the gates of a previously-loaded module The latter constraint is because there might have been an instance decl slurped in during an earlier compilation, like this: instance Foo a => Baz (Maybe a) where ... -In the module being compiled we might need (Baz (Maybe T)), where T -is defined in this module, and hence we need (Foo T). So @Foo@ becomes -a gate. But there's no way to 'see' that. More generally, types -might be involved as well: +In the module being compiled we might need (Baz (Maybe T)), where T is +defined in this module, and hence we need the instance for (Foo T). +So @Foo@ becomes a gate. But there's no way to 'see' that. More +generally, types might be involved as well: - instance Foo2 T a => Baz2 a where ... + instance Foo2 S a => Baz2 a where ... -Now we must treat T as a gate too, as well as Foo. So the solution +Now we must treat S as a gate too, as well as Foo2. So the solution we adopt is: - we simply treat all previously-loaded - tycons and classes as gates. + we simply treat the gates of all previously-loaded + modules as gates of this one + +So the gates are remembered across invocations of the renamer in the +PersistentRenamerState. This gloss mainly affects ghc --make and ghc +--interactive. -This gloss only affects ghc --make and ghc --interactive. +(We used to use the persistent type environment for this purpose, +but it has too much. For a start, it contains all tuple types, +because they are in the wired-in type env!) Consructors and class operations @@ -515,7 +393,6 @@ getGates source_fvs decl get_gates is_used (ForeignType {tcdName = tycon}) = unitNameSet tycon get_gates is_used (IfaceSig {tcdType = ty}) = extractHsTyNames ty -get_gates is_used (CoreDecl {tcdType = ty}) = extractHsTyNames ty get_gates is_used (ClassDecl { tcdCtxt = ctxt, tcdName = cls, tcdTyVars = tvs, tcdSigs = sigs}) = (super_cls_and_sigs `addOneToNameSet` cls) `unionNameSets` @@ -537,13 +414,13 @@ get_gates is_used (TyData {tcdCtxt = ctxt, tcdName = tycon, tcdTyVars = tvs, tcd (hsTyVarNames tvs) `addOneToNameSet` tycon where - get (ConDecl n _ tvs ctxt details _) + get (ConDecl n tvs ctxt details _) | is_used n -- If the constructor is method, get fvs from all its fields = delListFromNameSet (get_details details `plusFV` extractHsCtxtTyNames ctxt) (hsTyVarNames tvs) - get (ConDecl n _ tvs ctxt (RecCon fields) _) + get (ConDecl n tvs ctxt (RecCon fields) _) -- Even if the constructor isn't mentioned, the fields -- might be, as selectors. They can't mention existentially -- bound tyvars (typechecker checks for that) so no need for @@ -552,12 +429,12 @@ get_gates is_used (TyData {tcdCtxt = ctxt, tcdName = tycon, tcdTyVars = tvs, tcd get other_con = emptyFVs - get_details (VanillaCon tys) = plusFVs (map get_bang tys) + get_details (PrefixCon tys) = plusFVs (map get_bang tys) get_details (InfixCon t1 t2) = get_bang t1 `plusFV` get_bang t2 get_details (RecCon fields) = plusFVs [get_bang t | (_, t) <- fields] - get_field (fs,t) | any is_used fs = get_bang t - | otherwise = emptyFVs + get_field (f,t) | is_used f = get_bang t + | otherwise = emptyFVs get_bang bty = extractHsTyNames (getBangType bty) @@ -586,85 +463,89 @@ getWiredInGates :: TyThing -> FreeVars -- The TyThing is one that we already have in our type environment, either -- a) because the TyCon or Id is wired in, or -- b) from a previous compile +-- -- Either way, we might have instance decls in the (persistent) collection -- of parsed-but-not-slurped instance decls that should be slurped in. -- This might be the first module that mentions both the type and the class -- for that instance decl, even though both the type and the class were -- mentioned in other modules, and hence are in the type environment -getWiredInGates (AnId the_id) = namesOfType (idType the_id) -getWiredInGates (AClass cl) = implicitClassGates (getName cl) - -- The superclasses must also be previously - -- loaded, and hence are automatically gates - -- All previously-loaded classes are automatically gates - -- See "The gating story" above +getWiredInGates (AClass cl) + = unitFV (getName cl) `plusFV` mkFVs super_classes + where + super_classes = classNamesOfTheta (classSCTheta cl) + +getWiredInGates (AnId the_id) = tyClsNamesOfType (idType the_id) getWiredInGates (ATyCon tc) - | isSynTyCon tc = delListFromNameSet (namesOfType ty) (map getName tyvars) + | isSynTyCon tc = tyClsNamesOfType ty | otherwise = unitFV (getName tc) where - (tyvars,ty) = getSynTyConDefn tc + (_,ty) = getSynTyConDefn tc getInstDeclGates (InstDecl inst_ty _ _ _ _) = extractHsTyNames inst_ty \end{code} \begin{code} -getImportedInstDecls :: NameSet -> RnMG [(Module,RdrNameInstDecl)] +getImportedInstDecls :: NameSet -> TcRn m ([(Module,RdrNameInstDecl)], NameSet) + -- Returns the gates that are new since last time getImportedInstDecls gates = -- First, load any orphan-instance modules that aren't aready loaded -- Orphan-instance modules are recorded in the module dependecnies - getIfacesRn `thenRn` \ ifaces -> + getEps `thenM` \ eps -> let - orphan_mods = - [mod | (mod, (True, _)) <- fmToList (iImpModInfo ifaces)] + old_gates = eps_inst_gates eps + new_gates = gates `minusNameSet` old_gates + all_gates = new_gates `unionNameSets` old_gates + orphan_mods = [mod | (mod, (True, _)) <- fmToList (eps_imp_mods eps)] in - loadOrphanModules orphan_mods `thenRn_` + loadOrphanModules orphan_mods `thenM_` -- Now we're ready to grab the instance declarations -- Find the un-gated ones and return them, - -- removing them from the bag kept in Ifaces - getIfacesRn `thenRn` \ ifaces -> - getTypeEnvRn `thenRn` \ lookup -> + -- removing them from the bag kept in EPS + -- Don't foget to get the EPS a second time... + -- loadOrphanModules may have side-effected it! + getEps `thenM` \ eps -> let - available n = n `elemNameSet` gates || isJust (lookup n) - -- See "The gating story" above for the isJust thing - - (decls, new_insts) = selectGated available (iInsts ifaces) + available n = n `elemNameSet` all_gates + (decls, new_insts) = selectGated available (eps_insts eps) in - setIfacesRn (ifaces { iInsts = new_insts }) `thenRn_` + setEps (eps { eps_insts = new_insts, + eps_inst_gates = all_gates }) `thenM_` traceRn (sep [text "getImportedInstDecls:", - nest 4 (fsep (map ppr gate_list)), + nest 4 (fsep (map ppr (nameSetToList gates))), + nest 4 (fsep (map ppr (nameSetToList all_gates))), + nest 4 (fsep (map ppr (nameSetToList new_gates))), text "Slurped" <+> int (length decls) <+> text "instance declarations", - nest 4 (vcat (map ppr_brief_inst_decl decls))]) `thenRn_` - returnRn decls - where - gate_list = nameSetToList gates + nest 4 (vcat (map ppr_brief_inst_decl decls))]) `thenM_` + returnM (decls, new_gates) ppr_brief_inst_decl (mod, InstDecl inst_ty _ _ _ _) = case inst_ty of HsForAllTy _ _ tau -> ppr tau other -> ppr inst_ty -getImportedRules :: RnMG [(Module,RdrNameRuleDecl)] -getImportedRules - | opt_IgnoreIfacePragmas = returnRn [] +getImportedRules :: NameSet -- Slurped already + -> TcRn m [(Module,RdrNameRuleDecl)] +getImportedRules slurped + | opt_IgnoreIfacePragmas = returnM [] | otherwise - = getIfacesRn `thenRn` \ ifaces -> - getTypeEnvRn `thenRn` \ lookup -> + = getEps `thenM` \ eps -> + getInGlobalScope `thenM` \ in_type_env -> let -- Slurp rules for anything that is slurped, - -- either now or previously - gates = iSlurp ifaces - available n = n `elemNameSet` gates || isJust (lookup n) - (decls, new_rules) = selectGated available (iRules ifaces) + -- either now, or previously + available n = n `elemNameSet` slurped || in_type_env n + (decls, new_rules) = selectGated available (eps_rules eps) in if null decls then - returnRn [] + returnM [] else - setIfacesRn (ifaces { iRules = new_rules }) `thenRn_` + setEps (eps { eps_rules = new_rules }) `thenM_` traceRn (sep [text "getImportedRules:", - text "Slurped" <+> int (length decls) <+> text "rules"]) `thenRn_` - returnRn decls + text "Slurped" <+> int (length decls) <+> text "rules"]) `thenM_` + returnM decls selectGated :: (Name->Bool) -> GatedDecls d -> ([(Module,d)], GatedDecls d) @@ -688,70 +569,6 @@ selectGated available (decl_bag, n_slurped) \end{code} -%********************************************************* -%* * -\subsection{Getting in a declaration} -%* * -%********************************************************* - -\begin{code} -importDecl :: Name -> RnMG ImportDeclResult - -data ImportDeclResult - = AlreadySlurped - | InTypeEnv TyThing - | HereItIs (Module, RdrNameTyClDecl) - -importDecl name - = -- STEP 1: Check if we've slurped it in while compiling this module - getIfacesRn `thenRn` \ ifaces -> - if name `elemNameSet` iSlurp ifaces then - returnRn AlreadySlurped - else - - - -- STEP 2: Check if it's already in the type environment - getTypeEnvRn `thenRn` \ lookup -> - case lookup name of { - Just ty_thing - | name `elemNameEnv` wiredInThingEnv - -> -- When we find a wired-in name we must load its home - -- module so that we find any instance decls lurking therein - loadHomeInterface wi_doc name `thenRn_` - returnRn (InTypeEnv ty_thing) - - | otherwise - -> -- Very important: record that we've seen it - -- See comments with recordTypeEnvSlurp - setIfacesRn (recordTypeEnvSlurp ifaces ty_thing) `thenRn_` - returnRn (InTypeEnv ty_thing) ; - - Nothing -> - - -- STEP 3: OK, we have to slurp it in from an interface file - -- First load the interface file - traceRn nd_doc `thenRn_` - loadHomeInterface nd_doc name `thenRn_` - getIfacesRn `thenRn` \ ifaces -> - - -- STEP 4: Get the declaration out - let - (decls_map, _) = iDecls ifaces - in - case lookupNameEnv decls_map name of - Just (avail,_,decl) -> setIfacesRn (recordDeclSlurp ifaces avail) `thenRn_` - returnRn (HereItIs decl) - - Nothing -> addErrRn (getDeclErr name) `thenRn_` - returnRn AlreadySlurped - } - where - wi_doc = ptext SLIT("need home module for wired in thing") <+> ppr name - nd_doc = ptext SLIT("need decl for") <+> ppr name - -\end{code} - - %******************************************************** %* * \subsection{Checking usage information} @@ -768,26 +585,30 @@ type RecompileRequired = Bool upToDate = False -- Recompile not required outOfDate = True -- Recompile required -recompileRequired :: FilePath -- Only needed for debug msgs - -> ModIface -- Old interface - -> RnMG RecompileRequired -recompileRequired iface_path iface - = traceHiDiffsRn (text "Considering whether compilation is required for" <+> text iface_path <> colon) `thenRn_` +checkVersions :: Bool -- True <=> source unchanged + -> ModIface -- Old interface + -> TcRn m RecompileRequired +checkVersions source_unchanged iface + | not source_unchanged + = returnM outOfDate + | otherwise + = traceHiDiffs (text "Considering whether compilation is required for" <+> + ppr (mi_module iface) <> colon) `thenM_` -- Source code unchanged and no errors yet... carry on checkList [checkModUsage u | u <- mi_usages iface] -checkList :: [RnMG RecompileRequired] -> RnMG RecompileRequired -checkList [] = returnRn upToDate -checkList (check:checks) = check `thenRn` \ recompile -> +checkList :: [TcRn m RecompileRequired] -> TcRn m RecompileRequired +checkList [] = returnM upToDate +checkList (check:checks) = check `thenM` \ recompile -> if recompile then - returnRn outOfDate + returnM outOfDate else checkList checks \end{code} \begin{code} -checkModUsage :: ImportVersion Name -> RnMG RecompileRequired +checkModUsage :: ImportVersion Name -> TcRn m RecompileRequired -- Given the usage information extracted from the old -- M.hi file for the module being compiled, figure out -- whether M needs to be recompiled. @@ -804,76 +625,81 @@ checkModUsage (mod_name, _, is_boot, whats_imported) = -- Load the imported interface is possible -- We use tryLoadInterface, because failure is not an error -- (might just be that the old .hi file for this module is out of date) - -- We use ImportByUser/ImportByUserSource as the 'from' flag, - -- a) because we need to know whether to load the .hi-boot file - -- b) because loadInterface things matters are amiss if we - -- ImportBySystem an interface it knows nothing about let doc_str = sep [ptext SLIT("need version info for"), ppr mod_name] - from | is_boot = ImportByUserSource - | otherwise = ImportByUser + from = ImportForUsage is_boot in - traceHiDiffsRn (text "Checking usages for module" <+> ppr mod_name) `thenRn_` - tryLoadInterface doc_str mod_name from `thenRn` \ (iface, maybe_err) -> + traceHiDiffs (text "Checking usages for module" <+> ppr mod_name) `thenM_` - case maybe_err of { - Just err -> out_of_date (sep [ptext SLIT("Can't find version number for module"), - ppr mod_name]) ; + recoverM (returnM Nothing) + (loadInterface doc_str mod_name from `thenM` \ iface -> + returnM (Just iface)) `thenM` \ mb_iface -> + + case mb_iface of { + Nothing -> (out_of_date (sep [ptext SLIT("Can't find version number for module"), + ppr mod_name])); -- Couldn't find or parse a module mentioned in the -- old interface file. Don't complain -- it might just be that -- the current module doesn't need that import and it's been deleted - Nothing -> + Just iface -> let - new_vers = mi_version iface - new_decl_vers = vers_decls new_vers + new_vers = mi_version iface + new_mod_vers = vers_module new_vers + new_decl_vers = vers_decls new_vers + new_export_vers = vers_exports new_vers + new_rule_vers = vers_rules new_vers in case whats_imported of { -- NothingAtAll dealt with earlier - Everything old_mod_vers -> checkModuleVersion old_mod_vers new_vers `thenRn` \ recompile -> + Everything old_mod_vers -> checkModuleVersion old_mod_vers new_mod_vers `thenM` \ recompile -> if recompile then out_of_date (ptext SLIT("...and I needed the whole module")) else - returnRn upToDate ; + returnM upToDate ; Specifically old_mod_vers maybe_old_export_vers old_decl_vers old_rule_vers -> -- CHECK MODULE - checkModuleVersion old_mod_vers new_vers `thenRn` \ recompile -> + checkModuleVersion old_mod_vers new_mod_vers `thenM` \ recompile -> if not recompile then - returnRn upToDate + returnM upToDate else -- CHECK EXPORT LIST - if checkExportList maybe_old_export_vers new_vers then - out_of_date (ptext SLIT("Export list changed")) + if checkExportList maybe_old_export_vers new_export_vers then + out_of_date_vers (ptext SLIT(" Export list changed")) + (fromJust maybe_old_export_vers) + new_export_vers else -- CHECK RULES - if old_rule_vers /= vers_rules new_vers then - out_of_date (ptext SLIT("Rules changed")) + if old_rule_vers /= new_rule_vers then + out_of_date_vers (ptext SLIT(" Rules changed")) + old_rule_vers new_rule_vers else -- CHECK ITEMS ONE BY ONE - checkList [checkEntityUsage new_decl_vers u | u <- old_decl_vers] `thenRn` \ recompile -> + checkList [checkEntityUsage new_decl_vers u | u <- old_decl_vers] `thenM` \ recompile -> if recompile then - returnRn outOfDate -- This one failed, so just bail out now + returnM outOfDate -- This one failed, so just bail out now else - up_to_date (ptext SLIT("...but the bits I use haven't.")) + up_to_date (ptext SLIT(" Great! The bits I use are up to date")) }} ------------------------ -checkModuleVersion old_mod_vers new_vers - | vers_module new_vers == old_mod_vers +checkModuleVersion old_mod_vers new_mod_vers + | new_mod_vers == old_mod_vers = up_to_date (ptext SLIT("Module version unchanged")) | otherwise - = out_of_date (ptext SLIT("Module version has changed")) + = out_of_date_vers (ptext SLIT(" Module version has changed")) + old_mod_vers new_mod_vers ------------------------ checkExportList Nothing new_vers = upToDate -checkExportList (Just v) new_vers = v /= vers_exports new_vers +checkExportList (Just v) new_vers = v /= new_vers ------------------------ checkEntityUsage new_vers (name,old_vers) @@ -883,13 +709,15 @@ checkEntityUsage new_vers (name,old_vers) out_of_date (sep [ptext SLIT("No longer exported:"), ppr name]) Just new_vers -- It's there, but is it up to date? - | new_vers == old_vers -> traceHiDiffsRn (text "Up to date" <+> ppr name <+> parens (ppr new_vers)) `thenRn_` - returnRn upToDate - | otherwise -> out_of_date (sep [ptext SLIT("Out of date:"), ppr name, ppr - old_vers, ptext SLIT("->"), ppr new_vers]) - -up_to_date msg = traceHiDiffsRn msg `thenRn_` returnRn upToDate -out_of_date msg = traceHiDiffsRn msg `thenRn_` returnRn outOfDate + | new_vers == old_vers -> traceHiDiffs (text " Up to date" <+> ppr name <+> parens (ppr new_vers)) `thenM_` + returnM upToDate + | otherwise -> out_of_date_vers (ptext SLIT(" Out of date:") <+> ppr name) + old_vers new_vers + +up_to_date msg = traceHiDiffs msg `thenM_` returnM upToDate +out_of_date msg = traceHiDiffs msg `thenM_` returnM outOfDate +out_of_date_vers msg old_vers new_vers + = out_of_date (hsep [msg, ppr old_vers, ptext SLIT("->"), ppr new_vers]) \end{code} diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs deleted file mode 100644 index 254b8eceac..0000000000 --- a/ghc/compiler/rename/RnMonad.lhs +++ /dev/null @@ -1,760 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -\section[RnMonad]{The monad used by the renamer} - -\begin{code} -module RnMonad( - module RnMonad, - - module RdrName, -- Re-exports - module Name, -- from these two - - Module, - FiniteMap, - Bag, - RdrNameHsDecl, - RdrNameInstDecl, - Version, - NameSet, - OccName, - Fixity - ) where - -#include "HsVersions.h" - -import HsSyn -import RdrHsSyn -import RnHsSyn ( RenamedFixitySig ) -import HscTypes ( AvailEnv, emptyAvailEnv, lookupType, - NameSupply(..), - ImportedModuleInfo, WhetherHasOrphans, ImportVersion, - PersistentRenamerState(..), RdrExportItem, - DeclsMap, IfaceInsts, IfaceRules, - HomeSymbolTable, TyThing, - PersistentCompilerState(..), GlobalRdrEnv, - LocalRdrEnv, - HomeIfaceTable, PackageIfaceTable ) -import BasicTypes ( Version, defaultFixity, - Fixity(..), FixityDirection(..) ) -import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, - Message, Messages, errorsFound, warningsFound, - printErrorsAndWarnings - ) -import RdrName ( RdrName, dummyRdrVarName, rdrNameModule, rdrNameOcc, - RdrNameEnv, emptyRdrEnv, extendRdrEnv, - addListToRdrEnv, rdrEnvToList, rdrEnvElts - ) -import Id ( idName ) -import MkId ( seqId ) -import Name ( Name, OccName, NamedThing(..), - nameOccName, nameRdrName, - decode, mkInternalName - ) -import NameEnv ( NameEnv, lookupNameEnv, emptyNameEnv, - extendNameEnvList ) -import Module ( Module, ModuleName, ModuleSet, emptyModuleSet, - PackageName, preludePackage ) -import PrelInfo ( ghcPrimExports, - cCallableClassDecl, cReturnableClassDecl, assertDecl ) -import PrelNames ( mkUnboundName, gHC_PRIM_Name ) -import NameSet -import CmdLineOpts ( DynFlags, DynFlag(..), dopt ) -import SrcLoc ( SrcLoc, generatedSrcLoc, noSrcLoc ) -import Unique ( Unique ) -import FiniteMap ( FiniteMap ) -import Maybes ( seqMaybe ) -import Bag ( Bag, emptyBag, isEmptyBag, snocBag ) -import UniqSupply -import Outputable - -import DATA_IOREF ( IORef, newIORef, readIORef, writeIORef ) -import UNSAFE_IO ( unsafePerformIO ) -import FIX_IO ( fixIO ) - -import IO ( hPutStr, stderr ) - -infixr 9 `thenRn`, `thenRn_` -\end{code} - - -%************************************************************************ -%* * -\subsection{Somewhat magical interface to other monads} -%* * -%************************************************************************ - -\begin{code} -ioToRnM :: IO r -> RnM d (Either IOError r) -ioToRnM io rn_down g_down = (io >>= \ ok -> return (Right ok)) - `catch` - (\ err -> return (Left err)) - -ioToRnM_no_fail :: IO r -> RnM d r -ioToRnM_no_fail io rn_down g_down - = (io >>= \ ok -> return ok) - `catch` - (\ err -> panic "ioToRnM_no_fail: the I/O operation failed!") - -traceRn :: SDoc -> RnM d () -traceRn msg = ifOptRn Opt_D_dump_rn_trace (putDocRn msg) - -traceHiDiffsRn :: SDoc -> RnM d () -traceHiDiffsRn msg = ifOptRn Opt_D_dump_hi_diffs (putDocRn msg) - -putDocRn :: SDoc -> RnM d () -putDocRn msg = ioToRnM (printErrs alwaysQualify msg) `thenRn_` - returnRn () -\end{code} - - -%************************************************************************ -%* * -\subsection{Data types} -%* * -%************************************************************************ - -%=================================================== -\subsubsection{ MONAD TYPES} -%=================================================== - -\begin{code} -type RnM d r = RnDown -> d -> IO r -type RnMS r = RnM SDown r -- Renaming source -type RnMG r = RnM () r -- Getting global names etc - - -- Common part -data RnDown - = RnDown { - rn_mod :: Module, -- This module - rn_loc :: SrcLoc, -- Current locn - - rn_dflags :: DynFlags, - - rn_hit :: HomeIfaceTable, - rn_done :: Name -> Maybe TyThing, -- Tells what things (both in the - -- home package and other packages) - -- were already available (i.e. in - -- the relevant SymbolTable) before - -- compiling this module - -- The Name passed to rn_done is guaranteed to be a Global, - -- so it has a Module, so it can be looked up - - rn_errs :: IORef Messages, - rn_ns :: IORef NameSupply, - rn_ifaces :: IORef Ifaces - } - - -- For renaming source code -data SDown = SDown { - rn_mode :: RnMode, - - rn_genv :: GlobalRdrEnv, -- Top level environment - - rn_avails :: AvailEnv, - -- Top level AvailEnv; contains all the things that - -- are nameable in the top-level scope, regardless of - -- *how* they can be named (qualified, unqualified...) - -- It is used only to map a Class to its class ops, and - -- hence to resolve the binders in an instance decl - - rn_lenv :: LocalRdrEnv, -- Local name envt - -- Does *not* include global name envt; may shadow it - -- Includes both ordinary variables and type variables; - -- they are kept distinct because tyvar have a different - -- occurrence contructor (Name.TvOcc) - -- We still need the unsullied global name env so that - -- we can look up record field names - - rn_fixenv :: LocalFixityEnv -- Local fixities (for non-top-level - -- declarations) - -- The global fixities are held in the - -- HIT or PIT. Why? See the comments - -- with RnIfaces.lookupLocalFixity - } - -data RnMode = SourceMode -- Renaming source code - | InterfaceMode -- Renaming interface declarations. - | CmdLineMode -- Renaming a command-line expression - -isInterfaceMode InterfaceMode = True -isInterfaceMode _ = False - -isCmdLineMode CmdLineMode = True -isCmdLineMode _ = False -\end{code} - -\begin{code} -type LocalFixityEnv = NameEnv RenamedFixitySig - -- We keep the whole fixity sig so that we - -- can report line-number info when there is a duplicate - -- fixity declaration - -emptyLocalFixityEnv :: LocalFixityEnv -emptyLocalFixityEnv = emptyNameEnv -\end{code} - - -%************************************************************************ -%* * -\subsection{Interface file stuff} -%* * -%************************************************************************ - -\begin{code} -type IfaceDeprecs = Maybe (Either DeprecTxt [(RdrName,DeprecTxt)]) - -- Nothing => NoDeprecs - -- Just (Left t) => DeprecAll - -- Just (Right p) => DeprecSome - -data ParsedIface - = ParsedIface { - pi_mod :: ModuleName, - pi_pkg :: PackageName, - pi_vers :: Version, -- Module version number - pi_orphan :: WhetherHasOrphans, -- Whether this module has orphans - pi_usages :: [ImportVersion OccName], -- Usages - pi_exports :: (Version, [RdrExportItem]), -- Exports - pi_decls :: [(Version, RdrNameTyClDecl)], -- Local definitions - pi_fixity :: [(RdrName,Fixity)], -- Local fixity declarations, - pi_insts :: [RdrNameInstDecl], -- Local instance declarations - pi_rules :: (Version, [RdrNameRuleDecl]), -- Rules, with their version - pi_deprecs :: IfaceDeprecs -- Deprecations - } -\end{code} - -%************************************************************************ -%* * -\subsection{Wired-in interfaces} -%* * -%************************************************************************ - -\begin{code} -ghcPrimIface :: ParsedIface -ghcPrimIface = ParsedIface { - pi_mod = gHC_PRIM_Name, - pi_pkg = preludePackage, - pi_vers = 1, - pi_orphan = False, - pi_usages = [], - pi_exports = (1, [(gHC_PRIM_Name, ghcPrimExports)]), - pi_decls = [(1,cCallableClassDecl), - (1,cReturnableClassDecl), - (1,assertDecl)], - pi_fixity = [(nameRdrName (idName seqId), Fixity 0 InfixR)], - -- seq is infixr 0 - pi_insts = [], - pi_rules = (1,[]), - pi_deprecs = Nothing - } -\end{code} - -%************************************************************************ -%* * -\subsection{The renamer state} -%* * -%************************************************************************ - -\begin{code} -data Ifaces = Ifaces { - -- PERSISTENT FIELDS - iPIT :: PackageIfaceTable, - -- The ModuleIFaces for modules in other packages - -- whose interfaces we have opened - -- The declarations in these interface files are held in - -- iDecls, iInsts, iRules (below), not in the mi_decls fields - -- of the iPIT. What _is_ in the iPIT is: - -- * The Module - -- * Version info - -- * Its exports - -- * Fixities - -- * Deprecations - -- The iPIT field is initialised from the compiler's persistent - -- package symbol table, and the renamer incrementally adds - -- to it. - - iImpModInfo :: ImportedModuleInfo, - -- Modules that we know something about, because they are mentioned - -- in interface files, BUT which we have not loaded yet. - -- No module is both in here and in the PIT - - iDecls :: DeclsMap, - -- A single, global map of Names to unslurped decls - - iInsts :: IfaceInsts, - -- The as-yet un-slurped instance decls; this bag is depleted when we - -- slurp an instance decl so that we don't slurp the same one twice. - -- Each is 'gated' by the names that must be available before - -- this instance decl is needed. - - iRules :: IfaceRules, - -- Similar to instance decls, only for rules - - -- EPHEMERAL FIELDS - -- These fields persist during the compilation of a single module only - iSlurp :: NameSet, - -- All the names (whether "big" or "small", whether wired-in or not, - -- whether locally defined or not) that have been slurped in so far. - -- - -- It's used for two things: - -- a) To record what we've already slurped, so - -- we can no-op if we try to slurp it again - -- b) As the 'gates' for importing rules. We import a rule - -- if all its LHS free vars have been slurped - - iVSlurp :: (ModuleSet, NameSet) - -- The Names are all the (a) non-wired-in - -- (b) "big" - -- (c) non-locally-defined - -- (d) home-package - -- names that have been slurped in so far, with their versions. - -- This is used to generate the "usage" information for this module. - -- Subset of the previous field. - -- - -- The module set is the non-home-package modules from which we have - -- slurped at least one name. - -- It's worth keeping separately, because there's no very easy - -- way to distinguish the "big" names from the "non-big" ones. - -- But this is a decision we might want to revisit. - } -\end{code} - - -%************************************************************************ -%* * -\subsection{Main monad code} -%* * -%************************************************************************ - -\begin{code} -runRn dflags hit hst pcs mod do_rn - = do { (pcs, msgs, r) <- initRn dflags hit hst pcs mod do_rn ; - printErrorsAndWarnings alwaysQualify msgs ; - return (pcs, errorsFound msgs, r) - } - -initRn :: DynFlags - -> HomeIfaceTable -> HomeSymbolTable - -> PersistentCompilerState - -> Module - -> RnMG t - -> IO (PersistentCompilerState, Messages, t) - -initRn dflags hit hst pcs mod do_rn - = do - let prs = pcs_PRS pcs - let pte = pcs_PTE pcs - let ifaces = Ifaces { iPIT = pcs_PIT pcs, - iDecls = prsDecls prs, - iInsts = prsInsts prs, - iRules = prsRules prs, - - iImpModInfo = prsImpMods prs, - iSlurp = unitNameSet (mkUnboundName dummyRdrVarName), - -- Pretend that the dummy unbound name has already been - -- slurped. This is what's returned for an out-of-scope name, - -- and we don't want thereby to try to suck it in! - iVSlurp = (emptyModuleSet, emptyNameSet) - } - names_var <- newIORef (prsOrig prs) - errs_var <- newIORef (emptyBag,emptyBag) - iface_var <- newIORef ifaces - let rn_down = RnDown { rn_mod = mod, - rn_loc = noSrcLoc, - - rn_dflags = dflags, - rn_hit = hit, - rn_done = lookupType hst pte, - - rn_ns = names_var, - rn_errs = errs_var, - rn_ifaces = iface_var, - } - - -- do the business - res <- do_rn rn_down () - - -- Grab state and record it - (warns, errs) <- readIORef errs_var - new_ifaces <- readIORef iface_var - new_orig <- readIORef names_var - let new_prs = prs { prsOrig = new_orig, - prsImpMods = iImpModInfo new_ifaces, - prsDecls = iDecls new_ifaces, - prsInsts = iInsts new_ifaces, - prsRules = iRules new_ifaces } - let new_pcs = pcs { pcs_PIT = iPIT new_ifaces, - pcs_PRS = new_prs } - - return (new_pcs, (warns, errs), res) - -initRnMS :: GlobalRdrEnv -> AvailEnv -> LocalRdrEnv -> LocalFixityEnv -> RnMode - -> RnMS a -> RnM d a - -initRnMS rn_env avails local_env fixity_env mode thing_inside rn_down g_down - -- The fixity_env appears in both the rn_fixenv field - -- and in the HIT. See comments with RnHiFiles.lookupFixityRn - = let - s_down = SDown { rn_genv = rn_env, rn_avails = avails, - rn_lenv = local_env, rn_fixenv = fixity_env, - rn_mode = mode } - in - thing_inside rn_down s_down - -initIfaceRnMS :: Module -> RnMS r -> RnM d r -initIfaceRnMS mod thing_inside - = initRnMS emptyRdrEnv emptyAvailEnv emptyRdrEnv - emptyLocalFixityEnv InterfaceMode - (setModuleRn mod thing_inside) -\end{code} - -@renameDerivedCode@ is used to rename stuff ``out-of-line''; -that is, not as part of the main renamer. -Sole examples: derived definitions, -which are only generated in the type checker. - -The @NameSupply@ includes a @UniqueSupply@, so if you call it more than -once you must either split it, or install a fresh unique supply. - -\begin{code} -renameDerivedCode :: DynFlags - -> Module - -> PersistentRenamerState - -> RnMS r - -> r - -renameDerivedCode dflags mod prs thing_inside - = unsafePerformIO $ - -- It's not really unsafe! When renaming source code we - -- only do any I/O if we need to read in a fixity declaration; - -- and that doesn't happen in pragmas etc - - do { us <- mkSplitUniqSupply 'r' - ; names_var <- newIORef ((prsOrig prs) { nsUniqs = us }) - ; errs_var <- newIORef (emptyBag,emptyBag) - - ; let rn_down = RnDown { rn_dflags = dflags, - rn_loc = generatedSrcLoc, rn_ns = names_var, - rn_errs = errs_var, - rn_mod = mod, - rn_done = bogus "rn_done", - rn_hit = bogus "rn_hit", - rn_ifaces = bogus "rn_ifaces" - } - ; let s_down = SDown { rn_mode = InterfaceMode, - -- So that we can refer to PrelBase.True etc - rn_avails = emptyAvailEnv, - rn_genv = emptyRdrEnv, rn_lenv = emptyRdrEnv, - rn_fixenv = emptyLocalFixityEnv } - - ; result <- thing_inside rn_down s_down - ; messages <- readIORef errs_var - - ; if bad messages then - do { hPutStr stderr "Urk! renameDerivedCode found errors or warnings" - ; printErrorsAndWarnings alwaysQualify messages - } - else - return() - - ; return result - } - where -#ifdef DEBUG - bad messages = errorsFound messages || warningsFound messages -#else - bad messages = errorsFound messages -#endif - -bogus s = panic ("rnameSourceCode: " ++ s) -- Used for unused record fields - -{-# INLINE thenRn #-} -{-# INLINE thenRn_ #-} -{-# INLINE returnRn #-} -{-# INLINE andRn #-} - -returnRn :: a -> RnM d a -thenRn :: RnM d a -> (a -> RnM d b) -> RnM d b -thenRn_ :: RnM d a -> RnM d b -> RnM d b -andRn :: (a -> a -> a) -> RnM d a -> RnM d a -> RnM d a -mapRn :: (a -> RnM d b) -> [a] -> RnM d [b] -mapRn_ :: (a -> RnM d b) -> [a] -> RnM d () -mapMaybeRn :: (a -> RnM d (Maybe b)) -> [a] -> RnM d [b] -flatMapRn :: (a -> RnM d [b]) -> [a] -> RnM d [b] -sequenceRn :: [RnM d a] -> RnM d [a] -sequenceRn_ :: [RnM d a] -> RnM d () -foldlRn :: (b -> a -> RnM d b) -> b -> [a] -> RnM d b -mapAndUnzipRn :: (a -> RnM d (b,c)) -> [a] -> RnM d ([b],[c]) -fixRn :: (a -> RnM d a) -> RnM d a - -returnRn v gdown ldown = return v -thenRn m k gdown ldown = m gdown ldown >>= \ r -> k r gdown ldown -thenRn_ m k gdown ldown = m gdown ldown >> k gdown ldown -fixRn m gdown ldown = fixIO (\r -> m r gdown ldown) -andRn combiner m1 m2 gdown ldown - = m1 gdown ldown >>= \ res1 -> - m2 gdown ldown >>= \ res2 -> - return (combiner res1 res2) - -sequenceRn [] = returnRn [] -sequenceRn (m:ms) = m `thenRn` \ r -> - sequenceRn ms `thenRn` \ rs -> - returnRn (r:rs) - -sequenceRn_ [] = returnRn () -sequenceRn_ (m:ms) = m `thenRn_` sequenceRn_ ms - -mapRn f [] = returnRn [] -mapRn f (x:xs) - = f x `thenRn` \ r -> - mapRn f xs `thenRn` \ rs -> - returnRn (r:rs) - -mapRn_ f [] = returnRn () -mapRn_ f (x:xs) = - f x `thenRn_` - mapRn_ f xs - -foldlRn k z [] = returnRn z -foldlRn k z (x:xs) = k z x `thenRn` \ z' -> - foldlRn k z' xs - -mapAndUnzipRn f [] = returnRn ([],[]) -mapAndUnzipRn f (x:xs) - = f x `thenRn` \ (r1, r2) -> - mapAndUnzipRn f xs `thenRn` \ (rs1, rs2) -> - returnRn (r1:rs1, r2:rs2) - -mapAndUnzip3Rn f [] = returnRn ([],[],[]) -mapAndUnzip3Rn f (x:xs) - = f x `thenRn` \ (r1, r2, r3) -> - mapAndUnzip3Rn f xs `thenRn` \ (rs1, rs2, rs3) -> - returnRn (r1:rs1, r2:rs2, r3:rs3) - -mapMaybeRn f [] = returnRn [] -mapMaybeRn f (x:xs) = f x `thenRn` \ maybe_r -> - mapMaybeRn f xs `thenRn` \ rs -> - case maybe_r of - Nothing -> returnRn rs - Just r -> returnRn (r:rs) - -flatMapRn f [] = returnRn [] -flatMapRn f (x:xs) = f x `thenRn` \ r -> - flatMapRn f xs `thenRn` \ rs -> - returnRn (r ++ rs) -\end{code} - - - -%************************************************************************ -%* * -\subsection{Boring plumbing for common part} -%* * -%************************************************************************ - - -%================ -\subsubsection{ Errors and warnings} -%===================== - -\begin{code} -failWithRn :: a -> Message -> RnM d a -failWithRn res msg (RnDown {rn_errs = errs_var, rn_loc = loc}) l_down - = readIORef errs_var >>= \ (warns,errs) -> - writeIORef errs_var (warns, errs `snocBag` err) >> - return res - where - err = addShortErrLocLine loc msg - -warnWithRn :: a -> Message -> RnM d a -warnWithRn res msg (RnDown {rn_errs = errs_var, rn_loc = loc}) l_down - = readIORef errs_var >>= \ (warns,errs) -> - writeIORef errs_var (warns `snocBag` warn, errs) >> - return res - where - warn = addShortWarnLocLine loc msg - -tryRn :: RnM d a -> RnM d (Either Messages a) -tryRn try_this down@(RnDown {rn_errs = errs_var}) l_down - = do current_msgs <- readIORef errs_var - writeIORef errs_var (emptyBag,emptyBag) - a <- try_this down l_down - (warns, errs) <- readIORef errs_var - writeIORef errs_var current_msgs - if (isEmptyBag errs) - then return (Right a) - else return (Left (warns,errs)) - -setErrsRn :: Messages -> RnM d () -setErrsRn msgs down@(RnDown {rn_errs = errs_var}) l_down - = do writeIORef errs_var msgs; return () - -addErrRn :: Message -> RnM d () -addErrRn err = failWithRn () err - -checkRn :: Bool -> Message -> RnM d () -- Check that a condition is true -checkRn False err = addErrRn err -checkRn True err = returnRn () - -warnCheckRn :: Bool -> Message -> RnM d () -- Check that a condition is true -warnCheckRn False err = addWarnRn err -warnCheckRn True err = returnRn () - -addWarnRn :: Message -> RnM d () -addWarnRn warn = warnWithRn () warn - -checkErrsRn :: RnM d Bool -- True <=> no errors so far -checkErrsRn (RnDown {rn_errs = errs_var}) l_down - = readIORef errs_var >>= \ (warns,errs) -> - return (isEmptyBag errs) - -doptRn :: DynFlag -> RnM d Bool -doptRn dflag (RnDown { rn_dflags = dflags}) l_down - = return (dopt dflag dflags) - -ifOptRn :: DynFlag -> RnM d a -> RnM d () -ifOptRn dflag thing_inside down@(RnDown { rn_dflags = dflags}) l_down - | dopt dflag dflags = thing_inside down l_down >> return () - | otherwise = return () - -getDOptsRn :: RnM d DynFlags -getDOptsRn (RnDown { rn_dflags = dflags}) l_down - = return dflags -\end{code} - - -%================ -\subsubsection{Source location} -%===================== - -\begin{code} -pushSrcLocRn :: SrcLoc -> RnM d a -> RnM d a -pushSrcLocRn loc' m down l_down - = m (down {rn_loc = loc'}) l_down - -getSrcLocRn :: RnM d SrcLoc -getSrcLocRn down l_down - = return (rn_loc down) -\end{code} - -%================ -\subsubsection{The finder and home symbol table} -%===================== - -\begin{code} -getHomeIfaceTableRn :: RnM d HomeIfaceTable -getHomeIfaceTableRn down l_down = return (rn_hit down) - -getTypeEnvRn :: RnM d (Name -> Maybe TyThing) -getTypeEnvRn down l_down = return (rn_done down) - -extendTypeEnvRn :: NameEnv TyThing -> RnM d a -> RnM d a -extendTypeEnvRn env inside down l_down - = inside down{rn_done=new_rn_done} l_down - where new_rn_done = \nm -> lookupNameEnv env nm `seqMaybe` rn_done down nm -\end{code} - -%================ -\subsubsection{Name supply} -%===================== - -\begin{code} -getNameSupplyRn :: RnM d NameSupply -getNameSupplyRn rn_down l_down - = readIORef (rn_ns rn_down) - -setNameSupplyRn :: NameSupply -> RnM d () -setNameSupplyRn names' (RnDown {rn_ns = names_var}) l_down - = writeIORef names_var names' - -getUniqRn :: RnM d Unique -getUniqRn (RnDown {rn_ns = names_var}) l_down - = readIORef names_var >>= \ ns -> - let - (us1,us') = splitUniqSupply (nsUniqs ns) - in - writeIORef names_var (ns {nsUniqs = us'}) >> - return (uniqFromSupply us1) -\end{code} - -%================ -\subsubsection{ Module} -%===================== - -\begin{code} -getModuleRn :: RnM d Module -getModuleRn (RnDown {rn_mod = mod}) l_down - = return mod - -setModuleRn :: Module -> RnM d a -> RnM d a -setModuleRn new_mod enclosed_thing rn_down l_down - = enclosed_thing (rn_down {rn_mod = new_mod}) l_down -\end{code} - - -%************************************************************************ -%* * -\subsection{Plumbing for rename-source part} -%* * -%************************************************************************ - -%================ -\subsubsection{ RnEnv} -%===================== - -\begin{code} -getLocalNameEnv :: RnMS LocalRdrEnv -getLocalNameEnv rn_down (SDown {rn_lenv = local_env}) - = return local_env - -getGlobalNameEnv :: RnMS GlobalRdrEnv -getGlobalNameEnv rn_down (SDown {rn_genv = global_env}) - = return global_env - -getGlobalAvails :: RnMS AvailEnv -getGlobalAvails rn_down (SDown {rn_avails = avails}) - = return avails - -setLocalNameEnv :: LocalRdrEnv -> RnMS a -> RnMS a -setLocalNameEnv local_env' m rn_down l_down - = m rn_down (l_down {rn_lenv = local_env'}) - -getFixityEnv :: RnMS LocalFixityEnv -getFixityEnv rn_down (SDown {rn_fixenv = fixity_env}) - = return fixity_env - -setFixityEnv :: LocalFixityEnv -> RnMS a -> RnMS a -setFixityEnv fixes enclosed_scope rn_down l_down - = enclosed_scope rn_down (l_down {rn_fixenv = fixes}) -\end{code} - -%================ -\subsubsection{ Mode} -%===================== - -\begin{code} -getModeRn :: RnMS RnMode -getModeRn rn_down (SDown {rn_mode = mode}) - = return mode - -setModeRn :: RnMode -> RnMS a -> RnMS a -setModeRn new_mode thing_inside rn_down l_down - = thing_inside rn_down (l_down {rn_mode = new_mode}) -\end{code} - - -%************************************************************************ -%* * -\subsection{Plumbing for rename-globals part} -%* * -%************************************************************************ - -\begin{code} -getIfacesRn :: RnM d Ifaces -getIfacesRn (RnDown {rn_ifaces = iface_var}) _ - = readIORef iface_var - -setIfacesRn :: Ifaces -> RnM d () -setIfacesRn ifaces (RnDown {rn_ifaces = iface_var}) _ - = writeIORef iface_var ifaces -\end{code} diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 1eefbc3925..a5b0f84864 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -5,132 +5,142 @@ \begin{code} module RnNames ( - ExportAvails, getGlobalNames, exportsFromAvail + rnImports, importsFromLocalDecls, exportsFromAvail, + reportUnusedNames ) where #include "HsVersions.h" +import {-# SOURCE #-} RnHiFiles ( loadInterface ) + import CmdLineOpts ( DynFlag(..) ) -import HsSyn ( HsModule(..), HsDecl(..), IE(..), ieName, ImportDecl(..), +import HsSyn ( HsDecl(..), IE(..), ieName, ImportDecl(..), ForeignDecl(..), - collectLocatedHsBinders - ) -import RdrHsSyn ( RdrNameIE, RdrNameImportDecl, - RdrNameHsModule, RdrNameHsDecl + collectLocatedHsBinders, tyClDeclNames ) -import RnIfaces ( recordLocalSlurps ) -import RnHiFiles ( getTyClDeclBinders, loadInterface ) +import RdrHsSyn ( RdrNameIE, RdrNameImportDecl, RdrNameHsDecl ) import RnEnv -import RnMonad +import TcRnMonad import FiniteMap -import PrelNames ( pRELUDE_Name, mAIN_Name, isUnboundName ) -import Module ( ModuleName, moduleName, WhereFrom(..) ) -import Name ( Name, nameSrcLoc, nameOccName ) +import PrelNames ( pRELUDE_Name, mAIN_Name, isBuiltInSyntaxName ) +import Module ( Module, ModuleName, moduleName, + moduleNameUserString, + unitModuleEnvByName, lookupModuleEnvByName, + moduleEnvElts ) +import Name ( Name, nameSrcLoc, nameOccName, nameModule ) import NameSet import NameEnv +import OccName ( OccName, dataName, isTcOcc ) import HscTypes ( Provenance(..), ImportReason(..), GlobalRdrEnv, - GenAvailInfo(..), AvailInfo, Avails, AvailEnv, - Deprecations(..), ModIface(..), emptyAvailEnv + GenAvailInfo(..), AvailInfo, Avails, IsBootInterface, + availName, availNames, availsToNameSet, + Deprecations(..), ModIface(..), + GlobalRdrElt(..), unQualInScope, isLocalGRE ) -import RdrName ( rdrNameOcc, setRdrNameOcc ) -import OccName ( setOccNameSpace, dataName ) -import NameSet ( elemNameSet, emptyNameSet ) +import RdrName ( rdrNameOcc, setRdrNameSpace, emptyRdrEnv, foldRdrEnv, isQual ) +import SrcLoc ( noSrcLoc ) import Outputable import Maybes ( maybeToBool, catMaybes ) import ListSetOps ( removeDups ) import Util ( sortLt, notNull ) import List ( partition ) +import IO ( openFile, IOMode(..) ) \end{code} %************************************************************************ %* * -\subsection{Get global names} + rnImports %* * %************************************************************************ \begin{code} -getGlobalNames :: Module -> RdrNameHsModule - -> RnMG (GlobalRdrEnv, -- Maps all in-scope things - GlobalRdrEnv, -- Maps just *local* things - ExportAvails) -- The exported stuff - -getGlobalNames this_mod (HsModule _ _ _ imports decls _ mod_loc) - = -- PROCESS LOCAL DECLS - -- Do these *first* so that the correct provenance gets - -- into the global name cache. - importsFromLocalDecls this_mod decls `thenRn` \ (local_gbl_env, local_mod_avails) -> - - -- PROCESS IMPORT DECLS +rnImports :: [RdrNameImportDecl] + -> TcRn m (GlobalRdrEnv, ImportAvails) + +rnImports imports + = -- PROCESS IMPORT DECLS -- Do the non {- SOURCE -} ones first, so that we get a helpful -- warning for {- SOURCE -} ones that are unnecessary - doptRn Opt_NoImplicitPrelude `thenRn` \ opt_no_prelude -> + getModule `thenM` \ this_mod -> + getSrcLocM `thenM` \ loc -> + doptM Opt_NoImplicitPrelude `thenM` \ opt_no_prelude -> let - all_imports = mk_prel_imports opt_no_prelude ++ imports + all_imports = mk_prel_imports this_mod loc opt_no_prelude ++ imports (source, ordinary) = partition is_source_import all_imports - is_source_import (ImportDecl _ ImportByUserSource _ _ _ _) = True - is_source_import other = False + is_source_import (ImportDecl _ is_boot _ _ _ _) = is_boot - get_imports = importsFromImportDecl this_mod_name + get_imports = importsFromImportDecl (moduleName this_mod) in - mapAndUnzipRn get_imports ordinary `thenRn` \ (imp_gbl_envs1, imp_avails_s1) -> - mapAndUnzipRn get_imports source `thenRn` \ (imp_gbl_envs2, imp_avails_s2) -> + mappM get_imports ordinary `thenM` \ stuff1 -> + mappM get_imports source `thenM` \ stuff2 -> -- COMBINE RESULTS - -- We put the local env second, so that a local provenance - -- "wins", even if a module imports itself. let + (imp_gbl_envs, imp_avails) = unzip (stuff1 ++ stuff2) gbl_env :: GlobalRdrEnv - imp_gbl_env = foldr plusGlobalRdrEnv emptyRdrEnv (imp_gbl_envs2 ++ imp_gbl_envs1) - gbl_env = imp_gbl_env `plusGlobalRdrEnv` local_gbl_env + gbl_env = foldr plusGlobalRdrEnv emptyRdrEnv imp_gbl_envs - all_avails :: ExportAvails - all_avails = foldr plusExportAvails local_mod_avails (imp_avails_s2 ++ imp_avails_s1) + all_avails :: ImportAvails + all_avails = foldr plusImportAvails emptyImportAvails imp_avails in - -- ALL DONE - returnRn (gbl_env, local_gbl_env, all_avails) + returnM (gbl_env, all_avails) where - this_mod_name = moduleName this_mod - -- NB: opt_NoImplicitPrelude is slightly different to import Prelude (); - -- because the former doesn't even look at Prelude.hi for instance declarations, - -- whereas the latter does. - mk_prel_imports no_prelude - | this_mod_name == pRELUDE_Name || - explicit_prelude_import || - no_prelude + -- because the former doesn't even look at Prelude.hi for instance + -- declarations, whereas the latter does. + mk_prel_imports this_mod loc no_prelude + | moduleName this_mod == pRELUDE_Name + || explicit_prelude_import + || no_prelude = [] - | otherwise = [ImportDecl pRELUDE_Name - ImportByUser - False {- Not qualified -} - Nothing {- No "as" -} - Nothing {- No import list -} - mod_loc] - + | otherwise = [preludeImportDecl loc] + explicit_prelude_import - = notNull [ () | (ImportDecl mod _ _ _ _ _) <- imports, mod == pRELUDE_Name ] + = notNull [ () | (ImportDecl mod _ _ _ _ _) <- imports, + mod == pRELUDE_Name ] + +preludeImportDecl loc + = ImportDecl pRELUDE_Name + False {- Not a boot interface -} + False {- Not qualified -} + Nothing {- No "as" -} + Nothing {- No import list -} + loc \end{code} \begin{code} importsFromImportDecl :: ModuleName -> RdrNameImportDecl - -> RnMG (GlobalRdrEnv, - ExportAvails) + -> TcRn m (GlobalRdrEnv, ImportAvails) + +importsFromImportDecl this_mod_name + (ImportDecl imp_mod_name is_boot qual_only as_mod import_spec iloc) + = addSrcLoc iloc $ + let + doc = ppr imp_mod_name <+> ptext SLIT("is directly imported") + in + + -- If there's an error in loadInterface, (e.g. interface + -- file not found) we get lots of spurious errors from 'filterImports' + recoverM (returnM Nothing) + (loadInterface doc imp_mod_name (ImportByUser is_boot) `thenM` \ iface -> + returnM (Just iface)) `thenM` \ mb_iface -> -importsFromImportDecl this_mod_name (ImportDecl imp_mod_name from qual_only as_mod import_spec iloc) - = pushSrcLocRn iloc $ + case mb_iface of { + Nothing -> returnM (emptyRdrEnv, emptyImportAvails ) ; + Just iface -> - loadInterface (ppr imp_mod_name <+> ptext SLIT("is directly imported")) - imp_mod_name from `thenRn` \ iface -> let imp_mod = mi_module iface avails_by_module = mi_exports iface deprecs = mi_deprecs iface + dir_imp = unitModuleEnvByName imp_mod_name (imp_mod, import_all import_spec) avails :: Avails avails = [ avail | (mod_name, avails) <- avails_by_module, @@ -154,39 +164,53 @@ importsFromImportDecl this_mod_name (ImportDecl imp_mod_name from qual_only as_m -- then you'll get a 'B does not export AType' message. Oh well. in - if null avails_by_module then - -- If there's an error in loadInterface, (e.g. interface - -- file not found) we get lots of spurious errors from 'filterImports' - returnRn (emptyRdrEnv, mkEmptyExportAvails imp_mod_name) - else - -- Complain if we import a deprecated module - ifOptRn Opt_WarnDeprecations ( + ifOptM Opt_WarnDeprecations ( case deprecs of - DeprecAll txt -> addWarnRn (moduleDeprec imp_mod_name txt) - other -> returnRn () - ) `thenRn_` + DeprecAll txt -> addWarn (moduleDeprec imp_mod_name txt) + other -> returnM () + ) `thenM_` -- Filter the imports according to the import list - filterImports imp_mod_name from import_spec avails `thenRn` \ (filtered_avails, explicits) -> + filterImports imp_mod_name is_boot import_spec avails `thenM` \ (filtered_avails, explicits) -> let - unqual_imp = not qual_only -- Maybe want unqualified names + unqual_imp = not qual_only -- Maybe want unqualified names qual_mod = case as_mod of Nothing -> imp_mod_name Just another_name -> another_name mk_prov name = NonLocalDef (UserImport imp_mod iloc (name `elemNameSet` explicits)) gbl_env = mkGlobalRdrEnv qual_mod unqual_imp mk_prov filtered_avails deprecs - exports = mkExportAvails qual_mod unqual_imp gbl_env filtered_avails + imports = mkImportAvails qual_mod unqual_imp gbl_env filtered_avails in - returnRn (gbl_env, exports) + returnM (gbl_env, imports { imp_mods = dir_imp}) + } + +import_all (Just (False, _)) = False -- Imports are spec'd explicitly +import_all other = True -- Everything is imported \end{code} +%************************************************************************ +%* * + importsFromLocalDecls +%* * +%************************************************************************ + +From the top-level declarations of this module produce + * the lexical environment + * the ImportAvails +created by its bindings. + +Complain about duplicate bindings + \begin{code} -importsFromLocalDecls this_mod decls - = mapRn (getLocalDeclBinders this_mod) decls `thenRn` \ avails_s -> +importsFromLocalDecls :: [RdrNameHsDecl] + -> TcRn m (GlobalRdrEnv, ImportAvails) +importsFromLocalDecls decls + = getModule `thenM` \ this_mod -> + mappM (getLocalDeclBinders this_mod) decls `thenM` \ avails_s -> -- The avails that are returned don't include the "system" names let avails = concat avails_s @@ -201,17 +225,15 @@ importsFromLocalDecls this_mod decls -- The complaint will come out as "Multiple declarations of Foo.f" because -- since 'f' is in the env twice, the unQualInScope used by the error-msg -- printer returns False. It seems awkward to fix, unfortunately. - mapRn_ (addErrRn . dupDeclErr) dups `thenRn_` - + mappM_ (addErr . dupDeclErr) dups `thenM_` - -- Record that locally-defined things are available - recordLocalSlurps (availsToNameSet avails) `thenRn_` + doptM Opt_NoImplicitPrelude `thenM` \ implicit_prelude -> let mod_name = moduleName this_mod unqual_imp = True -- Want unqualified names mk_prov n = LocalDef -- Provenance is local - gbl_env = mkGlobalRdrEnv mod_name unqual_imp mk_prov avails NoDeprecs + gbl_env = mkGlobalRdrEnv mod_name unqual_imp mk_prov avails NoDeprecs -- NoDeprecs: don't complain about locally defined names -- For a start, we may be exporting a deprecated thing -- Also we may use a deprecated thing in the defn of another @@ -219,41 +241,78 @@ importsFromLocalDecls this_mod decls -- the defn of a non-deprecated thing, when changing a module's -- interface - exports = mkExportAvails mod_name unqual_imp gbl_env avails + + -- Optimisation: filter out names for built-in syntax + -- They just clutter up the environment (esp tuples), and the parser + -- will generate Exact RdrNames for them, so the cluttered + -- envt is no use. To avoid doing this filter all the type, + -- we use -fno-implicit-prelude as a clue that the filter is + -- worth while. Really, it's only useful for Base and Tuple. + -- + -- It's worth doing because it makes the environment smaller for + -- every module that imports the Prelude + -- + -- Note: don't filter the gbl_env (hence avails, not avails' in + -- defn of gbl_env above). Stupid reason: when parsing + -- data type decls, the constructors start as Exact tycon-names, + -- and then get turned into data con names by zapping the name space; + -- but that stops them being Exact, so they get looked up. Sigh. + -- It doesn't matter because it only affects the Data.Tuple really. + -- The important thing is to trim down the exports. + imports = mkImportAvails mod_name unqual_imp gbl_env avails' + avails' | implicit_prelude = filter not_built_in_syntax avails + | otherwise = avails + not_built_in_syntax a = not (all isBuiltInSyntaxName (availNames a)) + -- Only filter it if all the names of the avail are built-in + -- In particular, lists have (:) which is not built in syntax + -- so we don't filter it out. in - returnRn (gbl_env, exports) + returnM (gbl_env, imports) +\end{code} + + +%********************************************************* +%* * +\subsection{Getting binders out of a declaration} +%* * +%********************************************************* + +@getLocalDeclBinders@ returns the names for a @RdrNameHsDecl@. It's +used for both source code (from @importsFromLocalDecls@) and interface +files (@loadDecl@ calls @getTyClDeclBinders@). ---------------------------- -getLocalDeclBinders :: Module -> RdrNameHsDecl -> RnMG [AvailInfo] + *** See "THE NAMING STORY" in HsDecls **** + +\begin{code} +getLocalDeclBinders :: Module -> RdrNameHsDecl -> TcRn m [AvailInfo] getLocalDeclBinders mod (TyClD tycl_decl) = -- For type and class decls, we generate Global names, with -- no export indicator. They need to be global because they get -- permanently bound into the TyCons and Classes. They don't need -- an export indicator because they are all implicitly exported. - getTyClDeclBinders mod tycl_decl `thenRn` \ (avail, sys_names) -> - - -- Record that the system names are available - recordLocalSlurps (mkNameSet sys_names) `thenRn_` - returnRn [avail] + mapM new (tyClDeclNames tycl_decl) `thenM` \ names@(main_name:_) -> + returnM [AvailTC main_name names] + where + new (nm,loc) = newTopBinder mod nm loc getLocalDeclBinders mod (ValD binds) - = mapRn new (collectLocatedHsBinders binds) `thenRn` \ avails -> - returnRn avails + = mappM new (collectLocatedHsBinders binds) `thenM` \ avails -> + returnM avails where - new (rdr_name, loc) = newTopBinder mod rdr_name loc `thenRn` \ name -> - returnRn (Avail name) + new (rdr_name, loc) = newTopBinder mod rdr_name loc `thenM` \ name -> + returnM (Avail name) getLocalDeclBinders mod (ForD (ForeignImport nm _ _ _ loc)) - = newTopBinder mod nm loc `thenRn` \ name -> - returnRn [Avail name] + = newTopBinder mod nm loc `thenM` \ name -> + returnM [Avail name] getLocalDeclBinders mod (ForD _) - = returnRn [] + = returnM [] -getLocalDeclBinders mod (FixD _) = returnRn [] -getLocalDeclBinders mod (DeprecD _) = returnRn [] -getLocalDeclBinders mod (DefD _) = returnRn [] -getLocalDeclBinders mod (InstD _) = returnRn [] -getLocalDeclBinders mod (RuleD _) = returnRn [] +getLocalDeclBinders mod (FixD _) = returnM [] +getLocalDeclBinders mod (DeprecD _) = returnM [] +getLocalDeclBinders mod (DefD _) = returnM [] +getLocalDeclBinders mod (InstD _) = returnM [] +getLocalDeclBinders mod (RuleD _) = returnM [] \end{code} @@ -268,21 +327,21 @@ available, and filters it through the import spec (if any). \begin{code} filterImports :: ModuleName -- The module being imported - -> WhereFrom -- Tells whether it's a {-# SOURCE #-} import + -> IsBootInterface -- Tells whether it's a {-# SOURCE #-} import -> Maybe (Bool, [RdrNameIE]) -- Import spec; True => hiding -> [AvailInfo] -- What's available - -> RnMG ([AvailInfo], -- What's imported + -> TcRn m ([AvailInfo], -- What's imported NameSet) -- What was imported explicitly -- Complains if import spec mentions things that the module doesn't export -- Warns/informs if import spec contains duplicates. filterImports mod from Nothing imports - = returnRn (imports, emptyNameSet) + = returnM (imports, emptyNameSet) filterImports mod from (Just (want_hiding, import_items)) total_avails - = flatMapRn get_item import_items `thenRn` \ avails_w_explicits -> + = mappM get_item import_items `thenM` \ avails_w_explicits_s -> let - (item_avails, explicits_s) = unzip avails_w_explicits + (item_avails, explicits_s) = unzip (concat avails_w_explicits_s) explicits = foldl addListToNameSet emptyNameSet explicits_s in if want_hiding then @@ -290,10 +349,10 @@ filterImports mod from (Just (want_hiding, import_items)) total_avails hidden = availsToNameSet item_avails keep n = not (n `elemNameSet` hidden) in - returnRn (pruneAvails keep total_avails, emptyNameSet) + returnM (pruneAvails keep total_avails, emptyNameSet) else -- Just item_avails imported; nothing to be hidden - returnRn (item_avails, explicits) + returnM (item_avails, explicits) where import_fm :: FiniteMap OccName AvailInfo import_fm = listToFM [ (nameOccName name, avail) @@ -303,10 +362,10 @@ filterImports mod from (Just (want_hiding, import_items)) total_avails -- they won't make any difference because naked entities like T -- in an import list map to TcOccs, not VarOccs. - bale_out item = addErrRn (badImportItemErr mod from item) `thenRn_` - returnRn [] + bale_out item = addErr (badImportItemErr mod from item) `thenM_` + returnM [] - get_item :: RdrNameIE -> RnMG [(AvailInfo, [Name])] + get_item :: RdrNameIE -> TcRn m [(AvailInfo, [Name])] -- Empty list for a bad item. -- Singleton is typical case. -- Can have two when we are hiding, and mention C which might be @@ -320,24 +379,24 @@ filterImports mod from (Just (want_hiding, import_items)) total_avails Just avail@(AvailTC _ [n]) -> -- This occurs when you import T(..), but -- only export T abstractly. The single [n] -- in the AvailTC is the type or class itself - ifOptRn Opt_WarnMisc (addWarnRn (dodgyImportWarn mod item)) `thenRn_` - returnRn [(avail, [availName avail])] - Just avail -> returnRn [(avail, [availName avail])] + ifOptM Opt_WarnMisc (addWarn (dodgyImportWarn mod item)) `thenM_` + returnM [(avail, [availName avail])] + Just avail -> returnM [(avail, [availName avail])] get_item item@(IEThingAbs n) | want_hiding -- hiding( C ) -- Here the 'C' can be a data constructor *or* a type/class = case catMaybes [check_item item, check_item (IEVar data_n)] of [] -> bale_out item - avails -> returnRn [(a, []) | a <- avails] + avails -> returnM [(a, []) | a <- avails] -- The 'explicits' list is irrelevant when hiding where - data_n = setRdrNameOcc n (setOccNameSpace (rdrNameOcc n) dataName) + data_n = setRdrNameSpace n dataName get_item item = case check_item item of Nothing -> bale_out item - Just avail -> returnRn [(avail, availNames avail)] + Just avail -> returnM [(avail, availNames avail)] check_item item | not (maybeToBool maybe_in_import_avails) || @@ -356,52 +415,41 @@ filterImports mod from (Just (want_hiding, import_items)) total_avails Just filtered_avail = maybe_filtered_avail \end{code} - - -%************************************************************************ -%* * -\subsection{Qualifiying imports} -%* * -%************************************************************************ - \begin{code} -type ExportAvails - = (FiniteMap ModuleName Avails, - -- Used to figure out "module M" export specifiers - -- Includes avails only from *unqualified* imports - -- (see 1.4 Report Section 5.1.1) - - AvailEnv) -- All the things that are available. - -- Its domain is all the "main" things; - -- i.e. *excluding* class ops and constructors - -- (which appear inside their parent AvailTC) - -mkEmptyExportAvails :: ModuleName -> ExportAvails -mkEmptyExportAvails mod_name = (unitFM mod_name [], emptyNameEnv) - -plusExportAvails :: ExportAvails -> ExportAvails -> ExportAvails -plusExportAvails (m1, e1) (m2, e2) = (plusFM_C (++) m1 m2, plusAvailEnv e1 e2) - -mkExportAvails :: ModuleName -> Bool -> GlobalRdrEnv -> [AvailInfo] -> ExportAvails -mkExportAvails mod_name unqual_imp gbl_env avails - = (mod_avail_env, entity_avail_env) +filterAvail :: RdrNameIE -- Wanted + -> AvailInfo -- Available + -> Maybe AvailInfo -- Resulting available; + -- Nothing if (any of the) wanted stuff isn't there + +filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns) + | sub_names_ok = Just (AvailTC n (filter is_wanted ns)) + | otherwise = Nothing where - mod_avail_env = unitFM mod_name unqual_avails - - -- unqual_avails is the Avails that are visible in *unqualified* form - -- We need to know this so we know what to export when we see - -- module M ( module P ) where ... - -- Then we must export whatever came from P unqualified. - - unqual_avails | not unqual_imp = [] -- Short cut when no unqualified imports - | otherwise = pruneAvails (unQualInScope gbl_env) avails - - entity_avail_env = foldl insert emptyAvailEnv avails - insert env avail = extendNameEnv_C plusAvail env (availName avail) avail - -- 'avails' may have several items with the same availName - -- E.g import Ix( Ix(..), index ) - -- will give Ix(Ix,index,range) and Ix(index) - -- We want to combine these + is_wanted name = nameOccName name `elem` wanted_occs + sub_names_ok = all (`elem` avail_occs) wanted_occs + avail_occs = map nameOccName ns + wanted_occs = map rdrNameOcc (want:wants) + +filterAvail (IEThingAbs _) (AvailTC n ns) = ASSERT( n `elem` ns ) + Just (AvailTC n [n]) + +filterAvail (IEThingAbs _) avail@(Avail n) = Just avail -- Type synonyms + +filterAvail (IEVar _) avail@(Avail n) = Just avail +filterAvail (IEVar v) avail@(AvailTC n ns) = Just (AvailTC n (filter wanted ns)) + where + wanted n = nameOccName n == occ + occ = rdrNameOcc v + -- The second equation happens if we import a class op, thus + -- import A( op ) + -- where op is a class operation + +filterAvail (IEThingAll _) avail@(AvailTC _ _) = Just avail + -- We don't complain even if the IE says T(..), but + -- no constrs/class ops of T are available + -- Instead that's caught with a warning by the caller + +filterAvail ie avail = Nothing \end{code} @@ -413,15 +461,15 @@ mkExportAvails mod_name unqual_imp gbl_env avails Processing the export list. -You might think that we should record things that appear in the export list -as ``occurrences'' (using @addOccurrenceName@), but you'd be wrong. -We do check (here) that they are in scope, -but there is no need to slurp in their actual declaration -(which is what @addOccurrenceName@ forces). +You might think that we should record things that appear in the export +list as ``occurrences'' (using @addOccurrenceName@), but you'd be +wrong. We do check (here) that they are in scope, but there is no +need to slurp in their actual declaration (which is what +@addOccurrenceName@ forces). -Indeed, doing so would big trouble when -compiling @PrelBase@, because it re-exports @GHC@, which includes @takeMVar#@, -whose type includes @ConcBase.StateAndSynchVar#@, and so on... +Indeed, doing so would big trouble when compiling @PrelBase@, because +it re-exports @GHC@, which includes @takeMVar#@, whose type includes +@ConcBase.StateAndSynchVar#@, and so on... \begin{code} type ExportAccum -- The type of the accumulating parameter of @@ -430,6 +478,7 @@ type ExportAccum -- The type of the accumulating parameter of ExportOccMap, -- Tracks exported occurrence names AvailEnv) -- The accumulated exported stuff, kept in an env -- so we can common-up related AvailInfos +emptyExportAccum = ([], emptyFM, emptyAvailEnv) type ExportOccMap = FiniteMap OccName (Name, RdrNameIE) -- Tracks what a particular exported OccName @@ -438,81 +487,78 @@ type ExportOccMap = FiniteMap OccName (Name, RdrNameIE) -- that have the same occurrence name -exportsFromAvail :: ModuleName - -> Maybe [RdrNameIE] -- Export spec - -> FiniteMap ModuleName Avails -- Used for (module M) exports - -> NameEnv AvailInfo -- Domain is every in-scope thing - -> GlobalRdrEnv - -> RnMG Avails +exportsFromAvail :: Maybe [RdrNameIE] -> TcRn m Avails -- Complains if two distinct exports have same OccName -- Warns about identical exports. -- Complains about exports items not in scope -exportsFromAvail this_mod Nothing - mod_avail_env entity_avail_env global_name_env - = exportsFromAvail this_mod (Just true_exports) mod_avail_env - entity_avail_env global_name_env - where - true_exports - | this_mod == mAIN_Name = [] +exportsFromAvail Nothing + = do { this_mod <- getModule ; + if moduleName this_mod == mAIN_Name then + return [] -- Export nothing; Main.$main is automatically exported - | otherwise = [IEModuleContents this_mod] + else + exportsFromAvail (Just [IEModuleContents (moduleName this_mod)]) -- but for all other modules export everything. + } -exportsFromAvail this_mod (Just export_items) - mod_avail_env entity_avail_env global_name_env - = doptRn Opt_WarnDuplicateExports `thenRn` \ warn_dup_exports -> - foldlRn (exports_from_item warn_dup_exports) - ([], emptyFM, emptyAvailEnv) export_items - `thenRn` \ (_, _, export_avail_map) -> - let - export_avails :: [AvailInfo] - export_avails = nameEnvElts export_avail_map - in - returnRn export_avails +exportsFromAvail (Just exports) + = do { TcGblEnv { tcg_imports = imports } <- getGblEnv ; + warn_dup_exports <- doptM Opt_WarnDuplicateExports ; + exports_from_avail exports warn_dup_exports imports } + +exports_from_avail export_items warn_dup_exports + (ImportAvails { imp_unqual = mod_avail_env, + imp_env = entity_avail_env }) + = foldlM exports_from_item emptyExportAccum + export_items `thenM` \ (_, _, export_avail_map) -> + returnM (nameEnvElts export_avail_map) where - exports_from_item :: Bool -> ExportAccum -> RdrNameIE -> RnMG ExportAccum + exports_from_item :: ExportAccum -> RdrNameIE -> TcRn m ExportAccum - exports_from_item warn_dups acc@(mods, occs, avails) ie@(IEModuleContents mod) + exports_from_item acc@(mods, occs, avails) ie@(IEModuleContents mod) | mod `elem` mods -- Duplicate export of M - = warnCheckRn warn_dups (dupModuleExport mod) `thenRn_` - returnRn acc + = warnIf warn_dup_exports (dupModuleExport mod) `thenM_` + returnM acc | otherwise - = case lookupFM mod_avail_env mod of - Nothing -> failWithRn acc (modExportErr mod) - Just mod_avails -> foldlRn (check_occs ie) occs mod_avails - `thenRn` \ occs' -> - let - avails' = foldl addAvail avails mod_avails - in - returnRn (mod:mods, occs', avails') - - exports_from_item warn_dups acc@(mods, occs, avails) ie - = lookupSrcName global_name_env (ieName ie) `thenRn` \ name -> - - -- See what's available in the current environment - case lookupNameEnv entity_avail_env name of { - Nothing -> -- Presumably this happens because lookupSrcName didn't find - -- the name and returned an unboundName, which won't be in - -- the entity_avail_env, of course - WARN( not (isUnboundName name), ppr name ) - returnRn acc ; - - Just avail -> + = case lookupModuleEnvByName mod_avail_env mod of + Nothing -> addErr (modExportErr mod) `thenM_` + returnM acc + Just mod_avails + -> foldlM (check_occs warn_dup_exports ie) + occs mod_avails `thenM` \ occs' -> + let + avails' = foldl addAvail avails mod_avails + in + returnM (mod:mods, occs', avails') + + exports_from_item acc@(mods, occs, avails) ie + = lookupGRE (ieName ie) `thenM` \ mb_gre -> + case mb_gre of { + Nothing -> addErr (unknownNameErr (ieName ie)) `thenM_` + returnM acc ; + Just gre -> + + -- Get the AvailInfo for the parent of the specified name + case lookupAvailEnv entity_avail_env (gre_parent gre) of { + Nothing -> pprPanic "exportsFromAvail" + ((ppr (ieName ie)) <+> ppr gre) ; + Just avail -> -- Filter out the bits we want case filterAvail ie avail of { Nothing -> -- Not enough availability - failWithRn acc (exportItemErr ie) ; + addErr (exportItemErr ie) `thenM_` + returnM acc ; Just export_avail -> -- Phew! It's OK! Now to check the occurrence stuff! - warnCheckRn (ok_item ie avail) (dodgyExportWarn ie) `thenRn_` - check_occs ie occs export_avail `thenRn` \ occs' -> - returnRn (mods, occs', addAvail avails export_avail) - }} + warnIf (not (ok_item ie avail)) (dodgyExportWarn ie) `thenM_` + check_occs warn_dup_exports ie occs export_avail `thenM` \ occs' -> + returnM (mods, occs', addAvail avails export_avail) + }}} @@ -522,26 +568,176 @@ ok_item (IEThingAll _) (AvailTC _ [n]) = False -- in the AvailTC is the type or class itself ok_item _ _ = True -check_occs :: RdrNameIE -> ExportOccMap -> AvailInfo -> RnMG ExportOccMap -check_occs ie occs avail - = doptRn Opt_WarnDuplicateExports `thenRn` \ warn_dup_exports -> - foldlRn (check warn_dup_exports) occs (availNames avail) +check_occs :: Bool -> RdrNameIE -> ExportOccMap -> AvailInfo -> TcRn m ExportOccMap +check_occs warn_dup_exports ie occs avail + = foldlM check occs (availNames avail) where - check warn_dup occs name + check occs name = case lookupFM occs name_occ of - Nothing -> returnRn (addToFM occs name_occ (name, ie)) + Nothing -> returnM (addToFM occs name_occ (name, ie)) Just (name', ie') | name == name' -> -- Duplicate export - warnCheckRn warn_dup - (dupExportWarn name_occ ie ie') - `thenRn_` returnRn occs + warnIf warn_dup_exports + (dupExportWarn name_occ ie ie') + `thenM_` returnM occs | otherwise -> -- Same occ name but different names: an error - failWithRn occs (exportClashErr name_occ ie ie') + addErr (exportClashErr name_occ ie ie') `thenM_` + returnM occs where name_occ = nameOccName name \end{code} +%********************************************************* +%* * +\subsection{Unused names} +%* * +%********************************************************* + +\begin{code} +reportUnusedNames :: TcGblEnv + -> NameSet -- Used in this module + -> TcRn m () +reportUnusedNames gbl_env used_names + = warnUnusedModules unused_imp_mods `thenM_` + warnUnusedTopBinds bad_locals `thenM_` + warnUnusedImports bad_imports `thenM_` + printMinimalImports minimal_imports + where + direct_import_mods :: [ModuleName] + direct_import_mods = map (moduleName . fst) + (moduleEnvElts (imp_mods (tcg_imports gbl_env))) + + -- Now, a use of C implies a use of T, + -- if C was brought into scope by T(..) or T(C) + really_used_names :: NameSet + really_used_names = used_names `unionNameSets` + mkNameSet [ gre_parent gre + | gre <- defined_names, + gre_name gre `elemNameSet` used_names] + + -- Collect the defined names from the in-scope environment + -- Look for the qualified ones only, else get duplicates + defined_names :: [GlobalRdrElt] + defined_names = foldRdrEnv add [] (tcg_rdr_env gbl_env) + add rdr_name ns acc | isQual rdr_name = ns ++ acc + | otherwise = acc + + defined_and_used, defined_but_not_used :: [GlobalRdrElt] + (defined_and_used, defined_but_not_used) = partition used defined_names + used gre = gre_name gre `elemNameSet` really_used_names + + -- Filter out the ones only defined implicitly + bad_locals :: [GlobalRdrElt] + bad_locals = filter isLocalGRE defined_but_not_used + + bad_imports :: [GlobalRdrElt] + bad_imports = filter bad_imp defined_but_not_used + bad_imp (GRE {gre_prov = NonLocalDef (UserImport mod _ True)}) = not (module_unused mod) + bad_imp other = False + + -- To figure out the minimal set of imports, start with the things + -- that are in scope (i.e. in gbl_env). Then just combine them + -- into a bunch of avails, so they are properly grouped + minimal_imports :: FiniteMap ModuleName AvailEnv + minimal_imports0 = emptyFM + minimal_imports1 = foldr add_name minimal_imports0 defined_and_used + minimal_imports = foldr add_inst_mod minimal_imports1 direct_import_mods + -- The last line makes sure that we retain all direct imports + -- even if we import nothing explicitly. + -- It's not necessarily redundant to import such modules. Consider + -- module This + -- import M () + -- + -- The import M() is not *necessarily* redundant, even if + -- we suck in no instance decls from M (e.g. it contains + -- no instance decls, or This contains no code). It may be + -- that we import M solely to ensure that M's orphan instance + -- decls (or those in its imports) are visible to people who + -- import This. Sigh. + -- There's really no good way to detect this, so the error message + -- in RnEnv.warnUnusedModules is weakened instead + + + -- We've carefully preserved the provenance so that we can + -- construct minimal imports that import the name by (one of) + -- the same route(s) as the programmer originally did. + add_name (GRE {gre_name = n, gre_parent = p, + gre_prov = NonLocalDef (UserImport m _ _)}) acc + = addToFM_C plusAvailEnv acc (moduleName m) + (unitAvailEnv (mk_avail n p)) + add_name other acc + = acc + + -- n is the name of the thing, p is the name of its parent + mk_avail n p | n/=p = AvailTC p [p,n] + | isTcOcc (nameOccName p) = AvailTC n [n] + | otherwise = Avail n + + add_inst_mod m acc + | m `elemFM` acc = acc -- We import something already + | otherwise = addToFM acc m emptyAvailEnv + -- Add an empty collection of imports for a module + -- from which we have sucked only instance decls + + -- unused_imp_mods are the directly-imported modules + -- that are not mentioned in minimal_imports + unused_imp_mods = [m | m <- direct_import_mods, + not (maybeToBool (lookupFM minimal_imports m)), + m /= pRELUDE_Name] + + module_unused :: Module -> Bool + module_unused mod = moduleName mod `elem` unused_imp_mods + + +-- ToDo: deal with original imports with 'qualified' and 'as M' clauses +printMinimalImports :: FiniteMap ModuleName AvailEnv -- Minimal imports + -> TcRn m () +printMinimalImports imps + = ifOptM Opt_D_dump_minimal_imports $ do { + + mod_ies <- mappM to_ies (fmToList imps) ; + this_mod <- getModule ; + rdr_env <- getGlobalRdrEnv ; + ioToTcRn (do { h <- openFile (mkFilename this_mod) WriteMode ; + printForUser h (unQualInScope rdr_env) + (vcat (map ppr_mod_ie mod_ies)) }) + } + where + mkFilename this_mod = moduleNameUserString (moduleName this_mod) ++ ".imports" + ppr_mod_ie (mod_name, ies) + | mod_name == pRELUDE_Name + = empty + | otherwise + = ptext SLIT("import") <+> ppr mod_name <> + parens (fsep (punctuate comma (map ppr ies))) + + to_ies (mod, avail_env) = mappM to_ie (availEnvElts avail_env) `thenM` \ ies -> + returnM (mod, ies) + + to_ie :: AvailInfo -> TcRn m (IE Name) + -- The main trick here is that if we're importing all the constructors + -- we want to say "T(..)", but if we're importing only a subset we want + -- to say "T(A,B,C)". So we have to find out what the module exports. + to_ie (Avail n) = returnM (IEVar n) + to_ie (AvailTC n [m]) = ASSERT( n==m ) + returnM (IEThingAbs n) + to_ie (AvailTC n ns) + = loadInterface (text "Compute minimal imports from" <+> ppr n_mod) + n_mod ImportBySystem `thenM` \ iface -> + case [xs | (m,as) <- mi_exports iface, + m == n_mod, + AvailTC x xs <- as, + x == n] of + [xs] | all (`elem` ns) xs -> returnM (IEThingAll n) + | otherwise -> returnM (IEThingWith n (filter (/= n) ns)) + other -> pprTrace "to_ie" (ppr n <+> ppr (nameModule n) <+> ppr other) $ + returnM (IEVar n) + where + n_mod = moduleName (nameModule n) +\end{code} + + %************************************************************************ %* * \subsection{Errors} @@ -554,8 +750,8 @@ badImportItemErr mod from ie ptext SLIT("does not export"), quotes (ppr ie)] where source_import = case from of - ImportByUserSource -> ptext SLIT("(hi-boot interface)") - other -> empty + True -> ptext SLIT("(hi-boot interface)") + other -> empty dodgyImportWarn mod item = dodgyMsg (ptext SLIT("import")) item dodgyExportWarn item = dodgyMsg (ptext SLIT("export")) item diff --git a/ghc/compiler/rename/RnSource.hi-boot-5 b/ghc/compiler/rename/RnSource.hi-boot-5 new file mode 100644 index 0000000000..6b86c6332c --- /dev/null +++ b/ghc/compiler/rename/RnSource.hi-boot-5 @@ -0,0 +1,12 @@ +__interface RnSource 1 0 where +__export RnSource rnBinds rnSrcDecls; + +1 rnBinds :: __forall [b] => RdrHsSyn.RdrNameHsBinds + -> (RnHsSyn.RenamedHsBinds + -> TcRnTypes.RnM (b, NameSet.FreeVars)) + -> TcRnTypes.RnM (b, NameSet.FreeVars) ; + +1 rnSrcDecls :: [RdrHsSyn.RdrNameHsDecl] + -> TcRnTypes.RnM (TcRnTypes.TcGblEnv, [RnHsSyn.RenamedHsDecl], NameSet.FreeVars) ; + + diff --git a/ghc/compiler/rename/RnSource.hi-boot-6 b/ghc/compiler/rename/RnSource.hi-boot-6 new file mode 100644 index 0000000000..96d489f473 --- /dev/null +++ b/ghc/compiler/rename/RnSource.hi-boot-6 @@ -0,0 +1,10 @@ +module RnSource where + +rnBinds :: forall b . RdrHsSyn.RdrNameHsBinds + -> (RnHsSyn.RenamedHsBinds + -> TcRnTypes.RnM (b, NameSet.FreeVars)) + -> TcRnTypes.RnM (b, NameSet.FreeVars) ; + +rnSrcDecls :: [RdrHsSyn.RdrNameHsDecl] + -> TcRnTypes.RnM (TcRnTypes.TcGblEnv, [RnHsSyn.RenamedHsDecl], NameSet.FreeVars) + diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 352df726fd..d8c9a5be5b 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -4,49 +4,61 @@ \section[RnSource]{Main pass of renamer} \begin{code} -module RnSource ( rnTyClDecl, rnIfaceRuleDecl, rnInstDecl, rnSourceDecls, - ) where +module RnSource ( + rnSrcDecls, rnExtCoreDecls, checkModDeprec, + rnTyClDecl, rnIfaceRuleDecl, rnInstDecl, + rnBinds, rnStats, + ) where #include "HsVersions.h" import RnExpr import HsSyn -import HscTypes ( GlobalRdrEnv, AvailEnv ) import RdrName ( RdrName, isRdrDataCon, elemRdrEnv ) -import RdrHsSyn ( RdrNameConDecl, RdrNameTyClDecl, +import RdrHsSyn ( RdrNameConDecl, RdrNameTyClDecl, RdrNameHsDecl, + RdrNameDeprecation, RdrNameFixitySig, + RdrNameHsBinds, extractGenericPatTyVars ) import RnHsSyn import HsCore +import RnNames ( importsFromLocalDecls ) import RnTypes ( rnHsType, rnHsSigType, rnHsTypeFVs, rnContext ) -import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, renameSigsFVs ) -import RnEnv ( lookupTopBndrRn, lookupOccRn, lookupIfaceName, - lookupSysBinder, newLocalsRn, +import RnBinds ( rnTopMonoBinds, rnMonoBinds, rnMethodBinds, + renameSigs, renameSigsFVs ) +import RnEnv ( lookupTopBndrRn, lookupOccRn, lookupSysBndr, + newLocalsRn, lookupGlobalOccRn, bindLocalsFVRn, bindPatSigTyVars, bindTyVarsRn, extendTyVarEnvFVRn, bindCoreLocalRn, bindCoreLocalsRn, bindLocalNames, - checkDupOrQualNames, checkDupNames, mapFvRn + checkDupOrQualNames, checkDupNames, mapFvRn, + lookupTopSrcBndr_maybe, lookupTopSrcBndr, + dataTcOccs, unknownNameErr, + plusGlobalRdrEnv ) -import RnMonad +import TcRnMonad +import BasicTypes ( FixitySig(..) ) +import HscTypes ( ExternalPackageState(..), FixityEnv, + Deprecations(..), plusDeprecs ) +import Module ( moduleEnvElts ) import Class ( FunDep, DefMeth (..) ) import TyCon ( DataConDetails(..), visibleDataCons ) -import DataCon ( dataConWorkId ) -import Name ( Name, NamedThing(..) ) +import Name ( Name ) import NameSet -import PrelNames ( deRefStablePtrName, newStablePtrName, - bindIOName, returnIOName - ) -import TysWiredIn ( tupleCon ) +import NameEnv +import ErrUtils ( dumpIfSet ) +import PrelNames ( newStablePtrName, bindIOName, returnIOName ) import List ( partition ) +import Bag ( bagToList ) import Outputable import SrcLoc ( SrcLoc ) import CmdLineOpts ( DynFlag(..) ) -- Warn of unused for-all'd tyvars import Maybes ( maybeToBool ) -import Maybe ( maybe ) +import Maybe ( maybe, catMaybes ) \end{code} @rnSourceDecl@ `renames' declarations. @@ -65,58 +77,204 @@ Checks the @(..)@ etc constraints in the export list. \end{enumerate} -%********************************************************* -%* * -\subsection{Source code declarations} -%* * -%********************************************************* - \begin{code} -rnSourceDecls :: GlobalRdrEnv -> AvailEnv -> LocalFixityEnv -> RnMode - -> [RdrNameHsDecl] - -> RnMG ([RenamedHsDecl], FreeVars) - -- The decls get reversed, but that's ok - -rnSourceDecls gbl_env avails local_fixity_env mode decls - = initRnMS gbl_env avails emptyRdrEnv local_fixity_env mode (go emptyFVs [] decls) +rnSrcDecls :: [RdrNameHsDecl] -> RnM (TcGblEnv, [RenamedHsDecl], FreeVars) + +rnSrcDecls decls + = do { (rdr_env, imports) <- importsFromLocalDecls decls ; + updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` + tcg_rdr_env gbl, + tcg_imports = imports `plusImportAvails` + tcg_imports gbl }) + $ do { + + -- Deal with deprecations (returns only the extra deprecations) + deprecs <- rnSrcDeprecDecls [d | DeprecD d <- decls] ; + updGblEnv (\gbl -> gbl { tcg_deprecs = tcg_deprecs gbl `plusDeprecs` deprecs }) + $ do { + + -- Deal with top-level fixity decls + -- (returns the total new fixity env) + fix_env <- rnSrcFixityDecls decls ; + updGblEnv (\gbl -> gbl { tcg_fix_env = fix_env }) + $ do { + + -- Rename remaining declarations + (rn_src_decls, src_fvs) <- rn_src_decls decls ; + + tcg_env <- getGblEnv ; + return (tcg_env, rn_src_decls, src_fvs) + }}}} + +rnExtCoreDecls :: [RdrNameHsDecl] -> RnM ([RenamedHsDecl], FreeVars) +rnExtCoreDecls decls = rn_src_decls decls + +rn_src_decls decls -- Declarartions get reversed, but no matter + = go emptyFVs [] decls where -- Fixity and deprecations have been dealt with already; ignore them - go fvs ds' [] = returnRn (ds', fvs) + go fvs ds' [] = returnM (ds', fvs) go fvs ds' (FixD _:ds) = go fvs ds' ds go fvs ds' (DeprecD _:ds) = go fvs ds' ds - go fvs ds' (d:ds) = rnSourceDecl d `thenRn` \(d', fvs') -> + go fvs ds' (d:ds) = rnSrcDecl d `thenM` \(d', fvs') -> go (fvs `plusFV` fvs') (d':ds') ds +\end{code} + + +%********************************************************* +%* * + Source-code fixity declarations +%* * +%********************************************************* + +\begin{code} +rnSrcFixityDecls :: [RdrNameHsDecl] -> TcRn m FixityEnv +rnSrcFixityDecls decls + = getGblEnv `thenM` \ gbl_env -> + foldlM rnFixityDecl (tcg_fix_env gbl_env) + fix_decls `thenM` \ fix_env -> + traceRn (text "fixity env" <+> ppr fix_env) `thenM_` + returnM fix_env + where + fix_decls = foldr get_fix_sigs [] decls + + -- Get fixities from top level decls, and from class decl sigs too + get_fix_sigs (FixD fix) acc = fix:acc + get_fix_sigs (TyClD (ClassDecl { tcdSigs = sigs})) acc + = [sig | FixSig sig <- sigs] ++ acc + get_fix_sigs other_decl acc = acc + +rnFixityDecl :: FixityEnv -> RdrNameFixitySig -> TcRn m FixityEnv +rnFixityDecl fix_env (FixitySig rdr_name fixity loc) + = -- GHC extension: look up both the tycon and data con + -- for con-like things + -- If neither are in scope, report an error; otherwise + -- add both to the fixity env + mappM lookupTopSrcBndr_maybe (dataTcOccs rdr_name) `thenM` \ maybe_ns -> + case catMaybes maybe_ns of + [] -> addSrcLoc loc $ + addErr (unknownNameErr rdr_name) `thenM_` + returnM fix_env + ns -> foldlM add fix_env ns + where + add fix_env name + = case lookupNameEnv fix_env name of + Just (FixitySig _ _ loc') -> addErr (dupFixityDecl rdr_name loc loc') `thenM_` + returnM fix_env + Nothing -> returnM (extendNameEnv fix_env name (FixitySig name fixity loc)) + +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] +\end{code} + + +%********************************************************* +%* * + Source-code deprecations declarations +%* * +%********************************************************* + +For deprecations, all we do is check that the names are in scope. +It's only imported deprecations, dealt with in RnIfaces, that we +gather them together. + +\begin{code} +rnSrcDeprecDecls :: [RdrNameDeprecation] -> TcRn m Deprecations +rnSrcDeprecDecls [] + = returnM NoDeprecs + +rnSrcDeprecDecls decls + = mappM rn_deprec decls `thenM` \ pairs -> + returnM (DeprecSome (mkNameEnv (catMaybes pairs))) + where + rn_deprec (Deprecation rdr_name txt loc) + = addSrcLoc loc $ + lookupTopSrcBndr rdr_name `thenM` \ name -> + returnM (Just (name, (name,txt))) + +checkModDeprec :: Maybe DeprecTxt -> Deprecations +-- Check for a module deprecation; done once at top level +checkModDeprec Nothing = NoDeprecs +checkModdeprec (Just txt) = DeprecAll txt + +badDeprec d + = sep [ptext SLIT("Illegal deprecation when whole module is deprecated"), + nest 4 (ppr d)] +\end{code} +%********************************************************* +%* * +\subsection{Source code declarations} +%* * +%********************************************************* -rnSourceDecl :: RdrNameHsDecl -> RnMS (RenamedHsDecl, FreeVars) +\begin{code} +rnSrcDecl :: RdrNameHsDecl -> RnM (RenamedHsDecl, FreeVars) -rnSourceDecl (ValD binds) = rnTopBinds binds `thenRn` \ (new_binds, fvs) -> - returnRn (ValD new_binds, fvs) +rnSrcDecl (ValD binds) = rnTopBinds binds `thenM` \ (new_binds, fvs) -> + returnM (ValD new_binds, fvs) -rnSourceDecl (TyClD tycl_decl) - = rnTyClDecl tycl_decl `thenRn` \ new_decl -> - finishSourceTyClDecl tycl_decl new_decl `thenRn` \ (new_decl', fvs) -> - returnRn (TyClD new_decl', fvs `plusFV` tyClDeclFVs new_decl') +rnSrcDecl (TyClD tycl_decl) + = rnTyClDecl tycl_decl `thenM` \ new_decl -> + finishSourceTyClDecl tycl_decl new_decl `thenM` \ (new_decl', fvs) -> + returnM (TyClD new_decl', fvs `plusFV` tyClDeclFVs new_decl') -rnSourceDecl (InstD inst) - = rnInstDecl inst `thenRn` \ new_inst -> - finishSourceInstDecl inst new_inst `thenRn` \ (new_inst', fvs) -> - returnRn (InstD new_inst', fvs `plusFV` instDeclFVs new_inst') +rnSrcDecl (InstD inst) + = rnInstDecl inst `thenM` \ new_inst -> + finishSourceInstDecl inst new_inst `thenM` \ (new_inst', fvs) -> + returnM (InstD new_inst', fvs `plusFV` instDeclFVs new_inst') -rnSourceDecl (RuleD rule) - = rnHsRuleDecl rule `thenRn` \ (new_rule, fvs) -> - returnRn (RuleD new_rule, fvs) +rnSrcDecl (RuleD rule) + = rnHsRuleDecl rule `thenM` \ (new_rule, fvs) -> + returnM (RuleD new_rule, fvs) -rnSourceDecl (ForD ford) - = rnHsForeignDecl ford `thenRn` \ (new_ford, fvs) -> - returnRn (ForD new_ford, fvs) +rnSrcDecl (ForD ford) + = rnHsForeignDecl ford `thenM` \ (new_ford, fvs) -> + returnM (ForD new_ford, fvs) -rnSourceDecl (DefD (DefaultDecl tys src_loc)) - = pushSrcLocRn src_loc $ - mapFvRn (rnHsTypeFVs doc_str) tys `thenRn` \ (tys', fvs) -> - returnRn (DefD (DefaultDecl tys' src_loc), fvs) +rnSrcDecl (DefD (DefaultDecl tys src_loc)) + = addSrcLoc src_loc $ + mapFvRn (rnHsTypeFVs doc_str) tys `thenM` \ (tys', fvs) -> + returnM (DefD (DefaultDecl tys' src_loc), fvs) where doc_str = text "In a `default' declaration" + + +rnSrcDecl (CoreD (CoreDecl name ty rhs loc)) + = addSrcLoc loc $ + lookupTopBndrRn name `thenM` \ name' -> + rnHsTypeFVs doc_str ty `thenM` \ (ty', ty_fvs) -> + rnCoreExpr rhs `thenM` \ rhs' -> + returnM (CoreD (CoreDecl name' ty' rhs' loc), + ty_fvs `plusFV` ufExprFVs rhs') + where + doc_str = text "In the Core declaration for" <+> quotes (ppr name) +\end{code} + +%********************************************************* +%* * + Bindings +%* * +%********************************************************* + +These chaps are here, rather than in TcBinds, so that there +is just one hi-boot file (for RnSource). rnSrcDecls is part +of the loop too, and it must be defined in this module. + +\begin{code} +rnTopBinds :: RdrNameHsBinds -> RnM (RenamedHsBinds, FreeVars) +rnTopBinds EmptyBinds = returnM (EmptyBinds, emptyFVs) +rnTopBinds (MonoBind bind sigs _) = rnTopMonoBinds bind sigs + -- The parser doesn't produce other forms + +rnBinds :: RdrNameHsBinds + -> (RenamedHsBinds -> RnM (result, FreeVars)) + -> RnM (result, FreeVars) +rnBinds EmptyBinds thing_inside = thing_inside EmptyBinds +rnBinds (MonoBind bind sigs _) thing_inside = rnMonoBinds bind sigs thing_inside + -- the parser doesn't produce other forms \end{code} @@ -128,25 +286,24 @@ rnSourceDecl (DefD (DefaultDecl tys src_loc)) \begin{code} rnHsForeignDecl (ForeignImport name ty spec isDeprec src_loc) - = pushSrcLocRn src_loc $ - lookupTopBndrRn name `thenRn` \ name' -> - rnHsTypeFVs (fo_decl_msg name) ty `thenRn` \ (ty', fvs) -> - returnRn (ForeignImport name' ty' spec isDeprec src_loc, + = addSrcLoc src_loc $ + lookupTopBndrRn name `thenM` \ name' -> + rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) -> + returnM (ForeignImport name' ty' spec isDeprec src_loc, fvs `plusFV` extras spec) where extras (CImport _ _ _ _ CWrapper) = mkFVs [newStablePtrName, - deRefStablePtrName, bindIOName, returnIOName] extras _ = emptyFVs rnHsForeignDecl (ForeignExport name ty spec isDeprec src_loc) - = pushSrcLocRn src_loc $ - lookupOccRn name `thenRn` \ name' -> - rnHsTypeFVs (fo_decl_msg name) ty `thenRn` \ (ty', fvs) -> - returnRn (ForeignExport name' ty' spec isDeprec src_loc, + = addSrcLoc src_loc $ + lookupOccRn name `thenM` \ name' -> + rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) -> + returnM (ForeignExport name' ty' spec isDeprec src_loc, mkFVs [bindIOName, returnIOName] `plusFV` fvs) -fo_decl_msg name = ptext SLIT("The foreign declaration for") <+> ppr name +fo_decl_msg name = ptext SLIT("In the foreign declaration for") <+> ppr name \end{code} @@ -159,17 +316,17 @@ fo_decl_msg name = ptext SLIT("The foreign declaration for") <+> ppr name \begin{code} rnInstDecl (InstDecl inst_ty mbinds uprags maybe_dfun_rdr_name src_loc) -- Used for both source and interface file decls - = pushSrcLocRn src_loc $ - rnHsSigType (text "an instance decl") inst_ty `thenRn` \ inst_ty' -> + = addSrcLoc src_loc $ + rnHsSigType (text "an instance decl") inst_ty `thenM` \ inst_ty' -> (case maybe_dfun_rdr_name of - Nothing -> returnRn Nothing - Just dfun_rdr_name -> lookupIfaceName dfun_rdr_name `thenRn` \ dfun_name -> - returnRn (Just dfun_name) - ) `thenRn` \ maybe_dfun_name -> + Nothing -> returnM Nothing + Just dfun_rdr_name -> lookupGlobalOccRn dfun_rdr_name `thenM` \ dfun_name -> + returnM (Just dfun_name) + ) `thenM` \ maybe_dfun_name -> -- The typechecker checks that all the bindings are for the right class. - returnRn (InstDecl inst_ty' EmptyMonoBinds [] maybe_dfun_name src_loc) + returnM (InstDecl inst_ty' EmptyMonoBinds [] maybe_dfun_name src_loc) -- Compare finishSourceTyClDecl finishSourceInstDecl (InstDecl _ mbinds uprags _ _ ) @@ -179,17 +336,17 @@ finishSourceInstDecl (InstDecl _ mbinds uprags _ _ ) let meth_doc = text "In the bindings in an instance declaration" meth_names = collectLocatedMonoBinders mbinds - (inst_tyvars, (cls,_)) = getHsInstHead inst_ty + (inst_tyvars, _, cls,_) = splitHsInstDeclTy inst_ty -- (Slightly strangely) the forall-d tyvars scope over -- the method bindings too in -- Rename the bindings -- NB meth_names can be qualified! - checkDupNames meth_doc meth_names `thenRn_` + checkDupNames meth_doc meth_names `thenM_` extendTyVarEnvForMethodBinds inst_tyvars ( rnMethodBinds cls [] mbinds - ) `thenRn` \ (mbinds', meth_fvs) -> + ) `thenM` \ (mbinds', meth_fvs) -> let binders = collectMonoBinders mbinds' binder_set = mkNameSet binders @@ -203,9 +360,9 @@ finishSourceInstDecl (InstDecl _ mbinds uprags _ _ ) -- But the (unqualified) method names are in scope bindLocalNames binders ( renameSigsFVs (okInstDclSig binder_set) uprags - ) `thenRn` \ (uprags', prag_fvs) -> + ) `thenM` \ (uprags', prag_fvs) -> - returnRn (InstDecl inst_ty mbinds' uprags' maybe_dfun_name src_loc, + returnM (InstDecl inst_ty mbinds' uprags' maybe_dfun_name src_loc, meth_fvs `plusFV` prag_fvs) \end{code} @@ -217,33 +374,33 @@ finishSourceInstDecl (InstDecl _ mbinds uprags _ _ ) \begin{code} rnIfaceRuleDecl (IfaceRule rule_name act vars fn args rhs src_loc) - = pushSrcLocRn src_loc $ - lookupOccRn fn `thenRn` \ fn' -> + = addSrcLoc src_loc $ + lookupOccRn fn `thenM` \ fn' -> rnCoreBndrs vars $ \ vars' -> - mapRn rnCoreExpr args `thenRn` \ args' -> - rnCoreExpr rhs `thenRn` \ rhs' -> - returnRn (IfaceRule rule_name act vars' fn' args' rhs' src_loc) + mappM rnCoreExpr args `thenM` \ args' -> + rnCoreExpr rhs `thenM` \ rhs' -> + returnM (IfaceRule rule_name act vars' fn' args' rhs' src_loc) rnIfaceRuleDecl (IfaceRuleOut fn rule) -- Builtin rules come this way - = lookupOccRn fn `thenRn` \ fn' -> - returnRn (IfaceRuleOut fn' rule) + = lookupOccRn fn `thenM` \ fn' -> + returnM (IfaceRuleOut fn' rule) rnHsRuleDecl (HsRule rule_name act vars lhs rhs src_loc) - = pushSrcLocRn src_loc $ + = addSrcLoc src_loc $ bindPatSigTyVars (collectRuleBndrSigTys vars) $ bindLocalsFVRn doc (map get_var vars) $ \ ids -> - mapFvRn rn_var (vars `zip` ids) `thenRn` \ (vars', fv_vars) -> + mapFvRn rn_var (vars `zip` ids) `thenM` \ (vars', fv_vars) -> - rnExpr lhs `thenRn` \ (lhs', fv_lhs) -> - rnExpr rhs `thenRn` \ (rhs', fv_rhs) -> - checkRn (validRuleLhs ids lhs') - (badRuleLhsErr rule_name lhs') `thenRn_` + rnExpr lhs `thenM` \ (lhs', fv_lhs) -> + rnExpr rhs `thenM` \ (rhs', fv_rhs) -> + checkErr (validRuleLhs ids lhs') + (badRuleLhsErr rule_name lhs') `thenM_` let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs)] in - mapRn (addErrRn . badRuleVar rule_name) bad_vars `thenRn_` - returnRn (HsRule rule_name act vars' lhs' rhs' src_loc, + mappM (addErr . badRuleVar rule_name) bad_vars `thenM_` + returnM (HsRule rule_name act vars' lhs' rhs' src_loc, fv_vars `plusFV` fv_lhs `plusFV` fv_rhs) where doc = text "In the transformation rule" <+> ftext rule_name @@ -251,9 +408,23 @@ rnHsRuleDecl (HsRule rule_name act vars lhs rhs src_loc) get_var (RuleBndr v) = v get_var (RuleBndrSig v _) = v - rn_var (RuleBndr v, id) = returnRn (RuleBndr id, emptyFVs) - rn_var (RuleBndrSig v t, id) = rnHsTypeFVs doc t `thenRn` \ (t', fvs) -> - returnRn (RuleBndrSig id t', fvs) + rn_var (RuleBndr v, id) = returnM (RuleBndr id, emptyFVs) + rn_var (RuleBndrSig v t, id) = rnHsTypeFVs doc t `thenM` \ (t', fvs) -> + returnM (RuleBndrSig id t', fvs) +\end{code} + +Check the shape of a transformation rule LHS. Currently +we only allow LHSs of the form @(f e1 .. en)@, where @f@ is +not one of the @forall@'d variables. + +\begin{code} +validRuleLhs foralls lhs + = check lhs + where + check (OpApp _ op _ _) = check op + check (HsApp e1 e2) = check e1 + check (HsVar v) | v `notElem` foralls = True + check other = False \end{code} @@ -278,81 +449,65 @@ However, we can also do some scoping checks at the same time. \begin{code} rnTyClDecl (IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc = loc}) - = pushSrcLocRn loc $ - lookupTopBndrRn name `thenRn` \ name' -> - rnHsType doc_str ty `thenRn` \ ty' -> - mapRn rnIdInfo id_infos `thenRn` \ id_infos' -> - returnRn (IfaceSig {tcdName = name', tcdType = ty', tcdIdInfo = id_infos', tcdLoc = loc}) + = addSrcLoc loc $ + lookupTopBndrRn name `thenM` \ name' -> + rnHsType doc_str ty `thenM` \ ty' -> + mappM rnIdInfo id_infos `thenM` \ id_infos' -> + returnM (IfaceSig {tcdName = name', tcdType = ty', tcdIdInfo = id_infos', tcdLoc = loc}) where doc_str = text "In the interface signature for" <+> quotes (ppr name) -rnTyClDecl (CoreDecl {tcdName = name, tcdType = ty, tcdRhs = rhs, tcdLoc = loc}) - = pushSrcLocRn loc $ - lookupTopBndrRn name `thenRn` \ name' -> - rnHsType doc_str ty `thenRn` \ ty' -> - rnCoreExpr rhs `thenRn` \ rhs' -> - returnRn (CoreDecl {tcdName = name', tcdType = ty', tcdRhs = rhs', tcdLoc = loc}) - where - doc_str = text "In the Core declaration for" <+> quotes (ppr name) - rnTyClDecl (ForeignType {tcdName = name, tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc}) - = pushSrcLocRn loc $ - lookupTopBndrRn name `thenRn` \ name' -> - returnRn (ForeignType {tcdName = name', tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc}) + = addSrcLoc loc $ + lookupTopBndrRn name `thenM` \ name' -> + returnM (ForeignType {tcdName = name', tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc}) rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon, - tcdTyVars = tyvars, tcdCons = condecls, - tcdDerivs = derivs, tcdLoc = src_loc, tcdSysNames = sys_names}) - = pushSrcLocRn src_loc $ - lookupTopBndrRn tycon `thenRn` \ tycon' -> + tcdTyVars = tyvars, tcdCons = condecls, tcdGeneric = want_generic, + tcdDerivs = derivs, tcdLoc = src_loc}) + = addSrcLoc src_loc $ + lookupTopBndrRn tycon `thenM` \ tycon' -> bindTyVarsRn data_doc tyvars $ \ tyvars' -> - rnContext data_doc context `thenRn` \ context' -> - rn_derivs derivs `thenRn` \ derivs' -> - checkDupOrQualNames data_doc con_names `thenRn_` - - rnConDecls tycon' condecls `thenRn` \ condecls' -> - mapRn lookupSysBinder sys_names `thenRn` \ sys_names' -> - returnRn (TyData {tcdND = new_or_data, tcdCtxt = context', tcdName = tycon', - tcdTyVars = tyvars', tcdCons = condecls', - tcdDerivs = derivs', tcdLoc = src_loc, tcdSysNames = sys_names'}) + rnContext data_doc context `thenM` \ context' -> + rn_derivs derivs `thenM` \ derivs' -> + checkDupOrQualNames data_doc con_names `thenM_` + + rnConDecls tycon' condecls `thenM` \ condecls' -> + returnM (TyData {tcdND = new_or_data, tcdCtxt = context', tcdName = tycon', + tcdTyVars = tyvars', tcdCons = condecls', tcdGeneric = want_generic, + tcdDerivs = derivs', tcdLoc = src_loc}) where data_doc = text "In the data type declaration for" <+> quotes (ppr tycon) con_names = map conDeclName (visibleDataCons condecls) - rn_derivs Nothing = returnRn Nothing - rn_derivs (Just ds) = rnContext data_doc ds `thenRn` \ ds' -> returnRn (Just ds') + rn_derivs Nothing = returnM Nothing + rn_derivs (Just ds) = rnContext data_doc ds `thenM` \ ds' -> returnM (Just ds') rnTyClDecl (TySynonym {tcdName = name, tcdTyVars = tyvars, tcdSynRhs = ty, tcdLoc = src_loc}) - = pushSrcLocRn src_loc $ - lookupTopBndrRn name `thenRn` \ name' -> + = addSrcLoc src_loc $ + lookupTopBndrRn name `thenM` \ name' -> bindTyVarsRn syn_doc tyvars $ \ tyvars' -> - rnHsType syn_doc ty `thenRn` \ ty' -> - returnRn (TySynonym {tcdName = name', tcdTyVars = tyvars', tcdSynRhs = ty', tcdLoc = src_loc}) + rnHsType syn_doc ty `thenM` \ ty' -> + returnM (TySynonym {tcdName = name', tcdTyVars = tyvars', tcdSynRhs = ty', tcdLoc = src_loc}) where syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name) rnTyClDecl (ClassDecl {tcdCtxt = context, tcdName = cname, tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, - tcdSysNames = names, tcdLoc = src_loc}) + tcdLoc = src_loc}) -- Used for both source and interface file decls - = pushSrcLocRn src_loc $ + = addSrcLoc src_loc $ - lookupTopBndrRn cname `thenRn` \ cname' -> - - -- Deal with the implicit tycon and datacon name - -- They aren't in scope (because they aren't visible to the user) - -- and what we want to do is simply look them up in the cache; - -- we jolly well ought to get a 'hit' there! - mapRn lookupSysBinder names `thenRn` \ names' -> + lookupTopBndrRn cname `thenM` \ cname' -> -- Tyvars scope over superclass context and method signatures bindTyVarsRn cls_doc tyvars $ \ tyvars' -> -- Check the superclasses - rnContext cls_doc context `thenRn` \ context' -> + rnContext cls_doc context `thenM` \ context' -> -- Check the functional dependencies - rnFds cls_doc fds `thenRn` \ fds' -> + rnFds cls_doc fds `thenM` \ fds' -> -- Check the signatures -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs). @@ -360,50 +515,49 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdName = cname, (op_sigs, non_op_sigs) = partition isClassOpSig sigs sig_rdr_names_w_locs = [(op,locn) | ClassOpSig op _ _ locn <- sigs] in - checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_` - mapRn (rnClassOp cname' fds') op_sigs `thenRn` \ sigs' -> + checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenM_` + mappM (rnClassOp cname' fds') op_sigs `thenM` \ sigs' -> let binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ] in - renameSigs (okClsDclSig binders) non_op_sigs `thenRn` \ non_ops' -> + renameSigs (okClsDclSig binders) non_op_sigs `thenM` \ non_ops' -> -- Typechecker is responsible for checking that we only -- give default-method bindings for things in this class. -- The renamer *could* check this for class decls, but can't -- for instance decls. - returnRn (ClassDecl { tcdCtxt = context', tcdName = cname', tcdTyVars = tyvars', - tcdFDs = fds', tcdSigs = non_ops' ++ sigs', tcdMeths = Nothing, - tcdSysNames = names', tcdLoc = src_loc}) + returnM (ClassDecl { tcdCtxt = context', tcdName = cname', tcdTyVars = tyvars', + tcdFDs = fds', tcdSigs = non_ops' ++ sigs', tcdMeths = Nothing, + tcdLoc = src_loc}) where cls_doc = text "In the declaration for class" <+> ppr cname sig_doc = text "In the signatures for class" <+> ppr cname rnClassOp clas clas_fds sig@(ClassOpSig op dm_stuff ty locn) - = pushSrcLocRn locn $ - lookupTopBndrRn op `thenRn` \ op_name -> + = addSrcLoc locn $ + lookupTopBndrRn op `thenM` \ op_name -> -- Check the signature - rnHsSigType (quotes (ppr op)) ty `thenRn` \ new_ty -> + rnHsSigType (quotes (ppr op)) ty `thenM` \ new_ty -> -- Make the default-method name (case dm_stuff of DefMeth dm_rdr_name -> -- Imported class that has a default method decl - -- See comments with tname, snames, above - lookupSysBinder dm_rdr_name `thenRn` \ dm_name -> - returnRn (DefMeth dm_name) + lookupSysBndr dm_rdr_name `thenM` \ dm_name -> + returnM (DefMeth dm_name) -- An imported class decl for a class decl that had an explicit default -- method, mentions, rather than defines, -- the default method, so we must arrange to pull it in - GenDefMeth -> returnRn GenDefMeth - NoDefMeth -> returnRn NoDefMeth - ) `thenRn` \ dm_stuff' -> + GenDefMeth -> returnM GenDefMeth + NoDefMeth -> returnM NoDefMeth + ) `thenM` \ dm_stuff' -> - returnRn (ClassOpSig op_name dm_stuff' new_ty locn) + returnM (ClassOpSig op_name dm_stuff' new_ty locn) -finishSourceTyClDecl :: RdrNameTyClDecl -> RenamedTyClDecl -> RnMS (RenamedTyClDecl, FreeVars) +finishSourceTyClDecl :: RdrNameTyClDecl -> RenamedTyClDecl -> RnM (RenamedTyClDecl, FreeVars) -- Used for source file decls only -- Renames the default-bindings of a class decl finishSourceTyClDecl (ClassDecl {tcdMeths = Just mbinds, tcdLoc = src_loc}) -- Get mbinds from here @@ -419,18 +573,18 @@ finishSourceTyClDecl (ClassDecl {tcdMeths = Just mbinds, tcdLoc = src_loc}) -- G -- we want to name both "x" tyvars with the same unique, so that they are -- easy to group together in the typechecker. -- Hence the - pushSrcLocRn src_loc $ + addSrcLoc src_loc $ extendTyVarEnvForMethodBinds tyvars $ - getLocalNameEnv `thenRn` \ name_env -> + getLocalRdrEnv `thenM` \ name_env -> let meth_rdr_names_w_locs = collectLocatedMonoBinders mbinds gen_rdr_tyvars_w_locs = [(tv,src_loc) | tv <- extractGenericPatTyVars mbinds, not (tv `elemRdrEnv` name_env)] in - checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_` - newLocalsRn gen_rdr_tyvars_w_locs `thenRn` \ gen_tyvars -> - rnMethodBinds cls gen_tyvars mbinds `thenRn` \ (mbinds', meth_fvs) -> - returnRn (rn_cls_decl {tcdMeths = Just mbinds'}, meth_fvs) + checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenM_` + newLocalsRn gen_rdr_tyvars_w_locs `thenM` \ gen_tyvars -> + rnMethodBinds cls gen_tyvars mbinds `thenM` \ (mbinds', meth_fvs) -> + returnM (rn_cls_decl {tcdMeths = Just mbinds'}, meth_fvs) where meth_doc = text "In the default-methods for class" <+> ppr (tcdName rn_cls_decl) @@ -440,10 +594,10 @@ finishSourceTyClDecl _ tycl_decl@(TyData {tcdDerivs = derivings}) -- FVs that are `needed' by the interface file declaration, and -- derivings do not appear in this. It also means that the tcGroups -- are smaller, which turned out to be important for the usage inference. KSW 2002-02. - = returnRn (tycl_decl, + = returnM (tycl_decl, maybe emptyFVs extractHsCtxtTyNames derivings) -finishSourceTyClDecl _ tycl_decl = returnRn (tycl_decl, emptyFVs) +finishSourceTyClDecl _ tycl_decl = returnM (tycl_decl, emptyFVs) -- Not a class declaration \end{code} @@ -452,7 +606,7 @@ type variable environment iff -fglasgow-exts \begin{code} extendTyVarEnvForMethodBinds tyvars thing_inside - = doptRn Opt_GlasgowExts `thenRn` \ opt_GlasgowExts -> + = doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts -> if opt_GlasgowExts then extendTyVarEnvFVRn (map hsTyVarName tyvars) thing_inside else @@ -468,65 +622,62 @@ extendTyVarEnvForMethodBinds tyvars thing_inside \begin{code} conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc) -conDeclName (ConDecl n _ _ _ _ l) = (n,l) +conDeclName (ConDecl n _ _ _ l) = (n,l) -rnConDecls :: Name -> DataConDetails RdrNameConDecl -> RnMS (DataConDetails RenamedConDecl) -rnConDecls tycon Unknown = returnRn Unknown -rnConDecls tycon (HasCons n) = returnRn (HasCons n) +rnConDecls :: Name -> DataConDetails RdrNameConDecl -> RnM (DataConDetails RenamedConDecl) +rnConDecls tycon Unknown = returnM Unknown +rnConDecls tycon (HasCons n) = returnM (HasCons n) rnConDecls tycon (DataCons condecls) = -- Check that there's at least one condecl, -- or else we're reading an interface file, or -fglasgow-exts (if null condecls then - doptRn Opt_GlasgowExts `thenRn` \ glaExts -> - getModeRn `thenRn` \ mode -> - checkRn (glaExts || isInterfaceMode mode) + doptM Opt_GlasgowExts `thenM` \ glaExts -> + getModeRn `thenM` \ mode -> + checkErr (glaExts || isInterfaceMode mode) (emptyConDeclsErr tycon) - else returnRn () - ) `thenRn_` - - mapRn rnConDecl condecls `thenRn` \ condecls' -> - returnRn (DataCons condecls') + else returnM () + ) `thenM_` -rnConDecl :: RdrNameConDecl -> RnMS RenamedConDecl -rnConDecl (ConDecl name wkr tvs cxt details locn) - = pushSrcLocRn locn $ - checkConName name `thenRn_` - lookupTopBndrRn name `thenRn` \ new_name -> + mappM rnConDecl condecls `thenM` \ condecls' -> + returnM (DataCons condecls') - lookupSysBinder wkr `thenRn` \ new_wkr -> - -- See comments with ClassDecl +rnConDecl :: RdrNameConDecl -> RnM RenamedConDecl +rnConDecl (ConDecl name tvs cxt details locn) + = addSrcLoc locn $ + checkConName name `thenM_` + lookupTopBndrRn name `thenM` \ new_name -> bindTyVarsRn doc tvs $ \ new_tyvars -> - rnContext doc cxt `thenRn` \ new_context -> - rnConDetails doc locn details `thenRn` \ new_details -> - returnRn (ConDecl new_name new_wkr new_tyvars new_context new_details locn) + rnContext doc cxt `thenM` \ new_context -> + rnConDetails doc locn details `thenM` \ new_details -> + returnM (ConDecl new_name new_tyvars new_context new_details locn) where doc = text "In the definition of data constructor" <+> quotes (ppr name) -rnConDetails doc locn (VanillaCon tys) - = mapRn (rnBangTy doc) tys `thenRn` \ new_tys -> - returnRn (VanillaCon new_tys) +rnConDetails doc locn (PrefixCon tys) + = mappM (rnBangTy doc) tys `thenM` \ new_tys -> + returnM (PrefixCon new_tys) rnConDetails doc locn (InfixCon ty1 ty2) - = rnBangTy doc ty1 `thenRn` \ new_ty1 -> - rnBangTy doc ty2 `thenRn` \ new_ty2 -> - returnRn (InfixCon new_ty1 new_ty2) + = rnBangTy doc ty1 `thenM` \ new_ty1 -> + rnBangTy doc ty2 `thenM` \ new_ty2 -> + returnM (InfixCon new_ty1 new_ty2) rnConDetails doc locn (RecCon fields) - = checkDupOrQualNames doc field_names `thenRn_` - mapRn (rnField doc) fields `thenRn` \ new_fields -> - returnRn (RecCon new_fields) + = checkDupOrQualNames doc field_names `thenM_` + mappM (rnField doc) fields `thenM` \ new_fields -> + returnM (RecCon new_fields) where - field_names = [(fld, locn) | (flds, _) <- fields, fld <- flds] + field_names = [(fld, locn) | (fld, _) <- fields] -rnField doc (names, ty) - = mapRn lookupTopBndrRn names `thenRn` \ new_names -> - rnBangTy doc ty `thenRn` \ new_ty -> - returnRn (new_names, new_ty) +rnField doc (name, ty) + = lookupTopBndrRn name `thenM` \ new_name -> + rnBangTy doc ty `thenM` \ new_ty -> + returnM (new_name, new_ty) rnBangTy doc (BangType s ty) - = rnHsType doc ty `thenRn` \ new_ty -> - returnRn (BangType s new_ty) + = rnHsType doc ty `thenM` \ new_ty -> + returnM (BangType s new_ty) -- This data decl will parse OK -- data T = a Int @@ -539,8 +690,7 @@ rnBangTy doc (BangType s ty) -- from interface files, which always print in prefix form checkConName name - = checkRn (isRdrDataCon name) - (badDataCon name) + = checkErr (isRdrDataCon name) (badDataCon name) \end{code} @@ -551,17 +701,17 @@ checkConName name %********************************************************* \begin{code} -rnFds :: SDoc -> [FunDep RdrName] -> RnMS [FunDep Name] +rnFds :: SDoc -> [FunDep RdrName] -> RnM [FunDep Name] rnFds doc fds - = mapRn rn_fds fds + = mappM rn_fds fds where rn_fds (tys1, tys2) - = rnHsTyVars doc tys1 `thenRn` \ tys1' -> - rnHsTyVars doc tys2 `thenRn` \ tys2' -> - returnRn (tys1', tys2') + = rnHsTyVars doc tys1 `thenM` \ tys1' -> + rnHsTyVars doc tys2 `thenM` \ tys2' -> + returnM (tys1', tys2') -rnHsTyVars doc tvs = mapRn (rnHsTyvar doc) tvs +rnHsTyVars doc tvs = mappM (rnHsTyvar doc) tvs rnHsTyvar doc tyvar = lookupOccRn tyvar \end{code} @@ -573,84 +723,81 @@ rnHsTyvar doc tyvar = lookupOccRn tyvar \begin{code} rnIdInfo (HsWorker worker arity) - = lookupOccRn worker `thenRn` \ worker' -> - returnRn (HsWorker worker' arity) - -rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenRn` \ expr' -> - returnRn (HsUnfold inline expr') -rnIdInfo (HsStrictness str) = returnRn (HsStrictness str) -rnIdInfo (HsArity arity) = returnRn (HsArity arity) -rnIdInfo HsNoCafRefs = returnRn HsNoCafRefs + = lookupOccRn worker `thenM` \ worker' -> + returnM (HsWorker worker' arity) + +rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenM` \ expr' -> + returnM (HsUnfold inline expr') +rnIdInfo (HsStrictness str) = returnM (HsStrictness str) +rnIdInfo (HsArity arity) = returnM (HsArity arity) +rnIdInfo HsNoCafRefs = returnM HsNoCafRefs \end{code} @UfCore@ expressions. \begin{code} rnCoreExpr (UfType ty) - = rnHsType (text "unfolding type") ty `thenRn` \ ty' -> - returnRn (UfType ty') + = rnHsType (text "unfolding type") ty `thenM` \ ty' -> + returnM (UfType ty') rnCoreExpr (UfVar v) - = lookupOccRn v `thenRn` \ v' -> - returnRn (UfVar v') + = lookupOccRn v `thenM` \ v' -> + returnM (UfVar v') rnCoreExpr (UfLit l) - = returnRn (UfLit l) + = returnM (UfLit l) rnCoreExpr (UfLitLit l ty) - = rnHsType (text "litlit") ty `thenRn` \ ty' -> - returnRn (UfLitLit l ty') + = rnHsType (text "litlit") ty `thenM` \ ty' -> + returnM (UfLitLit l ty') rnCoreExpr (UfFCall cc ty) - = rnHsType (text "ccall") ty `thenRn` \ ty' -> - returnRn (UfFCall cc ty') + = rnHsType (text "ccall") ty `thenM` \ ty' -> + returnM (UfFCall cc ty') -rnCoreExpr (UfTuple (HsTupCon _ boxity arity) args) - = mapRn rnCoreExpr args `thenRn` \ args' -> - returnRn (UfTuple (HsTupCon tup_name boxity arity) args') - where - tup_name = getName (dataConWorkId (tupleCon boxity arity)) - -- Get the *worker* name and use that +rnCoreExpr (UfTuple (HsTupCon boxity arity) args) + = mappM rnCoreExpr args `thenM` \ args' -> + returnM (UfTuple (HsTupCon boxity arity) args') rnCoreExpr (UfApp fun arg) - = rnCoreExpr fun `thenRn` \ fun' -> - rnCoreExpr arg `thenRn` \ arg' -> - returnRn (UfApp fun' arg') + = rnCoreExpr fun `thenM` \ fun' -> + rnCoreExpr arg `thenM` \ arg' -> + returnM (UfApp fun' arg') rnCoreExpr (UfCase scrut bndr alts) - = rnCoreExpr scrut `thenRn` \ scrut' -> + = rnCoreExpr scrut `thenM` \ scrut' -> bindCoreLocalRn bndr $ \ bndr' -> - mapRn rnCoreAlt alts `thenRn` \ alts' -> - returnRn (UfCase scrut' bndr' alts') + mappM rnCoreAlt alts `thenM` \ alts' -> + returnM (UfCase scrut' bndr' alts') rnCoreExpr (UfNote note expr) - = rnNote note `thenRn` \ note' -> - rnCoreExpr expr `thenRn` \ expr' -> - returnRn (UfNote note' expr') + = rnNote note `thenM` \ note' -> + rnCoreExpr expr `thenM` \ expr' -> + returnM (UfNote note' expr') rnCoreExpr (UfLam bndr body) = rnCoreBndr bndr $ \ bndr' -> - rnCoreExpr body `thenRn` \ body' -> - returnRn (UfLam bndr' body') + rnCoreExpr body `thenM` \ body' -> + returnM (UfLam bndr' body') rnCoreExpr (UfLet (UfNonRec bndr rhs) body) - = rnCoreExpr rhs `thenRn` \ rhs' -> + = rnCoreExpr rhs `thenM` \ rhs' -> rnCoreBndr bndr $ \ bndr' -> - rnCoreExpr body `thenRn` \ body' -> - returnRn (UfLet (UfNonRec bndr' rhs') body') + rnCoreExpr body `thenM` \ body' -> + returnM (UfLet (UfNonRec bndr' rhs') body') rnCoreExpr (UfLet (UfRec pairs) body) = rnCoreBndrs bndrs $ \ bndrs' -> - mapRn rnCoreExpr rhss `thenRn` \ rhss' -> - rnCoreExpr body `thenRn` \ body' -> - returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body') + mappM rnCoreExpr rhss `thenM` \ rhss' -> + rnCoreExpr body `thenM` \ body' -> + returnM (UfLet (UfRec (bndrs' `zip` rhss')) body') where (bndrs, rhss) = unzip pairs \end{code} \begin{code} rnCoreBndr (UfValBinder name ty) thing_inside - = rnHsType doc ty `thenRn` \ ty' -> + = rnHsType doc ty `thenM` \ ty' -> bindCoreLocalRn name $ \ name' -> thing_inside (UfValBinder name' ty') where @@ -668,60 +815,90 @@ rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b $ \ name' -> \begin{code} rnCoreAlt (con, bndrs, rhs) - = rnUfCon con `thenRn` \ con' -> + = rnUfCon con `thenM` \ con' -> bindCoreLocalsRn bndrs $ \ bndrs' -> - rnCoreExpr rhs `thenRn` \ rhs' -> - returnRn (con', bndrs', rhs') + rnCoreExpr rhs `thenM` \ rhs' -> + returnM (con', bndrs', rhs') rnNote (UfCoerce ty) - = rnHsType (text "unfolding coerce") ty `thenRn` \ ty' -> - returnRn (UfCoerce ty') + = rnHsType (text "unfolding coerce") ty `thenM` \ ty' -> + returnM (UfCoerce ty') -rnNote (UfSCC cc) = returnRn (UfSCC cc) -rnNote UfInlineCall = returnRn UfInlineCall -rnNote UfInlineMe = returnRn UfInlineMe +rnNote (UfSCC cc) = returnM (UfSCC cc) +rnNote UfInlineCall = returnM UfInlineCall +rnNote UfInlineMe = returnM UfInlineMe rnUfCon UfDefault - = returnRn UfDefault + = returnM UfDefault -rnUfCon (UfTupleAlt (HsTupCon _ boxity arity)) - = returnRn (UfTupleAlt (HsTupCon tup_name boxity arity)) - where - tup_name = getName (tupleCon boxity arity) +rnUfCon (UfTupleAlt tup_con) + = returnM (UfTupleAlt tup_con) rnUfCon (UfDataAlt con) - = lookupOccRn con `thenRn` \ con' -> - returnRn (UfDataAlt con') + = lookupOccRn con `thenM` \ con' -> + returnM (UfDataAlt con') rnUfCon (UfLitAlt lit) - = returnRn (UfLitAlt lit) + = returnM (UfLitAlt lit) rnUfCon (UfLitLitAlt lit ty) - = rnHsType (text "litlit") ty `thenRn` \ ty' -> - returnRn (UfLitLitAlt lit ty') + = rnHsType (text "litlit") ty `thenM` \ ty' -> + returnM (UfLitLitAlt lit ty') \end{code} %********************************************************* -%* * -\subsection{Rule shapes} -%* * +%* * +\subsection{Statistics} +%* * %********************************************************* -Check the shape of a transformation rule LHS. Currently -we only allow LHSs of the form @(f e1 .. en)@, where @f@ is -not one of the @forall@'d variables. - \begin{code} -validRuleLhs foralls lhs - = check lhs +rnStats :: [RenamedHsDecl] -- Imported decls + -> TcRn m () +rnStats imp_decls + = doptM Opt_D_dump_rn_trace `thenM` \ dump_rn_trace -> + doptM Opt_D_dump_rn_stats `thenM` \ dump_rn_stats -> + doptM Opt_D_dump_rn `thenM` \ dump_rn -> + getEps `thenM` \ eps -> + + ioToTcRn (dumpIfSet (dump_rn_trace || dump_rn_stats || dump_rn) + "Renamer statistics" + (getRnStats eps imp_decls)) `thenM_` + returnM () + +getRnStats :: ExternalPackageState -> [RenamedHsDecl] -> SDoc +getRnStats eps imported_decls + = hcat [text "Renamer stats: ", stats] where - check (OpApp _ op _ _) = check op - check (HsApp e1 e2) = check e1 - check (HsVar v) | v `notElem` foralls = True - check other = False -\end{code} + n_mods = length [() | _ <- moduleEnvElts (eps_PIT eps)] + -- This is really only right for a one-shot compile + (decls_map, n_decls_slurped) = eps_decls eps + + n_decls_left = length [decl | (avail, True, (_,decl)) <- nameEnvElts decls_map + -- Data, newtype, and class decls are in the decls_fm + -- under multiple names; the tycon/class, and each + -- constructor/class op too. + -- The 'True' selects just the 'main' decl + ] + + (insts_left, n_insts_slurped) = eps_insts eps + n_insts_left = length (bagToList insts_left) + + (rules_left, n_rules_slurped) = eps_rules eps + n_rules_left = length (bagToList rules_left) + + stats = vcat + [int n_mods <+> text "interfaces read", + hsep [ int n_decls_slurped, text "type/class/variable imported, out of", + int (n_decls_slurped + n_decls_left), text "read"], + hsep [ int n_insts_slurped, text "instance decls imported, out of", + int (n_insts_slurped + n_insts_left), text "read"], + hsep [ int n_rules_slurped, text "rule decls imported, out of", + int (n_rules_slurped + n_rules_left), text "read"] + ] +\end{code} %********************************************************* %* * diff --git a/ghc/compiler/rename/RnTypes.lhs b/ghc/compiler/rename/RnTypes.lhs index 35ab81b332..4d59426817 100644 --- a/ghc/compiler/rename/RnTypes.lhs +++ b/ghc/compiler/rename/RnTypes.lhs @@ -11,12 +11,13 @@ import CmdLineOpts ( DynFlag(Opt_WarnMisc, Opt_WarnUnusedMatches, Opt_GlasgowExt import HsSyn import RdrHsSyn ( RdrNameContext, RdrNameHsType, extractHsTyRdrTyVars, extractHsCtxtRdrTyVars ) -import RnHsSyn ( RenamedContext, RenamedHsType, extractHsTyNames, tupleTyCon_name ) +import RnHsSyn ( RenamedContext, RenamedHsType, extractHsTyNames ) import RnEnv ( lookupOccRn, newIPName, bindTyVarsRn, lookupFixityRn ) -import RnMonad +import TcRnMonad import PrelInfo ( cCallishClassKeys ) import RdrName ( elemRdrEnv ) +import Name ( Name ) import NameSet ( FreeVars ) import Unique ( Uniquable(..) ) @@ -38,17 +39,17 @@ to break several loop. %********************************************************* \begin{code} -rnHsTypeFVs :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars) +rnHsTypeFVs :: SDoc -> RdrNameHsType -> RnM (RenamedHsType, FreeVars) rnHsTypeFVs doc_str ty - = rnHsType doc_str ty `thenRn` \ ty' -> - returnRn (ty', extractHsTyNames ty') + = rnHsType doc_str ty `thenM` \ ty' -> + returnM (ty', extractHsTyNames ty') -rnHsSigTypeFVs :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars) +rnHsSigTypeFVs :: SDoc -> RdrNameHsType -> RnM (RenamedHsType, FreeVars) rnHsSigTypeFVs doc_str ty - = rnHsSigType doc_str ty `thenRn` \ ty' -> - returnRn (ty', extractHsTyNames ty') + = rnHsSigType doc_str ty `thenM` \ ty' -> + returnM (ty', extractHsTyNames ty') -rnHsSigType :: SDoc -> RdrNameHsType -> RnMS RenamedHsType +rnHsSigType :: SDoc -> RdrNameHsType -> RnM RenamedHsType -- rnHsSigType is used for source-language type signatures, -- which use *implicit* universal quantification. rnHsSigType doc_str ty @@ -59,13 +60,13 @@ rnHsType is here because we call it from loadInstDecl, and I didn't want a gratuitous knot. \begin{code} -rnHsType :: SDoc -> RdrNameHsType -> RnMS RenamedHsType +rnHsType :: SDoc -> RdrNameHsType -> RnM RenamedHsType rnHsType doc (HsForAllTy Nothing ctxt ty) -- Implicit quantifiction in source code (no kinds on tyvars) -- Given the signature C => T we universally quantify -- over FV(T) \ {in-scope-tyvars} - = getLocalNameEnv `thenRn` \ name_env -> + = getLocalRdrEnv `thenM` \ name_env -> let mentioned_in_tau = extractHsTyRdrTyVars ty mentioned_in_ctxt = extractHsCtxtRdrTyVars ctxt @@ -92,83 +93,80 @@ rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau) -- Explicitly quantified but not mentioned in ctxt or tau warn_guys = filter (`notElem` mentioned) forall_tyvar_names in - mapRn_ (forAllWarn doc tau) warn_guys `thenRn_` + mappM_ (forAllWarn doc tau) warn_guys `thenM_` rnForAll doc forall_tyvars ctxt tau rnHsType doc (HsTyVar tyvar) - = lookupOccRn tyvar `thenRn` \ tyvar' -> - returnRn (HsTyVar tyvar') + = lookupOccRn tyvar `thenM` \ tyvar' -> + returnM (HsTyVar tyvar') rnHsType doc (HsOpTy ty1 op ty2) = (case op of - HsArrow -> returnRn HsArrow - HsTyOp n -> lookupOccRn n `thenRn` \ n' -> - returnRn (HsTyOp n') - ) `thenRn` \ op' -> - rnHsType doc ty1 `thenRn` \ ty1' -> - rnHsType doc ty2 `thenRn` \ ty2' -> - lookupTyFixityRn op' `thenRn` \ fix -> + HsArrow -> returnM HsArrow + HsTyOp n -> lookupOccRn n `thenM` \ n' -> + returnM (HsTyOp n') + ) `thenM` \ op' -> + rnHsType doc ty1 `thenM` \ ty1' -> + rnHsType doc ty2 `thenM` \ ty2' -> + lookupTyFixityRn op' `thenM` \ fix -> mkHsOpTyRn op' fix ty1' ty2' rnHsType doc (HsParTy ty) - = rnHsType doc ty `thenRn` \ ty' -> - returnRn (HsParTy ty') + = rnHsType doc ty `thenM` \ ty' -> + returnM (HsParTy ty') rnHsType doc (HsNumTy i) - | i == 1 = returnRn (HsNumTy i) - | otherwise = failWithRn (HsNumTy i) - (ptext SLIT("Only unit numeric type pattern is valid")) + | i == 1 = returnM (HsNumTy i) + | otherwise = addErr err_msg `thenM_` returnM (HsNumTy i) + where + err_msg = ptext SLIT("Only unit numeric type pattern is valid") + rnHsType doc (HsFunTy ty1 ty2) - = rnHsType doc ty1 `thenRn` \ ty1' -> + = rnHsType doc ty1 `thenM` \ ty1' -> -- Might find a for-all as the arg of a function type - rnHsType doc ty2 `thenRn` \ ty2' -> + rnHsType doc ty2 `thenM` \ ty2' -> -- Or as the result. This happens when reading Prelude.hi -- when we find return :: forall m. Monad m -> forall a. a -> m a - returnRn (HsFunTy ty1' ty2') + returnM (HsFunTy ty1' ty2') rnHsType doc (HsListTy ty) - = rnHsType doc ty `thenRn` \ ty' -> - returnRn (HsListTy ty') + = rnHsType doc ty `thenM` \ ty' -> + returnM (HsListTy ty') rnHsType doc (HsKindSig ty k) - = rnHsType doc ty `thenRn` \ ty' -> - returnRn (HsKindSig ty' k) + = rnHsType doc ty `thenM` \ ty' -> + returnM (HsKindSig ty' k) rnHsType doc (HsPArrTy ty) - = rnHsType doc ty `thenRn` \ ty' -> - returnRn (HsPArrTy ty') + = rnHsType doc ty `thenM` \ ty' -> + returnM (HsPArrTy ty') -- Unboxed tuples are allowed to have poly-typed arguments. These -- sometimes crop up as a result of CPR worker-wrappering dictionaries. -rnHsType doc (HsTupleTy (HsTupCon _ boxity arity) tys) - -- Don't do lookupOccRn, because this is built-in syntax - -- so it doesn't need to be in scope - = mapRn (rnHsType doc) tys `thenRn` \ tys' -> - returnRn (HsTupleTy (HsTupCon tup_name boxity arity) tys') - where - tup_name = tupleTyCon_name boxity arity - +rnHsType doc (HsTupleTy tup_con tys) + = mappM (rnHsType doc) tys `thenM` \ tys' -> + returnM (HsTupleTy tup_con tys') rnHsType doc (HsAppTy ty1 ty2) - = rnHsType doc ty1 `thenRn` \ ty1' -> - rnHsType doc ty2 `thenRn` \ ty2' -> - returnRn (HsAppTy ty1' ty2') + = rnHsType doc ty1 `thenM` \ ty1' -> + rnHsType doc ty2 `thenM` \ ty2' -> + returnM (HsAppTy ty1' ty2') rnHsType doc (HsPredTy pred) - = rnPred doc pred `thenRn` \ pred' -> - returnRn (HsPredTy pred') + = rnPred doc pred `thenM` \ pred' -> + returnM (HsPredTy pred') -rnHsTypes doc tys = mapRn (rnHsType doc) tys +rnHsTypes doc tys = mappM (rnHsType doc) tys \end{code} \begin{code} rnForAll doc forall_tyvars ctxt ty = bindTyVarsRn doc forall_tyvars $ \ new_tyvars -> - rnContext doc ctxt `thenRn` \ new_ctxt -> - rnHsType doc ty `thenRn` \ new_ty -> - returnRn (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty) + rnContext doc ctxt `thenM` \ new_ctxt -> + rnHsType doc ty `thenM` \ new_ty -> + returnM (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty) \end{code} @@ -188,39 +186,39 @@ have already been renamed and rearranged. It's made rather tiresome by the presence of -> \begin{code} -lookupTyFixityRn HsArrow = returnRn arrowFixity +lookupTyFixityRn HsArrow = returnM arrowFixity lookupTyFixityRn (HsTyOp n) - = doptRn Opt_GlasgowExts `thenRn` \ glaExts -> - warnCheckRn glaExts (infixTyConWarn n) `thenRn_` + = doptM Opt_GlasgowExts `thenM` \ glaExts -> + warnIf (not glaExts) (infixTyConWarn n) `thenM_` lookupFixityRn n -- Building (ty1 `op1` (ty21 `op2` ty22)) mkHsOpTyRn :: HsTyOp Name -> Fixity -> RenamedHsType -> RenamedHsType - -> RnMS RenamedHsType + -> RnM RenamedHsType mkHsOpTyRn op1 fix1 ty1 ty2@(HsOpTy ty21 op2 ty22) - = lookupTyFixityRn op2 `thenRn` \ fix2 -> + = lookupTyFixityRn op2 `thenM` \ fix2 -> let (nofix_error, associate_right) = compareFixity fix1 fix2 in if nofix_error then - addErrRn (precParseErr (quotes (ppr op1),fix1) - (quotes (ppr op2),fix2)) `thenRn_` - returnRn (HsOpTy ty1 op1 ty2) + addErr (precParseErr (quotes (ppr op1),fix1) + (quotes (ppr op2),fix2)) `thenM_` + returnM (HsOpTy ty1 op1 ty2) else if not associate_right then -- Rearrange to ((ty1 `op1` ty21) `op2` ty22) - mkHsOpTyRn op1 fix1 ty1 ty21 `thenRn` \ new_ty -> - returnRn (HsOpTy new_ty op2 ty22) + mkHsOpTyRn op1 fix1 ty1 ty21 `thenM` \ new_ty -> + returnM (HsOpTy new_ty op2 ty22) else - returnRn (HsOpTy ty1 op1 ty2) + returnM (HsOpTy ty1 op1 ty2) mkHsOpTyRn op fix ty1 ty2 -- Default case, no rearrangment - = returnRn (HsOpTy ty1 op ty2) + = returnM (HsOpTy ty1 op ty2) mkHsFunTyRn ty1 ty2 -- Precedence of function arrow is 0 - = returnRn (HsFunTy ty1 ty2) -- so no rearrangement reqd. Change + = returnM (HsFunTy ty1 ty2) -- so no rearrangement reqd. Change -- this if fixity of -> increases. not_op_ty (HsOpTy _ _ _) = False @@ -234,45 +232,45 @@ not_op_ty other = True %********************************************************* \begin{code} -rnContext :: SDoc -> RdrNameContext -> RnMS RenamedContext +rnContext :: SDoc -> RdrNameContext -> RnM RenamedContext rnContext doc ctxt - = mapRn rn_pred ctxt `thenRn` \ theta -> + = mappM rn_pred ctxt `thenM` \ theta -> -- Check for duplicate assertions -- If this isn't an error, then it ought to be: - ifOptRn Opt_WarnMisc ( + ifOptM Opt_WarnMisc ( let (_, dups) = removeDupsEq theta -- We only have equality, not ordering in - mapRn (addWarnRn . dupClassAssertWarn theta) dups - ) `thenRn_` + mappM_ (addWarn . dupClassAssertWarn theta) dups + ) `thenM_` - returnRn theta + returnM theta where --Someone discovered that @CCallable@ and @CReturnable@ -- could be used in contexts such as: -- foo :: CCallable a => a -> PrimIO Int -- Doing this utterly wrecks the whole point of introducing these -- classes so we specifically check that this isn't being done. - rn_pred pred = rnPred doc pred `thenRn` \ pred'-> - checkRn (not (bad_pred pred')) - (naughtyCCallContextErr pred') `thenRn_` - returnRn pred' + rn_pred pred = rnPred doc pred `thenM` \ pred'-> + checkErr (not (bad_pred pred')) + (naughtyCCallContextErr pred') `thenM_` + returnM pred' bad_pred (HsClassP clas _) = getUnique clas `elem` cCallishClassKeys bad_pred other = False rnPred doc (HsClassP clas tys) - = lookupOccRn clas `thenRn` \ clas_name -> - rnHsTypes doc tys `thenRn` \ tys' -> - returnRn (HsClassP clas_name tys') + = lookupOccRn clas `thenM` \ clas_name -> + rnHsTypes doc tys `thenM` \ tys' -> + returnM (HsClassP clas_name tys') rnPred doc (HsIParam n ty) - = newIPName n `thenRn` \ name -> - rnHsType doc ty `thenRn` \ ty' -> - returnRn (HsIParam name ty') + = newIPName n `thenM` \ name -> + rnHsType doc ty `thenM` \ ty' -> + returnM (HsIParam name ty') \end{code} @@ -285,16 +283,16 @@ rnPred doc (HsIParam n ty) \end{code} \begin{code} forAllWarn doc ty tyvar - = ifOptRn Opt_WarnUnusedMatches $ - getModeRn `thenRn` \ mode -> + = ifOptM Opt_WarnUnusedMatches $ + getModeRn `thenM` \ mode -> case mode of { #ifndef DEBUG - InterfaceMode -> returnRn () ; -- Don't warn of unused tyvars in interface files + InterfaceMode _ -> returnM () ; -- Don't warn of unused tyvars in interface files -- unless DEBUG is on, in which case it is slightly -- informative. They can arise from mkRhsTyLam, #endif -- leading to (say) f :: forall a b. [b] -> [b] other -> - addWarnRn ( + addWarn ( sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar), nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))] $$ |