summaryrefslogtreecommitdiff
path: root/ghc/compiler/rename
diff options
context:
space:
mode:
authorsimonpj <unknown>2002-09-13 15:02:50 +0000
committersimonpj <unknown>2002-09-13 15:02:50 +0000
commit9af77fa423926fbda946b31e174173d0ec5ebac8 (patch)
tree140cc94aa3e04f6e50c4bf07ceb0efe67d11b9c6 /ghc/compiler/rename
parent69e55e7476392a2b59b243a32065350c258d4970 (diff)
downloadhaskell-9af77fa423926fbda946b31e174173d0ec5ebac8.tar.gz
[project @ 2002-09-13 15:02:25 by simonpj]
-------------------------------------- Make Template Haskell into the HEAD -------------------------------------- This massive commit transfers to the HEAD all the stuff that Simon and Tim have been doing on Template Haskell. The meta-haskell-branch is no more! WARNING: make sure that you * Update your links if you are using link trees. Some modules have been added, some have gone away. * Do 'make clean' in all library trees. The interface file format has changed, and you can get strange panics (sadly) if GHC tries to read old interface files: e.g. ghc-5.05: panic! (the `impossible' happened, GHC version 5.05): Binary.get(TyClDecl): ForeignType * You need to recompile the rts too; Linker.c has changed However the libraries are almost unaltered; just a tiny change in Base, and to the exports in Prelude. NOTE: so far as TH itself is concerned, expression splices work fine, but declaration splices are not complete. --------------- The main change --------------- The main structural change: renaming and typechecking have to be interleaved, because we can't rename stuff after a declaration splice until after we've typechecked the stuff before (and the splice itself). * Combine the renamer and typecheker monads into one (TcRnMonad, TcRnTypes) These two replace TcMonad and RnMonad * Give them a single 'driver' (TcRnDriver). This driver replaces TcModule.lhs and Rename.lhs * The haskell-src library package has a module Language/Haskell/THSyntax which defines the Haskell data type seen by the TH programmer. * New modules: hsSyn/Convert.hs converts THSyntax -> HsSyn deSugar/DsMeta.hs converts HsSyn -> THSyntax * New module typecheck/TcSplice type-checks Template Haskell splices. ------------- Linking stuff ------------- * ByteCodeLink has been split into ByteCodeLink (which links) ByteCodeAsm (which assembles) * New module ghci/ObjLink is the object-code linker. * compMan/CmLink is removed entirely (was out of place) Ditto CmTypes (which was tiny) * Linker.c initialises the linker when it is first used (no need to call initLinker any more). Template Haskell makes it harder to know when and whether to initialise the linker. ------------------------------------- Gathering the LIE in the type checker ------------------------------------- * Instead of explicitly gathering constraints in the LIE tcExpr :: RenamedExpr -> TcM (TypecheckedExpr, LIE) we now dump the constraints into a mutable varabiable carried by the monad, so we get tcExpr :: RenamedExpr -> TcM TypecheckedExpr Much less clutter in the code, and more efficient too. (Originally suggested by Mark Shields.) ----------------- Remove "SysNames" ----------------- Because the renamer and the type checker were entirely separate, we had to carry some rather tiresome implicit binders (or "SysNames") along inside some of the HsDecl data structures. They were both tiresome and fragile. Now that the typechecker and renamer are more intimately coupled, we can eliminate SysNames (well, mostly... default methods still carry something similar). ------------- Clean up HsPat ------------- One big clean up is this: instead of having two HsPat types (InPat and OutPat), they are now combined into one. This is more consistent with the way that HsExpr etc is handled; there are some 'Out' constructors for the type checker output. So: HsPat.InPat --> HsPat.Pat HsPat.OutPat --> HsPat.Pat No 'pat' type parameter in HsExpr, HsBinds, etc Constructor patterns are nicer now: they use HsPat.HsConDetails for the three cases of constructor patterns: prefix, infix, and record-bindings The *same* data type HsConDetails is used in the type declaration of the data type (HsDecls.TyData) Lots of associated clean-up operations here and there. Less code. Everything is wonderful.
Diffstat (limited to 'ghc/compiler/rename')
-rw-r--r--ghc/compiler/rename/Rename.lhs1048
-rw-r--r--ghc/compiler/rename/RnBinds.hi-boot5
-rw-r--r--ghc/compiler/rename/RnBinds.hi-boot-53
-rw-r--r--ghc/compiler/rename/RnBinds.hi-boot-66
-rw-r--r--ghc/compiler/rename/RnBinds.lhs197
-rw-r--r--ghc/compiler/rename/RnEnv.lhs988
-rw-r--r--ghc/compiler/rename/RnExpr.lhs762
-rw-r--r--ghc/compiler/rename/RnHiFiles.hi-boot-53
-rw-r--r--ghc/compiler/rename/RnHiFiles.hi-boot-64
-rw-r--r--ghc/compiler/rename/RnHiFiles.lhs667
-rw-r--r--ghc/compiler/rename/RnHsSyn.lhs51
-rw-r--r--ghc/compiler/rename/RnIfaces.lhs820
-rw-r--r--ghc/compiler/rename/RnMonad.lhs760
-rw-r--r--ghc/compiler/rename/RnNames.lhs684
-rw-r--r--ghc/compiler/rename/RnSource.hi-boot-512
-rw-r--r--ghc/compiler/rename/RnSource.hi-boot-610
-rw-r--r--ghc/compiler/rename/RnSource.lhs745
-rw-r--r--ghc/compiler/rename/RnTypes.lhs168
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))]
$$
View Lorry Controller Status