X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnDriver.lhs;h=ee2cb50c4c735cb5b3ff681b5d04ae89820e734d;hb=d551dbfef0b710f5ede21ee0c54ee7e80dd53b64;hp=84c8ec4c9d44631c19706c30a0b53ebd5f8d86e6;hpb=36a3f8f330caa40380a78ff4a218199130c81ec3;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index 84c8ec4..ee2cb50 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -22,10 +22,10 @@ import IO import {-# SOURCE #-} TcSplice ( tcSpliceDecls ) #endif -import CmdLineOpts ( DynFlag(..), opt_PprStyle_Debug, dopt ) +import DynFlags ( DynFlag(..), DynFlags(..), dopt, GhcMode(..) ) +import StaticFlags ( opt_PprStyle_Debug ) import Packages ( moduleToPackageConfig, mkPackageId, package, isHomeModule ) -import DriverState ( v_MainModIs, v_MainFunIs ) import HsSyn ( HsModule(..), HsExtCore(..), HsGroup(..), LHsDecl, SpliceDecl(..), HsBind(..), nlHsApp, nlHsVar, pprLHsBinds ) import RdrHsSyn ( findSplice ) @@ -60,7 +60,6 @@ import DataCon ( dataConWrapId ) import ErrUtils ( Messages, mkDumpDoc, showPass ) import Id ( mkExportedLocalId, isLocalId, idName, idType ) import Var ( Var ) -import VarEnv ( varEnvElts ) import Module ( Module, ModuleEnv, mkModule, moduleEnvElts, lookupModuleEnv ) import OccName ( mkVarOcc ) import Name ( Name, isExternalName, getSrcLoc, getOccName, isWiredInName ) @@ -69,7 +68,7 @@ import TyCon ( tyConHasGenerics, isSynTyCon, getSynTyConDefn, tyConKind ) import SrcLoc ( srcLocSpan, Located(..), noLoc ) import DriverPhases ( HscSource(..), isHsBoot ) import HscTypes ( ModGuts(..), HscEnv(..), ExternalPackageState(..), - GhciMode(..), IsBootInterface, noDependencies, + IsBootInterface, noDependencies, Deprecs( NoDeprecs ), plusDeprecs, ForeignStubs(NoStubs), TyThing(..), TypeEnv, lookupTypeEnv, hptInstances, lookupType, @@ -82,7 +81,7 @@ import Outputable import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..), HsBindGroup(..), LStmt, LHsExpr, LHsType, mkMatchGroup, collectStmtsBinders, mkSimpleMatch, - nlLetStmt, nlExprStmt, nlBindStmt, nlResultStmt, nlVarPat ) + mkExprStmt, mkBindStmt, nlVarPat ) import RdrName ( GlobalRdrEnv, mkGlobalRdrEnv, GlobalRdrElt(..), Provenance(..), ImportSpec(..), lookupLocalRdrEnv, extendLocalRdrEnv ) @@ -99,7 +98,7 @@ import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType, isUnLiftedType, tyClsNamesOfDFunHead ) import TcEnv ( tcLookupTyCon, tcLookupId, tcLookupGlobal ) import RnTypes ( rnLHsType ) -import Inst ( tcStdSyntaxName, tcGetInstEnvs ) +import Inst ( tcGetInstEnvs ) import InstEnv ( DFunId, classInstances, instEnvElts ) import RnExpr ( rnStmts, rnLExpr ) import RnNames ( exportsToAvails ) @@ -699,13 +698,11 @@ tcTopSrcDecls boot_names checkMain = do { ghci_mode <- getGhciMode ; tcg_env <- getGblEnv ; - - mb_main_mod <- readMutVar v_MainModIs ; - mb_main_fn <- readMutVar v_MainFunIs ; - let { main_mod = case mb_main_mod of { + dflags <- getDOpts ; + let { main_mod = case mainModIs dflags of { Just mod -> mkModule mod ; Nothing -> mAIN } ; - main_fn = case mb_main_fn of { + main_fn = case mainFunIs dflags of { Just fn -> mkRdrUnqual (mkVarOcc (mkFastString fn)) ; Nothing -> main_RDR_Unqual } } ; @@ -885,7 +882,7 @@ Here is the grand plan, implemented in tcUserStmt \begin{code} --------------------------- tcUserStmt :: LStmt Name -> TcM ([Id], LHsExpr Id) -tcUserStmt (L _ (ExprStmt expr _)) +tcUserStmt (L loc (ExprStmt expr _)) = newUnique `thenM` \ uniq -> let fresh_it = itName uniq @@ -894,18 +891,18 @@ tcUserStmt (L _ (ExprStmt expr _)) in tryTcLIE_ (do { -- Try this if the other fails traceTc (text "tcs 1b") ; - tc_stmts [ - nlLetStmt [HsBindGroup (unitBag the_bind) [] NonRecursive], - nlExprStmt (nlHsApp (nlHsVar printName) - (nlHsVar fresh_it)) - ] }) + tc_stmts (map (L loc) [ + LetStmt [HsBindGroup (unitBag the_bind) [] NonRecursive], + mkExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it)) + ]) }) (do { -- Try this first traceTc (text "tcs 1a") ; - tc_stmts [nlBindStmt (nlVarPat fresh_it) expr] }) + tc_stmts [L loc (mkBindStmt (nlVarPat fresh_it) expr)] }) tcUserStmt stmt = tc_stmts [stmt] --------------------------- +tc_stmts :: [Stmt RdrName] -> tc_stmts stmts = do { ioTyCon <- tcLookupTyCon ioTyConName ; let { @@ -915,13 +912,16 @@ tc_stmts stmts names = map unLoc (collectStmtsBinders stmts) ; stmt_ctxt = SC { sc_what = DoExpr, - sc_rhs = infer_rhs, + sc_bind = infer_rhs, + sc_expr = infer_rhs, sc_body = check_body, sc_ty = ret_ty } ; - infer_rhs rhs = do { (rhs', rhs_ty) <- tcInferRho rhs - ; [pat_ty] <- unifyTyConApp ioTyCon rhs_ty - ; return (rhs', pat_ty) } ; + infer_rhs _bind_op rhs + = do { (rhs', rhs_ty) <- tcInferRho rhs + ; [pat_ty] <- unifyTyConApp ioTyCon rhs_ty + ; return (noSyntaxExpr, rhs', pat_ty) } ; + check_body body = tcCheckRho body io_ret_ty ; -- mk_return builds the expression @@ -946,16 +946,15 @@ tc_stmts stmts -- OK, we're ready to typecheck the stmts traceTc (text "tcs 2") ; ((ids, tc_expr), lie) <- getLIE $ do { - (ids, tc_stmts) <- tcStmtsAndThen combine stmt_ctxt stmts $ + (tc_stmts, ids) <- 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, [nlResultStmt (mk_return ret_id ids)]) } ; + return ids } ; - io_ids <- mappM (tcStdSyntaxName DoOrigin io_ty) monadNames ; - return (ids, noLoc (HsDo DoExpr tc_stmts io_ids io_ret_ty)) + ret_id <- tcLookupId returnIOName ; -- return @ IO + return (ids, noLoc (HsDo DoExpr tc_stmts (mk_return ret_id ids) io_ret_ty)) } ; -- Simplify the context right here, so that we fail @@ -1080,12 +1079,11 @@ vanillaProv mod = Imported [ImportSpec mod mod False \begin{code} getModuleContents :: HscEnv - -> InteractiveContext -> Module -- Module to inspect -> Bool -- Grab just the exports, or the whole toplev -> IO (Maybe [IfaceDecl]) -getModuleContents hsc_env ictxt mod exports_only +getModuleContents hsc_env mod exports_only = initTcPrintErrors hsc_env iNTERACTIVE (get_mod_contents exports_only) where get_mod_contents exports_only @@ -1112,7 +1110,7 @@ getModuleContents hsc_env ictxt mod exports_only ; thing <- tcLookupGlobal main_name ; return (filter_decl (availNames avail) (toIfaceDecl ext_nm thing)) } - ext_nm = interactiveExtNameFun (icPrintUnqual ictxt) + ext_nm = interactiveExtNameFun (icPrintUnqual (hsc_IC hsc_env)) --------------------- filter_decl occs decl@(IfaceClass {ifSigs = sigs}) @@ -1157,7 +1155,7 @@ tcRnGetInfo :: HscEnv -- Look up a RdrName and return all the TyThings it might be -- 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; +-- *and* as a type or class constructor; -- hence the call to dataTcOccs, and we return up to two results tcRnGetInfo hsc_env ictxt rdr_name = initTcPrintErrors hsc_env iNTERACTIVE $