X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnDriver.lhs;h=463ff1da7a2813584de519a9ec15c9e4579d6f94;hb=f8031f577f9667ef1ab439b11fdd15fc39a79630;hp=6dabc142ba887e4d0af417eb1e1dafdc9bf62617;hpb=76c6edcbde24c92a09642469d2bbe617278c391f;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index 6dabc142..463ff1d 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -6,11 +6,11 @@ \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" @@ -21,6 +21,7 @@ import DsMeta ( templateHaskellNames ) #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(..), @@ -30,11 +31,10 @@ import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsExpr(..), 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, unsafeCoerceName ) -import MkId ( unsafeCoerceId ) import RdrName ( RdrName, getRdrName, mkRdrUnqual, lookupRdrEnv, elemRdrEnv ) @@ -45,15 +45,13 @@ import TcHsSyn ( TypecheckedHsExpr, TypecheckedRuleDecl, zonkTopExpr, zonkTopBndrs ) -import TcExpr ( tcInferRho ) +import TcExpr ( tcInferRho, tcCheckRho ) import TcRnMonad -import TcMType ( newTyVarTy, zonkTcType ) -import TcType ( Type, liftedTypeKind, - tyVarsOfType, tcFunResultTy, +import TcType ( Type, + tyVarsOfType, tcFunResultTy, tidyTopType, mkForAllTys, mkFunTys, mkTyConApp, tcSplitForAllTys ) -import TcMatches ( tcStmtsAndThen ) -import Inst ( showLIE ) +import Inst ( showLIE, tcStdSyntaxName ) import TcBinds ( tcTopBinds ) import TcClassDcl ( tcClassDecls2 ) import TcDefaults ( tcDefaults ) @@ -66,7 +64,7 @@ import TcRules ( tcRules ) 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, @@ -75,24 +73,20 @@ import RnIfaces ( slurpImpDecls, checkVersions, RecompileRequired, outOfDate ) 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(..), @@ -108,13 +102,21 @@ import HscTypes ( PersistentCompilerState(..), InteractiveContext(..), 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 ) @@ -135,9 +137,13 @@ tcRnModule :: HscEnv -> PersistentCompilerState -> 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 ; @@ -165,7 +171,7 @@ tcRnModule hsc_env pcs $ do { -- Process the export list - export_avails <- exportsFromAvail exports ; + export_avails <- exportsFromAvail maybe_mod exports ; updGblEnv (\gbl -> gbl { tcg_exports = export_avails }) $ do { @@ -251,6 +257,7 @@ hsCoreRules rules = [(id,rule) | IfaceRuleOut id rule <- rules] %************************************************************************ \begin{code} +#ifdef GHCI tcRnStmt :: HscEnv -> PersistentCompilerState -> InteractiveContext -> RdrNameStmt @@ -287,7 +294,7 @@ tcRnStmt hsc_env pcs ictxt rdr_stmt 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 @@ -372,34 +379,44 @@ tcUserStmt stmt = tc_stmts [stmt] --------------------------- 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 ; + names = collectStmtsBinders stmts ; + + 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 (mkTyConApp ioTyCon [ret_ty]) ; - io_ty = (\ ty -> mkTyConApp ioTyCon [ty], res_ty) ; + -- ret_expr is the expression + -- returnIO [coerce () x, .., coerce () z] + ret_stmt = ResultStmt ret_expr noSrcLoc ; + ret_expr = HsApp (HsVar returnIOName) + (ExplicitList placeHolderType (map mk_item names)) ; + mk_item name = HsApp (HsVar unsafeCoerceName) (HsVar name) ; - -- 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)) ; + all_stmts = stmts ++ [ret_stmt] ; - mk_item id = HsApp (TyApp (HsVar unsafeCoerceId) [idType id, unitTy]) - (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 all_stmts $ + do { + -- Look up the names right in the middle, + -- where they will all be in scope + ids <- mappM tcLookupId names ; + return (ids, []) } ; + io_ids <- mappM (tcStdSyntaxName DoOrigin io_ty) monadNames ; + return (ids, HsDo DoExpr tc_stmts io_ids + (mkTyConApp ioTyCon [ret_ty]) noSrcLoc) + } ; -- Simplify the context right here, so that we fail -- if there aren't enough instances. Notably, when we see @@ -408,12 +425,10 @@ tc_stmts stmts -- 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 ; @@ -446,7 +461,7 @@ tcRnExpr hsc_env pcs ictxt rdr_expr -- 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) $ @@ -514,6 +529,7 @@ initRnInteractive ictxt rn_thing = initRn CmdLineMode $ setLocalRdrEnv (ic_rn_local_env ictxt) $ rn_thing +#endif /* GHCI */ \end{code} %************************************************************************ @@ -528,8 +544,8 @@ tcRnExtCore :: HscEnv -> PersistentCompilerState -> 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" ; @@ -539,14 +555,14 @@ tcRnExtCore hsc_env pcs -- 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) ; @@ -558,7 +574,7 @@ tcRnExtCore hsc_env pcs 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 @@ -570,8 +586,8 @@ tcRnExtCore hsc_env pcs 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, @@ -651,7 +667,7 @@ tc_rn_src_decls ds setEnvs tc_envs $ - -- If there is no splice, we're nearlydone + -- If there is no splice, we're nearly done case group_tail of { Nothing -> do { -- Last thing: check for `main' (tcg_env, main_fvs) <- checkMain ; @@ -1093,10 +1109,21 @@ noRdrEnvErr mod = ptext SLIT("No top-level environment available for module") 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. @@ -1111,7 +1138,7 @@ check_main ghci_mode tcg_env -- -- 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 @@ -1119,11 +1146,12 @@ check_main ghci_mode tcg_env -- -- 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) ; @@ -1131,12 +1159,12 @@ check_main ghci_mode tcg_env 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 } } ; @@ -1152,8 +1180,9 @@ check_main ghci_mode tcg_env -- 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} @@ -1205,8 +1234,8 @@ pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, , ppr_insts dfun_ids , vcat (map ppr rules) , ppr_gen_tycons (typeEnvTyCons type_env) - , ppr (moduleEnvElts (imp_dep_mods imports)) - , ppr (imp_dep_pkgs imports)] + , ptext SLIT("Dependent modules:") <+> ppr (moduleEnvElts (imp_dep_mods imports)) + , ptext SLIT("Dependent packages:") <+> ppr (imp_dep_pkgs imports)] pprModGuts :: ModGuts -> SDoc pprModGuts (ModGuts { mg_types = type_env, @@ -1239,7 +1268,7 @@ ppr_sigs ids -- Convert to HsType so that we get source-language style printing -- And sort by RdrName = vcat $ map ppr_sig $ sortLt lt_sig $ - [ (getRdrName id, toHsType (idType id)) + [ (getRdrName id, toHsType (tidyTopType (idType id))) | id <- ids ] where lt_sig (n1,_) (n2,_) = n1 < n2 @@ -1253,9 +1282,8 @@ ppr_rules rs = vcat [ptext SLIT("{-# RULES"), 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