X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnDriver.lhs;h=b5d5f1672c2da0601fd44884b9f28b4a204a822d;hb=fcf5ff34649982a99bc1e4a4940453a181a8d899;hp=4443eafef922942e6174c9e4d5e3f4cdc4e4c2da;hpb=7379e82aafc7d0c1b839a13a20d52babeafed023;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 4443eaf..b5d5f16 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -25,8 +25,6 @@ module TcRnDriver ( tcRnExtCore ) where -#include "HsVersions.h" - import IO #ifdef GHCI import {-# SOURCE #-} TcSplice ( tcSpliceDecls ) @@ -58,6 +56,7 @@ import MkIface import IfaceSyn import TcSimplify import TcTyClsDecls +import TcUnify ( withBox ) import LoadIface import RnNames import RnEnv @@ -69,11 +68,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 +85,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 +100,7 @@ import Maybes import Util import Bag -import Control.Monad ( unless ) +import Control.Monad import Data.Maybe ( isJust ) \end{code} @@ -290,10 +288,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 + emptyFsEnv {- no fixity decls -} ; - setGblEnv tcg_env $ do { + setEnvs tc_envs $ do { rn_decls <- checkNoErrs $ rnTyClDecls ldecls ; @@ -502,7 +501,7 @@ tcRnHsBootDecls decls }}}} spliceInHsBootErr (SpliceDecl (L loc _), _) - = addErrAt loc (ptext SLIT("Splices are not allowed in hs-boot files")) + = addErrAt loc (ptext (sLit "Splices are not allowed in hs-boot files")) \end{code} Once we've typechecked the body of the module, we want to compare what @@ -607,17 +606,17 @@ checkHiBootIface ---------------- missingBootThing thing what - = ppr thing <+> ptext SLIT("is exported by the hs-boot file, but not") - <+> text what <+> ptext SLIT("the module") + = ppr thing <+> ptext (sLit "is exported by the hs-boot file, but not") + <+> text what <+> ptext (sLit "the module") bootMisMatch thing boot_decl real_decl - = vcat [ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hs-boot file"), - ptext SLIT("Main module:") <+> ppr real_decl, - ptext SLIT("Boot file: ") <+> ppr boot_decl] + = vcat [ppr thing <+> ptext (sLit "has conflicting definitions in the module and its hs-boot file"), + ptext (sLit "Main module:") <+> ppr real_decl, + ptext (sLit "Boot file: ") <+> ppr boot_decl] instMisMatch inst = hang (ppr inst) - 2 (ptext SLIT("is defined in the hs-boot file, but not in the module itself")) + 2 (ptext (sLit "is defined in the hs-boot file, but not in the module itself")) \end{code} @@ -773,19 +772,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")) + (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, @@ -810,11 +815,11 @@ check_main dflags 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 the") <+> pp_main_fn - noMainMsg = ptext SLIT("The") <+> pp_main_fn - <+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod) - pp_main_fn | isJust main_is_flag = ptext SLIT("main function") <+> quotes (ppr main_fn) - | otherwise = ptext SLIT("function") <+> quotes (ppr main_fn) + mainCtxt = ptext (sLit "When checking the type of the") <+> pp_main_fn + noMainMsg = ptext (sLit "The") <+> pp_main_fn + <+> ptext (sLit "is not defined in module") <+> quotes (ppr main_mod) + pp_main_fn | isJust main_is_flag = ptext (sLit "main function") <+> quotes (ppr main_fn) + | otherwise = ptext (sLit "function") <+> quotes (ppr main_fn) \end{code} Note [Root-main Id] @@ -896,19 +901,10 @@ 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 { -- (a) Make all the bound ids "global" ids, now that - -- they're notionally top-level bindings. This is - -- important: otherwise when we come to compile an expression - -- using these ids later, the byte code generator will consider - -- the occurrences to be free rather than global. - -- - -- (b) Tidy their types; this is important, because :info may - -- ask to look at them, and :info expects the things it looks - -- up to have tidy types - global_ids = map globaliseAndTidy zonked_ids ; + let { global_ids = map globaliseAndTidy zonked_ids } ; {- --------------------------------------------- At one stage I removed any shadowed bindings from the type_env; @@ -928,26 +924,47 @@ tcRnStmt hsc_env ictxt rdr_stmt Hence this code is commented out -------------------------------------------------- -} - } ; dumpOptTcRn Opt_D_dump_tc (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:"), + bad_unboxed id = addErr (sep [ptext (sLit "GHCi can't bind a variable of unlifted type:"), nest 2 (ppr id <+> dcolon <+> ppr (idType id))]) globaliseAndTidy :: Id -> Id -globaliseAndTidy id --- Give the Id a Global Name, and tidy its type +globaliseAndTidy id -- Note [Interactively-bound Ids in GHCi] = Id.setIdType (globaliseId VanillaGlobal id) tidy_type where tidy_type = tidyTopType (idType id) \end{code} +Note [Interactively-bound Ids in GHCi] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The Ids bound by previous Stmts in Template Haskell are currently + a) GlobalIds + b) with an Internal Name (not External) + c) and a tidied type + + (a) They must be GlobalIds (not LocalIds) otherwise when we come to + compile an expression using these ids later, the byte code + generator will consider the occurrences to be free rather than + global. + + (b) They retain their Internal names becuase we don't have a suitable + Module to name them with. We could revisit this choice. + + (c) Their types are tidied. This is important, because :info may ask + to look at them, and :info expects the things it looks up to have + tidy types + + +-------------------------------------------------------------------------- + Typechecking Stmts in GHCi + Here is the grand plan, implemented in tcUserStmt What you type The IO [HValue] that hscStmt returns @@ -1000,7 +1017,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 @@ -1025,7 +1042,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: @@ -1044,11 +1061,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) ; @@ -1072,7 +1087,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 @@ -1114,7 +1129,7 @@ tcRnExpr hsc_env ictxt rdr_expr zonkTcType all_expr_ty } where - smpl_doc = ptext SLIT("main expression") + smpl_doc = ptext (sLit "main expression") \end{code} tcRnType just finds the kind of a type @@ -1136,7 +1151,7 @@ tcRnType hsc_env ictxt rdr_type return kind } where - doc = ptext SLIT("In GHCi input") + doc = ptext (sLit "In GHCi input") #endif /* GHCi */ \end{code} @@ -1168,7 +1183,7 @@ getModuleExports hsc_env mod -- argument). tcGetModuleExports :: Module -> [Module] -> TcM [AvailInfo] tcGetModuleExports mod directlyImpMods - = do { let doc = ptext SLIT("context for compiling statements") + = do { let doc = ptext (sLit "context for compiling statements") ; iface <- initIfaceTcRn $ loadSysInterface doc mod -- Load any orphan-module and family instance-module @@ -1297,7 +1312,7 @@ loadUnqualIfaces ictxt not (isInternalName name), isTcOcc (nameOccName name), -- Types and classes only unQualOK gre ] -- In scope unqualified - doc = ptext SLIT("Need interface for module whose export(s) are in scope unqualified") + doc = ptext (sLit "Need interface for module whose export(s) are in scope unqualified") #endif /* GHCI */ \end{code} @@ -1317,8 +1332,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) @@ -1331,8 +1346,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) } @@ -1352,8 +1367,8 @@ pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, , ppr_fam_insts fam_insts , vcat (map ppr rules) , ppr_gen_tycons (typeEnvTyCons type_env) - , ptext SLIT("Dependent modules:") <+> ppr (eltsUFM (imp_dep_mods imports)) - , ptext SLIT("Dependent packages:") <+> ppr (imp_dep_pkgs imports)] + , ptext (sLit "Dependent modules:") <+> ppr (eltsUFM (imp_dep_mods imports)) + , ptext (sLit "Dependent packages:") <+> ppr (imp_dep_pkgs imports)] pprModGuts :: ModGuts -> SDoc pprModGuts (ModGuts { mg_types = type_env, @@ -1411,16 +1426,16 @@ ppr_tydecls tycons where le_sig tycon1 tycon2 = getOccName tycon1 <= getOccName tycon2 ppr_tycon tycon - | isCoercionTyCon tycon = ptext SLIT("coercion") <+> ppr tycon + | isCoercionTyCon tycon = ptext (sLit "coercion") <+> ppr tycon | otherwise = ppr (tyThingToIfaceDecl (ATyCon tycon)) ppr_rules :: [CoreRule] -> SDoc ppr_rules [] = empty -ppr_rules rs = vcat [ptext SLIT("{-# RULES"), +ppr_rules rs = vcat [ptext (sLit "{-# RULES"), nest 4 (pprRules rs), - ptext SLIT("#-}")] + ptext (sLit "#-}")] ppr_gen_tycons [] = empty -ppr_gen_tycons tcs = vcat [ptext SLIT("Tycons with generics:"), +ppr_gen_tycons tcs = vcat [ptext (sLit "Tycons with generics:"), nest 2 (fsep (map ppr (filter tyConHasGenerics tcs)))] \end{code}