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 TcTyClsDecls ( tcTyAndClassDecls )
import LoadIface ( loadOrphanModules )
import RnNames ( importsFromLocalDecls, rnImports, rnExports,
+ mkRdrEnvAndImports, mkExportNameSet,
reportUnusedNames, reportDeprecations )
import RnEnv ( lookupSrcOcc_maybe )
import RnSource ( rnSrcDecls, rnTyClDecls, checkModDeprec )
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 TyCon ( tyConHasGenerics, isSynTyCon, synTyConDefn, tyConKind )
import SrcLoc ( srcLocSpan, Located(..), noLoc )
import DriverPhases ( HscSource(..), isHsBoot )
import HscTypes ( ModGuts(..), ModDetails(..), emptyModDetails,
import Outputable
#ifdef GHCI
-import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..), HsBindGroup(..),
- LStmt, LHsExpr, LHsType, mkVarBind,
+import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..),
+ HsLocalBinds(..), HsValBinds(..),
+ LStmt, LHsExpr, LHsType, mkMatch, emptyLocalBinds,
collectLStmtsBinders, collectLStmtBinders, nlVarPat,
- placeHolderType, noSyntaxExpr )
+ mkFunBind, 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 )
-> Located (HsModule RdrName)
-> IO (Messages, Maybe TcGblEnv)
-tcRnModule hsc_env hsc_src save_rn_decls
+tcRnModule hsc_env hsc_src save_rn_syntax
(L loc (HsModule maybe_mod export_ies
import_decls local_decls mod_deprec))
= do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
initTc hsc_env hsc_src this_mod $
setSrcSpan loc $
do {
- -- Deal with imports; sets tcg_rdr_env, tcg_imports
- (rdr_env, imports) <- rnImports import_decls ;
+ -- Deal with imports;
+ rn_imports <- rnImports import_decls ;
+ (rdr_env, imports) <- mkRdrEnvAndImports rn_imports ;
let { dep_mods :: ModuleEnv (Module, IsBootInterface)
; dep_mods = imp_dep_mods imports
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
+ tcg_rn_imports = if save_rn_syntax then
+ Just rn_imports
+ else
+ Nothing,
+ tcg_rn_decls = if save_rn_syntax then
+ Just emptyRnGroup
else
Nothing })
$ do {
reportDeprecations tcg_env ;
-- Process the export list
- exports <- rnExports (isJust maybe_mod) export_ies ;
+ rn_exports <- rnExports export_ies ;
+ exports <- mkExportNameSet (isJust maybe_mod) rn_exports ;
-- Check whether the entire module is deprecated
-- This happens only once per module
-- Add exports and deprecations to envt
let { final_env = tcg_env { tcg_exports = exports,
+ tcg_rn_exports = if save_rn_syntax then
+ rn_exports
+ else Nothing,
tcg_dus = tcg_dus tcg_env `plusDU` usesOnly exports,
tcg_deprecs = tcg_deprecs tcg_env `plusDeprecs`
mod_deprecs }
}}}}
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}
TcGblEnv { tcg_type_env = type_env, tcg_binds = binds,
tcg_rules = rules, tcg_fords = fords } = tcg_env } ;
+ tcDump tcg_env ;
(bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds)
rules fords ;
| tyConKind boot_tc == tyConKind real_tc
= return ()
where
- (tvs1, defn1) = getSynTyConDefn boot_tc
- (tvs2, defn2) = getSynTyConDefn boot_tc
+ (tvs1, defn1) = synTyConDefn boot_tc
+ (tvs2, defn2) = synTyConDefn boot_tc
check_thing (AnId boot_id) (AnId real_id)
| idType boot_id `tcEqType` idType real_id
-- 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,
checkMain :: TcM TcGblEnv
-- If we are in module Main, check that 'main' is defined.
checkMain
- = do { ghci_mode <- getGhciMode ;
+ = do { ghc_mode <- getGhcMode ;
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
+ check_main ghc_mode tcg_env main_mod main_fn
}
-check_main ghci_mode tcg_env main_mod main_fn
+check_main ghc_mode tcg_env main_mod main_fn
| mod /= main_mod
= traceTc (text "checkMain not" <+> ppr main_mod <+> ppr mod) >>
return tcg_env
; (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,
where
mod = tcg_mod tcg_env
- complain_no_main | ghci_mode == Interactive = return ()
+ complain_no_main | ghc_mode == Interactive = return ()
| otherwise = failWithTc noMainMsg
-- In interactive mode, don't worry about the absence of 'main'
-- In other modes, fail altogether, so that we don't go on
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 $ mkFunBind (L loc fresh_it) matches
+ matches = [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))
-- OK, we're ready to typecheck the stmts
traceTc (text "tcs 2") ;
((tc_stmts, ids), lie) <- getLIE $
- tcStmts DoExpr (tcDoStmt io_ty io_ret_ty) stmts $
+ tcStmts DoExpr (tcDoStmt io_ty) stmts io_ret_ty $ \ _ ->
mappM tcLookupId names ;
-- Look up the names right in the middle,
-- where they will all be in scope
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