X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnDriver.lhs;h=ade0e60d776a81805fe7bfd5234b8023943997ee;hb=05afb7485eea44d6410139f8a20c94b6f66c46f2;hp=b6e94aaba7d85a35ea31beb7dce9834f61a886e2;hpb=d28ba8c800901bea01f70c4719278c2a364cf9fc;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index b6e94aa..ade0e60 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" @@ -22,7 +22,6 @@ import DsMeta ( templateHaskellNames ) import CmdLineOpts ( DynFlag(..), opt_PprStyle_Debug, dopt ) import DriverState ( v_MainModIs, v_MainFunIs ) -import DriverUtil ( split_longest_prefix ) import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsExpr(..), Stmt(..), Pat(VarPat), HsStmtContext(..), RuleDecl(..), HsGroup(..), SpliceDecl(..), @@ -32,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, + dollarMainName, itName, mAIN_Name, unsafeCoerceName ) -import MkId ( unsafeCoerceId ) import RdrName ( RdrName, getRdrName, mkRdrUnqual, lookupRdrEnv, elemRdrEnv ) @@ -47,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, +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 ) @@ -77,21 +73,17 @@ 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, mkHomeModule, mkModuleName, 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(..) ) @@ -111,9 +103,15 @@ 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 NameEnv ( delListFromNameEnv ) import HscTypes ( GlobalRdrElt(..), GlobalRdrEnv, ImportReason(..), Provenance(..), isLocalGRE ) #endif @@ -260,6 +258,7 @@ hsCoreRules rules = [(id,rule) | IfaceRuleOut id rule <- rules] %************************************************************************ \begin{code} +#ifdef GHCI tcRnStmt :: HscEnv -> PersistentCompilerState -> InteractiveContext -> RdrNameStmt @@ -296,7 +295,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 @@ -381,34 +380,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 ; - 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 } ; - -- 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)) ; + check_rhs rhs rhs_ty = tcCheckRho rhs (mkTyConApp ioTyCon [rhs_ty]) ; + check_body body = tcCheckRho body (mkTyConApp ioTyCon [ret_ty]) ; - mk_item id = HsApp (TyApp (HsVar unsafeCoerceId) [idType id, unitTy]) - (HsVar id) } ; + -- 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) ; + + all_stmts = stmts ++ [ret_stmt] ; + + 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 @@ -420,9 +429,7 @@ tc_stmts stmts const_binds <- tcSimplifyTop 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 ; @@ -523,6 +530,7 @@ initRnInteractive ictxt rn_thing = initRn CmdLineMode $ setLocalRdrEnv (ic_rn_local_env ictxt) $ rn_thing +#endif /* GHCI */ \end{code} %************************************************************************