import DynFlags ( DynFlag(..), DynFlags(..), dopt, GhcMode(..) )
import StaticFlags ( opt_PprStyle_Debug )
-import Packages ( moduleToPackageConfig, mkPackageId, package,
- isHomeModule )
+import Packages ( checkForPackageConflicts, mkHomeModules )
import HsSyn ( HsModule(..), HsExtCore(..), HsGroup(..), LHsDecl,
SpliceDecl(..), HsBind(..), LHsBinds,
- emptyGroup, appendGroups,
+ emptyRdrGroup, emptyRnGroup, appendGroups, plusHsValBinds,
nlHsApp, nlHsVar, pprLHsBinds )
import RdrHsSyn ( findSplice )
-import PrelNames ( runMainIOName, rootMainName, mAIN,
+import PrelNames ( runMainIOName, rootMainKey, rOOT_MAIN, mAIN,
main_RDR_Unqual )
import RdrName ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv )
import TcHsSyn ( zonkTopDecls )
import ErrUtils ( Messages, mkDumpDoc, showPass )
import Id ( Id, mkExportedLocalId, isLocalId, idName, idType )
import Var ( Var )
-import Module ( Module, ModuleEnv, mkModule, moduleEnvElts, elemModuleEnv )
-import OccName ( mkVarOcc )
-import Name ( Name, NamedThing(..), isExternalName, getSrcLoc, isWiredInName )
+import Module ( Module, ModuleEnv, moduleEnvElts, elemModuleEnv )
+import OccName ( mkVarOccFS )
+import Name ( Name, NamedThing(..), isExternalName, getSrcLoc, isWiredInName,
+ mkExternalName )
import NameSet
import TyCon ( tyConHasGenerics, isSynTyCon, getSynTyConDefn, tyConKind )
import SrcLoc ( srcLocSpan, Located(..), noLoc )
import Outputable
#ifdef GHCI
-import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..), HsBindGroup(..),
- LStmt, LHsExpr, LHsType, mkVarBind,
+import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..),
+ HsLocalBinds(..), HsValBinds(..),
+ LStmt, LHsExpr, LHsType, mkMatchGroup, mkMatch, emptyLocalBinds,
collectLStmtsBinders, collectLStmtBinders, nlVarPat,
placeHolderType, noSyntaxExpr )
import RdrName ( GlobalRdrElt(..), globalRdrEnvElts,
unQualOK, lookupLocalRdrEnv, extendLocalRdrEnv )
import RnSource ( addTcgDUs )
-import TcHsSyn ( mkHsLet, zonkTopLExpr, zonkTopBndrs )
+import TcHsSyn ( mkHsDictLet, zonkTopLExpr, zonkTopBndrs )
import TcHsType ( kcHsType )
import TcMType ( zonkTcType, zonkQuantifiedTyVar )
import TcMatches ( tcStmts, tcDoStmt )
import HscTypes ( InteractiveContext(..),
ModIface(..), icPrintUnqual,
Dependencies(..) )
-import BasicTypes ( RecFlag(..), Fixity )
-import SrcLoc ( unLoc, noSrcSpan )
+import BasicTypes ( Fixity, RecFlag(..) )
+import SrcLoc ( unLoc )
#endif
import FastString ( mkFastString )
+import Maybes ( MaybeErr(..) )
import Util ( sortLe )
import Bag ( unionBags, snocBag, emptyBag, unitBag, unionManyBags )
initTc hsc_env hsc_src this_mod $
setSrcSpan loc $
do {
- checkForPackageModule (hsc_dflags hsc_env) this_mod;
-
-- Deal with imports; sets tcg_rdr_env, tcg_imports
(rdr_env, imports) <- rnImports import_decls ;
-- and any other incrementally-performed imports
updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ;
+ checkConflicts imports this_mod $ do {
+
-- Update the gbl env
updGblEnv ( \ gbl ->
gbl { tcg_rdr_env = rdr_env,
tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts,
tcg_imports = tcg_imports gbl `plusImportAvails` imports,
tcg_rn_decls = if save_rn_decls then
- Just emptyGroup
+ Just emptyRnGroup
else
Nothing })
$ do {
-- Dump output and return
tcDump final_env ;
return final_env
- }}}}
-
--- This is really a sanity check that the user has given -package-name
--- if necessary. -package-name is only necessary when the package database
--- already contains the current package, because then we can't tell
--- whether a given module is in the current package or not, without knowing
--- the name of the current package.
-checkForPackageModule dflags this_mod
- | not (isHomeModule dflags this_mod),
- Just (pkg,_) <- moduleToPackageConfig dflags this_mod =
- let
- ppr_pkg = ppr (mkPackageId (package pkg))
- in
- addErr (ptext SLIT("Module") <+> quotes (ppr this_mod) <+>
- ptext SLIT("is a member of package") <+> ppr_pkg <> char '.' $$
- ptext SLIT("To compile this module, please use -ignore-package") <+> ppr_pkg <> char '.')
- | otherwise = return ()
+ }}}}}
+
+
+-- The program is not allowed to contain two modules with the same
+-- name, and we check for that here. It could happen if the home package
+-- contains a module that is also present in an external package, for example.
+checkConflicts imports this_mod and_then = do
+ dflags <- getDOpts
+ let
+ dep_mods = this_mod : map fst (moduleEnvElts (imp_dep_mods imports))
+ -- don't forget to include the current module!
+
+ mb_dep_pkgs = checkForPackageConflicts
+ dflags dep_mods (imp_dep_pkgs imports)
+ --
+ case mb_dep_pkgs of
+ Failed msg ->
+ do addErr msg; failM
+ Succeeded _ ->
+ updGblEnv (\gbl -> gbl{ tcg_home_mods = mkHomeModules dep_mods })
+ and_then
\end{code}
mg_usages = [], -- ToDo: compute usage
mg_dir_imps = [], -- ??
mg_deps = noDependencies, -- ??
+ mg_home_mods = mkHomeModules [], -- ?? wrong!!
mg_exports = my_exports,
mg_types = final_type_env,
mg_insts = tcg_insts tcg_env,
}}}}
mkFakeGroup decls -- Rather clumsy; lots of unused fields
- = HsGroup { hs_tyclds = decls, -- This is the one we want
- hs_valds = [], hs_fords = [],
- hs_instds = [], hs_fixds = [], hs_depds = [],
- hs_ruleds = [], hs_defds = [] }
+ = emptyRdrGroup { hs_tyclds = decls }
\end{code}
-- We also typecheck any extra binds that came out
-- of the "deriving" process (deriv_binds)
traceTc (text "Tc5") ;
- (tc_val_binds, tcl_env) <- tcTopBinds (val_binds ++ deriv_binds) ;
+ (tc_val_binds, tcl_env) <- tcTopBinds (val_binds `plusHsValBinds` deriv_binds) ;
setLclTypeEnv tcl_env $ do {
-- Second pass over class and instance declarations,
= do { ghci_mode <- getGhciMode ;
tcg_env <- getGblEnv ;
dflags <- getDOpts ;
- let { main_mod = case mainModIs dflags of {
- Just mod -> mkModule mod ;
- Nothing -> mAIN } ;
+ let { main_mod = mainModIs dflags ;
main_fn = case mainFunIs dflags of {
- Just fn -> mkRdrUnqual (mkVarOcc (mkFastString fn)) ;
+ Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn)) ;
Nothing -> main_RDR_Unqual } } ;
check_main ghci_mode tcg_env main_mod main_fn
; (main_expr, ty) <- setSrcSpan (srcLocSpan (getSrcLoc main_name)) $
tcInferRho rhs
- ; let { root_main_id = mkExportedLocalId rootMainName ty ;
- main_bind = noLoc (VarBind root_main_id main_expr) }
+ -- The function that the RTS invokes is always :Main.main,
+ -- which we call root_main_id.
+ -- (Because GHC allows the user to have a module not called
+ -- Main as the main module, we can't rely on the main function
+ -- being called "Main.main". That's why root_main_id has a fixed
+ -- module ":Main".)
+ -- We also make root_main_id an implicit Id, by making main_name
+ -- its parent (hence (Just main_name)). That has the effect
+ -- of preventing its type and unfolding from getting out into
+ -- the interface file. Otherwise we can end up with two defns
+ -- for 'main' in the interface file!
+
+ ; let { root_main_name = mkExternalName rootMainKey rOOT_MAIN
+ (mkVarOccFS FSLIT("main"))
+ (Just main_name) (getSrcLoc main_name)
+ ; root_main_id = mkExportedLocalId root_main_name ty
+ ; main_bind = noLoc (VarBind root_main_id main_expr) }
; return (tcg_env { tcg_binds = tcg_binds tcg_env
`snocBag` main_bind,
mkPlan (L loc (ExprStmt expr _ _)) -- An expression typed at the prompt
= do { uniq <- newUnique -- is treated very specially
; let fresh_it = itName uniq
- the_bind = mkVarBind noSrcSpan fresh_it expr
- let_stmt = L loc $ LetStmt [HsBindGroup (unitBag the_bind) [] NonRecursive]
+ the_bind = L loc $ FunBind (L loc fresh_it) False matches emptyNameSet
+ matches = mkMatchGroup [mkMatch [] expr emptyLocalBinds]
+ let_stmt = L loc $ LetStmt (HsValBinds (ValBindsOut [(NonRecursive,unitBag the_bind)] []))
bind_stmt = L loc $ BindStmt (nlVarPat fresh_it) expr
(HsVar bindIOName) noSyntaxExpr
print_it = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it))
const_binds <- checkNoErrs (tcSimplifyInteractive lie) ;
-- checkNoErrs ensures that the plan fails if context redn fails
- return (ids, mkHsLet const_binds $
+ return (ids, mkHsDictLet const_binds $
noLoc (HsDo DoExpr tc_stmts (mk_return ids) io_ret_ty))
}
\end{code}
projects / ghc-hetmet.git / blobdiff