X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnDriver.lhs;h=1b099231bd64e421619afbc41e82b31fe47c7fcc;hp=efe58a19b2462f9581ea7b928890883c3db21583;hb=a27c5f77da8b3b3f00f9902b69a504460f234e8c;hpb=3f1b316d7035c55cd712cd39a9981339bcef2e8c diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index efe58a1..1b09923 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -58,6 +58,7 @@ import MkIface import IfaceSyn import TcSimplify import TcTyClsDecls +import TcUnify ( withBox ) import LoadIface import RnNames import RnEnv @@ -69,11 +70,12 @@ import ErrUtils import Id import Var import Module -import UniqFM +import LazyUniqFM import Name import NameEnv import NameSet import TyCon +import TysWiredIn import SrcLoc import HscTypes import ListSetOps @@ -85,12 +87,10 @@ import DataCon import TcHsType import TcMType import TcMatches -import TcGadt import RnTypes import RnExpr import IfaceEnv import MkId -import TysWiredIn import IdInfo import {- Kind parts of -} Type import BasicTypes @@ -102,7 +102,7 @@ import Maybes import Util import Bag -import Control.Monad ( unless ) +import Control.Monad import Data.Maybe ( isJust ) \end{code} @@ -290,10 +290,11 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) -- (b) tcExtCoreBindings doesn't need anything -- (in fact, it might not even need to be in the scope of -- this tcg_env at all) - tcg_env <- importsFromLocalDecls False (mkFakeGroup ldecls) - emptyUFM {- no fixity decls -} ; + avails <- getLocalNonValBinders (mkFakeGroup ldecls) ; + tc_envs <- extendGlobalRdrEnvRn False avails + emptyOccEnv {- no fixity decls -} ; - setGblEnv tcg_env $ do { + setEnvs tc_envs $ do { rn_decls <- checkNoErrs $ rnTyClDecls ldecls ; @@ -773,19 +774,25 @@ check_main dflags tcg_env Just main_name -> do { traceTc (text "checkMain found" <+> ppr main_mod <+> ppr main_fn) - ; let { rhs = nlHsApp (nlHsVar runMainIOName) (nlHsVar main_name) } - -- :Main.main :: IO () = runMainIO main - - ; (main_expr, ty) <- addErrCtxt mainCtxt $ - setSrcSpan (srcLocSpan (getSrcLoc main_name)) $ - tcInferRho rhs + ; let loc = srcLocSpan (getSrcLoc main_name) + ; ioTyCon <- tcLookupTyCon ioTyConName + ; (main_expr, res_ty) + <- addErrCtxt mainCtxt $ + withBox liftedTypeKind $ \res_ty -> + tcMonoExpr (L loc (HsVar main_name)) (mkTyConApp ioTyCon [res_ty]) -- See Note [Root-main Id] + -- Construct the binding + -- :Main.main :: IO res_ty = runMainIO res_ty main + ; run_main_id <- tcLookupId runMainIOName ; let { root_main_name = mkExternalName rootMainKey rOOT_MAIN (mkVarOccFS FSLIT("main")) (getSrcSpan main_name) - ; root_main_id = Id.mkExportedLocalId root_main_name ty - ; main_bind = noLoc (VarBind root_main_id main_expr) } + ; root_main_id = Id.mkExportedLocalId root_main_name + (mkTyConApp ioTyCon [res_ty]) + ; co = mkWpTyApps [res_ty] + ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) main_expr + ; main_bind = noLoc (VarBind root_main_id rhs) } ; return (tcg_env { tcg_binds = tcg_binds tcg_env `snocBag` main_bind, @@ -896,7 +903,7 @@ tcRnStmt hsc_env ictxt rdr_stmt -- None of the Ids should be of unboxed type, because we -- cast them all to HValues in the end! - mappM bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ; + mapM bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ; traceTc (text "tcs 1") ; let { global_ids = map globaliseAndTidy zonked_ids } ; @@ -924,7 +931,7 @@ tcRnStmt hsc_env ictxt rdr_stmt (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids, text "Typechecked expr" <+> ppr zonked_expr]) ; - returnM (global_ids, zonked_expr) + return (global_ids, zonked_expr) } where bad_unboxed id = addErr (sep [ptext SLIT("GHCi can't bind a variable of unlifted type:"), @@ -1012,7 +1019,7 @@ mkPlan (L loc (ExprStmt expr _ _)) -- An expression typed at the prompt ; runPlans [ -- Plan A do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it] ; it_ty <- zonkTcType (idType it_id) - ; ifM (isUnitTy it_ty) failM + ; when (isUnitTy it_ty) failM ; return stuff }, -- Plan B; a naked bind statment @@ -1037,7 +1044,7 @@ mkPlan stmt@(L loc (BindStmt {})) ; let print_plan = do { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v] ; v_ty <- zonkTcType (idType v_id) - ; ifM (isUnitTy v_ty || not (isTauTy v_ty)) failM + ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM ; return stuff } -- The plans are: @@ -1056,11 +1063,9 @@ tcGhciStmts stmts = do { ioTyCon <- tcLookupTyCon ioTyConName ; ret_id <- tcLookupId returnIOName ; -- return @ IO let { - io_ty = mkTyConApp ioTyCon [] ; ret_ty = mkListTy unitTy ; io_ret_ty = mkTyConApp ioTyCon [ret_ty] ; - tc_io_stmts stmts = tcStmts DoExpr (tcDoStmt io_ty) stmts - (emptyRefinement, io_ret_ty) ; + tc_io_stmts stmts = tcStmts DoExpr tcDoStmt stmts io_ret_ty ; names = map unLoc (collectLStmtsBinders stmts) ; @@ -1084,7 +1089,7 @@ tcGhciStmts stmts -- OK, we're ready to typecheck the stmts traceTc (text "TcRnDriver.tcGhciStmts: tc stmts") ; ((tc_stmts, ids), lie) <- getLIE $ tc_io_stmts stmts $ \ _ -> - mappM tcLookupId names ; + mapM tcLookupId names ; -- Look up the names right in the middle, -- where they will all be in scope @@ -1329,8 +1334,8 @@ tcDump env = do { dflags <- getDOpts ; -- Dump short output if -ddump-types or -ddump-tc - ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags) - (dumpTcRn short_dump) ; + when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags) + (dumpTcRn short_dump) ; -- Dump bindings if -ddump-tc dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) @@ -1343,8 +1348,8 @@ tcDump env tcCoreDump mod_guts = do { dflags <- getDOpts ; - ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags) - (dumpTcRn (pprModGuts mod_guts)) ; + when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags) + (dumpTcRn (pprModGuts mod_guts)) ; -- Dump bindings if -ddump-tc dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) }