\begin{code}
module TcRnDriver (
#ifdef GHCI
- mkGlobalContext, getModuleContents,
+ mkGlobalContext, getModuleContents, tcRnStmt, tcRnThing, tcRnExpr,
#endif
tcRnModule, checkOldIface,
importSupportingDecls, tcTopSrcDecls,
- tcRnIface, tcRnExtCore, tcRnStmt, tcRnExpr, tcRnThing
+ tcRnIface, tcRnExtCore
) where
#include "HsVersions.h"
#endif
import CmdLineOpts ( DynFlag(..), opt_PprStyle_Debug, dopt )
+import DriverState ( v_MainModIs, v_MainFunIs )
import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsExpr(..),
Stmt(..), Pat(VarPat), HsStmtContext(..), RuleDecl(..),
HsGroup(..), SpliceDecl(..),
import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameStmt, RdrNameHsExpr,
emptyGroup, mkGroup, findSplice, addImpDecls, main_RDR_Unqual )
-import PrelNames ( iNTERACTIVE, ioTyConName, printName,
- returnIOName, bindIOName, failIOName, thenIOName, runIOName,
- dollarMainName, itName, mAIN_Name
+import PrelNames ( iNTERACTIVE, ioTyConName, printName, monadNames,
+ returnIOName, runIOName,
+ rootMainName, itName, mAIN_Name
)
-import MkId ( unsafeCoerceId )
import RdrName ( RdrName, getRdrName, mkRdrUnqual,
lookupRdrEnv, elemRdrEnv )
zonkTopExpr, zonkTopBndrs
)
-import TcExpr ( tcInferRho )
+import TcExpr ( tcInferRho, tcCheckRho )
import TcRnMonad
-import TcMType ( newTyVarTy, zonkTcType )
-import TcType ( Type, liftedTypeKind,
+import TcType ( Type,
tyVarsOfType, tcFunResultTy, tidyTopType,
mkForAllTys, mkFunTys, mkTyConApp, tcSplitForAllTys
)
-import TcMatches ( tcStmtsAndThen )
-import Inst ( showLIE )
+import Inst ( showLIE, tcStdSyntaxName )
+import MkId ( unsafeCoerceId )
import TcBinds ( tcTopBinds )
import TcClassDcl ( tcClassDecls2 )
import TcDefaults ( tcDefaults )
import TcForeign ( tcForeignImports, tcForeignExports )
import TcIfaceSig ( tcInterfaceSigs, tcCoreBinds )
import TcInstDcls ( tcInstDecls1, tcIfaceInstDecls, tcInstDecls2 )
-import TcSimplify ( tcSimplifyTop, tcSimplifyInfer )
+import TcSimplify ( tcSimplifyTop, tcSimplifyInteractive, tcSimplifyInfer )
import TcTyClsDecls ( tcTyAndClassDecls )
import RnNames ( importsFromLocalDecls, rnImports, exportsFromAvail,
import RnHiFiles ( readIface, loadOldIface )
import RnEnv ( lookupSrcName, lookupOccRn, plusGlobalRdrEnv,
ubiquitousNames, implicitModuleFVs, implicitStmtFVs, dataTcOccs )
-import RnExpr ( rnStmts, rnExpr )
import RnSource ( rnSrcDecls, checkModDeprec, rnStats )
import CoreUnfold ( unfoldingTemplate )
import CoreSyn ( IdCoreRule, Bind(..) )
import PprCore ( pprIdRules, pprCoreBindings )
-import TysWiredIn ( mkListTy, unitTy )
import ErrUtils ( mkDumpDoc, showPass, pprBagOfErrors )
import Id ( Id, mkLocalId, isLocalId, idName, idType, idUnfolding, setIdLocalExported )
-import IdInfo ( GlobalIdDetails(..) )
import Var ( Var, setGlobalIdDetails )
-import Module ( Module, moduleName, moduleUserString, moduleEnvElts )
+import Module ( Module, mkHomeModule, mkModuleName, moduleName, moduleUserString, moduleEnvElts )
+import OccName ( mkVarOcc )
import Name ( Name, isExternalName, getSrcLoc, nameOccName )
-import NameEnv ( delListFromNameEnv )
import NameSet
import TyCon ( tyConGenInfo )
import BasicTypes ( EP(..), RecFlag(..) )
-import SrcLoc ( noSrcLoc )
import Outputable
import HscTypes ( PersistentCompilerState(..), InteractiveContext(..),
ModIface, ModDetails(..), ModGuts(..),
extendLocalRdrEnv, emptyFixityEnv
)
#ifdef GHCI
+import TcMType ( zonkTcType )
+import TcMatches ( tcStmtsAndThen, TcStmtCtxt(..) )
import RdrName ( rdrEnvElts )
+import RnExpr ( rnStmts, rnExpr )
import RnHiFiles ( loadInterface )
import RnEnv ( mkGlobalRdrEnv )
+import TysWiredIn ( mkListTy, unitTy )
+import IdInfo ( GlobalIdDetails(..) )
+import SrcLoc ( noSrcLoc )
+import NameEnv ( delListFromNameEnv )
import HscTypes ( GlobalRdrElt(..), GlobalRdrEnv, ImportReason(..), Provenance(..),
isLocalGRE )
#endif
+import FastString ( mkFastString )
import Panic ( showException )
import List ( partition )
import Util ( sortLt )
-> IO (PersistentCompilerState, Maybe TcGblEnv)
tcRnModule hsc_env pcs
- (HsModule this_mod _ exports import_decls local_decls mod_deprec loc)
+ (HsModule maybe_mod exports import_decls local_decls mod_deprec loc)
= do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
+ let { this_mod = case maybe_mod of
+ Nothing -> mkHomeModule mAIN_Name -- 'module M where' is omitted
+ Just mod -> mod } ; -- The normal case
+
initTc hsc_env pcs this_mod $ addSrcLoc loc $
do { -- Deal with imports; sets tcg_rdr_env, tcg_imports
(rdr_env, imports) <- rnImports import_decls ;
$ do {
-- Process the export list
- export_avails <- exportsFromAvail exports ;
+ export_avails <- exportsFromAvail maybe_mod exports ;
updGblEnv (\gbl -> gbl { tcg_exports = export_avails })
$ do {
%************************************************************************
\begin{code}
+#ifdef GHCI
tcRnStmt :: HscEnv -> PersistentCompilerState
-> InteractiveContext
-> RdrNameStmt
setGblEnv tcg_env $ do {
-- The real work is done here
- ((bound_ids, tc_expr), lie) <- getLIE (tcUserStmt rn_stmt) ;
+ (bound_ids, tc_expr) <- tcUserStmt rn_stmt ;
traceTc (text "tcs 1") ;
let { -- Make all the bound ids "global" ids, now that
---------------------------
tc_stmts stmts
- = do { io_ids <- mappM tcLookupId
- [returnIOName, failIOName, bindIOName, thenIOName] ;
- ioTyCon <- tcLookupTyCon ioTyConName ;
- res_ty <- newTyVarTy liftedTypeKind ;
+ = do { ioTyCon <- tcLookupTyCon ioTyConName ;
let {
- names = collectStmtsBinders stmts ;
- return_id = head io_ids ; -- Rather gruesome
+ ret_ty = mkListTy unitTy ;
+ io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
+
+ names = collectStmtsBinders stmts ;
- io_ty = (\ ty -> mkTyConApp ioTyCon [ty], res_ty) ;
+ stmt_ctxt = SC { sc_what = DoExpr,
+ sc_rhs = check_rhs,
+ sc_body = check_body,
+ sc_ty = ret_ty } ;
+
+ check_rhs rhs rhs_ty = tcCheckRho rhs (mkTyConApp ioTyCon [rhs_ty]) ;
+ check_body body = tcCheckRho body io_ret_ty ;
-- mk_return builds the expression
-- returnIO @ [()] [coerce () x, .., coerce () z]
- mk_return ids = HsApp (TyApp (HsVar return_id) [mkListTy unitTy])
- (ExplicitList unitTy (map mk_item ids)) ;
-
+ --
+ -- Despite the inconvenience of building the type applications etc,
+ -- this *has* to be done in type-annotated post-typecheck form
+ -- because we are going to return a list of *polymorphic* values
+ -- coerced to type (). If we built a *source* stmt
+ -- return [coerce x, ..., coerce z]
+ -- then the type checker would instantiate x..z, and we wouldn't
+ -- get their *polymorphic* values. (And we'd get ambiguity errs
+ -- if they were overloaded, since they aren't applied to anything.)
+ mk_return ret_id ids = HsApp (TyApp (HsVar ret_id) [ret_ty])
+ (ExplicitList unitTy (map mk_item ids)) ;
mk_item id = HsApp (TyApp (HsVar unsafeCoerceId) [idType id, unitTy])
- (HsVar id) } ;
+ (HsVar id) ;
+
+ io_ty = mkTyConApp ioTyCon []
+ } ;
-- OK, we're ready to typecheck the stmts
traceTc (text "tcs 2") ;
- ((ids, tc_stmts), lie) <-
- getLIE $ tcStmtsAndThen combine DoExpr io_ty stmts $
- do {
- -- Look up the names right in the middle,
- -- where they will all be in scope
- ids <- mappM tcLookupId names ;
- return (ids, [ResultStmt (mk_return ids) noSrcLoc])
- } ;
+ ((ids, tc_expr), lie) <- getLIE $ do {
+ (ids, tc_stmts) <- tcStmtsAndThen combine stmt_ctxt stmts $
+ do {
+ -- Look up the names right in the middle,
+ -- where they will all be in scope
+ ids <- mappM tcLookupId names ;
+ ret_id <- tcLookupId returnIOName ; -- return @ IO
+ return (ids, [ResultStmt (mk_return ret_id ids) noSrcLoc]) } ;
+
+ io_ids <- mappM (tcStdSyntaxName DoOrigin io_ty) monadNames ;
+ return (ids, HsDo DoExpr tc_stmts io_ids io_ret_ty noSrcLoc)
+ } ;
-- Simplify the context right here, so that we fail
-- if there aren't enough instances. Notably, when we see
-- and then let it = e
-- It's the simplify step that rejects the first.
traceTc (text "tcs 3") ;
- const_binds <- tcSimplifyTop lie ;
+ const_binds <- tcSimplifyInteractive lie ;
-- Build result expression and zonk it
- let { expr = mkHsLet const_binds $
- HsDo DoExpr tc_stmts io_ids
- (mkTyConApp ioTyCon [mkListTy unitTy]) noSrcLoc } ;
+ let { expr = mkHsLet const_binds tc_expr } ;
zonked_expr <- zonkTopExpr expr ;
zonked_ids <- zonkTopBndrs ids ;
-- it might have a rank-2 type (e.g. :t runST)
((tc_expr, res_ty), lie) <- getLIE (tcInferRho rn_expr) ;
((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ;
- tcSimplifyTop lie_top ;
+ tcSimplifyInteractive lie_top ;
let { all_expr_ty = mkForAllTys qtvs $
mkFunTys (map idType dict_ids) $
-> RdrName
-> IO (PersistentCompilerState, Maybe [TyThing])
-- Look up a RdrName and return all the TyThings it might be
--- We treat a capitalised RdrName as both a data constructor
--- and as a type or class constructor; hence we return up to two results
+-- A capitalised RdrName is given to us in the DataName namespace,
+-- but we want to treat it as *both* a data constructor
+-- *and* as a type or class constructor;
+-- hence the call to dataTcOccs, and we return up to two results
tcRnThing hsc_env pcs ictxt rdr_name
= initTc hsc_env pcs iNTERACTIVE $
setInteractiveContext ictxt $ do {
errs_s = [msgs | (msgs, Nothing) <- results] } ;
-- Fail if nothing good happened, else add warnings
- if null good_names then -- Fail
+ if null good_names then
+ -- No lookup succeeded, so
+ -- pick the first error message and report it
+ -- ToDo: If one of the errors is "could be Foo.X or Baz.X",
+ -- while the other is "X is not in scope",
+ -- we definitely want the former; but we might pick the latter
do { addMessages (head errs_s) ; failM }
else -- Add deprecation warnings
mapM_ addMessages warns_s ;
= initRn CmdLineMode $
setLocalRdrEnv (ic_rn_local_env ictxt) $
rn_thing
+#endif /* GHCI */
\end{code}
%************************************************************************
-> IO (PersistentCompilerState, Maybe ModGuts)
-- Nothing => some error occurred
-tcRnExtCore hsc_env pcs
- (HsModule this_mod _ _ _ local_decls _ loc)
+tcRnExtCore hsc_env pcs (HsModule (Just this_mod) _ _ decls _ loc)
+ -- For external core, the module name is syntactically reqd
-- Rename the (Core) module. It's a bit like an interface
-- file: all names are original names
= do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
-- Rename the source, only in interface mode.
-- rnSrcDecls handles fixity decls etc too, which won't occur
-- but that doesn't matter
- let { local_group = mkGroup local_decls } ;
- (_, rn_local_decls, dus) <- initRn (InterfaceMode this_mod)
- (rnSrcDecls local_group) ;
+ let { local_group = mkGroup decls } ;
+ (_, rn_src_decls, dus) <- initRn (InterfaceMode this_mod)
+ (rnSrcDecls local_group) ;
failIfErrsM ;
-- Get the supporting decls
rn_imp_decls <- slurpImpDecls (duUses dus) ;
- let { rn_decls = rn_local_decls `addImpDecls` rn_imp_decls } ;
+ let { rn_decls = rn_src_decls `addImpDecls` rn_imp_decls } ;
-- Dump trace of renaming part
rnDump (ppr rn_decls) ;
setGblEnv tcg_env $ do {
-- Now the core bindings
- core_prs <- tcCoreBinds (hs_coreds rn_local_decls) ;
+ core_prs <- tcCoreBinds (hs_coreds rn_decls) ;
tcExtendGlobalValEnv (map fst core_prs) $ do {
-- Wrap up
final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
mod_guts = ModGuts { mg_module = this_mod,
- mg_usages = [], -- ToDo: compute usage
- mg_dir_imps = [], -- ??
+ mg_usages = [], -- ToDo: compute usage
+ mg_dir_imps = [], -- ??
mg_deps = noDependencies, -- ??
mg_exports = my_exports,
mg_types = final_type_env,
checkMain
= do { ghci_mode <- getGhciMode ;
tcg_env <- getGblEnv ;
- check_main ghci_mode tcg_env
+
+ mb_main_mod <- readMutVar v_MainModIs ;
+ mb_main_fn <- readMutVar v_MainFunIs ;
+ let { main_mod = case mb_main_mod of {
+ Just mod -> mkModuleName mod ;
+ Nothing -> mAIN_Name } ;
+ main_fn = case mb_main_fn of {
+ Just fn -> mkRdrUnqual (mkVarOcc (mkFastString fn)) ;
+ Nothing -> main_RDR_Unqual } } ;
+
+ check_main ghci_mode tcg_env main_mod main_fn
}
-check_main ghci_mode tcg_env
+
+check_main ghci_mode tcg_env main_mod main_fn
-- If we are in module Main, check that 'main' is defined.
-- It may be imported from another module, in which case
-- we have to drag in its.
--
-- Blimey: a whole page of code to do this...
- | mod_name /= mAIN_Name
+ | mod_name /= main_mod
= return (tcg_env, emptyFVs)
-- Check that 'main' is in scope
--
-- We use a guard for this (rather than letting lookupSrcName fail)
-- because it's not an error in ghci)
- | not (main_RDR_Unqual `elemRdrEnv` rdr_env)
+ | not (main_fn `elemRdrEnv` rdr_env)
= do { complain_no_main; return (tcg_env, emptyFVs) }
- | otherwise
- = do { main_name <- lookupSrcName main_RDR_Unqual ;
+ | otherwise -- OK, so the appropriate 'main' is in scope
+ --
+ = do { main_name <- lookupSrcName main_fn ;
tcg_env <- importSupportingDecls (unitFV runIOName) ;
addErrCtxt mainCtxt $
setGblEnv tcg_env $ do {
- -- $main :: IO () = runIO main
+ -- :Main.main :: IO () = runIO main
let { rhs = HsApp (HsVar runIOName) (HsVar main_name) } ;
(main_expr, ty) <- tcInferRho rhs ;
- let { dollar_main_id = setIdLocalExported (mkLocalId dollarMainName ty) ;
- main_bind = VarMonoBind dollar_main_id main_expr ;
+ let { root_main_id = setIdLocalExported (mkLocalId rootMainName ty) ;
+ main_bind = VarMonoBind root_main_id main_expr ;
tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env
`andMonoBinds` main_bind } } ;
-- In other modes, fail altogether, so that we don't go on
-- and complain a second time when processing the export list.
- mainCtxt = ptext SLIT("When checking the type of 'main'")
- noMainMsg = ptext SLIT("No 'main' defined in module Main")
+ mainCtxt = ptext SLIT("When checking the type of the main function") <+> quotes (ppr main_fn)
+ noMainMsg = ptext SLIT("The main function") <+> quotes (ppr main_fn)
+ <+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod)
\end{code}
ptext SLIT("#-}")]
ppr_gen_tycons [] = empty
-ppr_gen_tycons tcs = vcat [ptext SLIT("{-# Generic type constructor details"),
- vcat (map ppr_gen_tycon tcs),
- ptext SLIT("#-}")
+ppr_gen_tycons tcs = vcat [ptext SLIT("Generic type constructor details:"),
+ nest 2 (vcat (map ppr_gen_tycon tcs))
]
-- x&y are now Id's, not CoreExpr's