X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnDriver.lhs;h=88695bcf9dd96526cf46eb418f550a027c65dab7;hp=a646125a0858e96edf1a81667e9bf3be1c697d53;hb=e1cae1230d5b334c045d0c568d5bf7d02a26dbd7;hpb=1d1c3c727617630beacacaf33022e1daba06a0bb diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index a646125..88695bc 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 @@ -67,30 +66,33 @@ import PprCore import CoreSyn import ErrUtils import Id +import VarEnv import Var import Module -import UniqFM +import LazyUniqFM import Name import NameEnv import NameSet import TyCon +import TysWiredIn import SrcLoc import HscTypes import ListSetOps import Outputable +import DataCon +import Type +import Class +import Data.List ( sortBy ) #ifdef GHCI import Linker -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,9 +104,10 @@ import Maybes import Util import Bag -import Control.Monad ( unless ) +import Control.Monad import Data.Maybe ( isJust ) +#include "HsVersions.h" \end{code} @@ -170,7 +173,7 @@ tcRnModule hsc_env hsc_src save_rn_syntax tcg_env <- finishDeprecations (hsc_dflags hsc_env) mod_deprec tcg_env ; -- Process the export list - traceRn (text "rn4a: before exports"); + traceRn (text "rn4a: before exports"); tcg_env <- rnExports (isJust maybe_mod) export_ies tcg_env ; traceRn (text "rn4b: after exportss") ; @@ -253,8 +256,7 @@ tcRnImports hsc_env this_mod import_decls -- Check type-familily consistency ; traceRn (text "rn1: checking family instance consistency") - ; let { dir_imp_mods = map (\ (mod, _) -> mod) - . moduleEnvElts + ; let { dir_imp_mods = moduleEnvKeys . imp_mods $ imports } ; checkFamInstConsistency (imp_finsts imports) dir_imp_mods ; @@ -290,10 +292,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 +505,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 @@ -551,6 +554,7 @@ checkHiBootIface -- be the equivalent to the dfun bindings returned for class -- instances? We can't easily equate tycons... + ; failIfErrsM ; return tcg_env' } where check_export boot_avail -- boot_avail is exported by the boot iface @@ -561,7 +565,8 @@ checkHiBootIface -- Check that the actual module exports the same thing | not (null missing_names) - = addErrTc (missingBootThing (head missing_names) "exported by") + = addErrAt (nameSrcSpan (head missing_names)) + (missingBootThing (head missing_names) "exported by") -- If the boot module does not *define* the thing, we are done -- (it simply re-exports it, and names match, so nothing further to do) @@ -569,13 +574,14 @@ checkHiBootIface -- Check that the actual module also defines the thing, and -- then compare the definitions - | Just real_thing <- lookupTypeEnv local_type_env name - = do { let boot_decl = tyThingToIfaceDecl (fromJust mb_boot_thing) - real_decl = tyThingToIfaceDecl real_thing - ; checkTc (checkBootDecl boot_decl real_decl) - (bootMisMatch real_thing boot_decl real_decl) } - -- The easiest way to check compatibility is to convert to - -- iface syntax, where we already have good comparison functions + | Just real_thing <- lookupTypeEnv local_type_env name, + Just boot_thing <- mb_boot_thing + = when (not (checkBootDecl boot_thing real_thing)) + $ addErrAt (nameSrcSpan (getName boot_thing)) + (let boot_decl = tyThingToIfaceDecl + (fromJust mb_boot_thing) + real_decl = tyThingToIfaceDecl real_thing + in bootMisMatch real_thing boot_decl real_decl) | otherwise = addErrTc (missingBootThing name "defined in") @@ -605,19 +611,116 @@ checkHiBootIface local_boot_dfun = Id.mkExportedLocalId (idName boot_dfun) boot_inst_ty +-- This has to compare the TyThing from the .hi-boot file to the TyThing +-- in the current source file. We must be careful to allow alpha-renaming +-- where appropriate, and also the boot declaration is allowed to omit +-- constructors and class methods. +-- +-- See rnfail055 for a good test of this stuff. + +checkBootDecl :: TyThing -> TyThing -> Bool + +checkBootDecl (AnId id1) (AnId id2) + = ASSERT(id1 == id2) + (idType id1 `tcEqType` idType id2) + +checkBootDecl (ATyCon tc1) (ATyCon tc2) + | isSynTyCon tc1 && isSynTyCon tc2 + = ASSERT(tc1 == tc2) + let tvs1 = tyConTyVars tc1; tvs2 = tyConTyVars tc2 + env = rnBndrs2 env0 tvs1 tvs2 + + eqSynRhs (OpenSynTyCon k1 _) (OpenSynTyCon k2 _) + = tcEqTypeX env k1 k2 + eqSynRhs (SynonymTyCon t1) (SynonymTyCon t2) + = tcEqTypeX env t1 t2 + in + equalLength tvs1 tvs2 && + eqSynRhs (synTyConRhs tc1) (synTyConRhs tc2) + + | isAlgTyCon tc1 && isAlgTyCon tc2 + = ASSERT(tc1 == tc2) + eqListBy tcEqPred (tyConStupidTheta tc1) (tyConStupidTheta tc2) + && eqAlgRhs (algTyConRhs tc1) (algTyConRhs tc2) + + | isForeignTyCon tc1 && isForeignTyCon tc2 + = tyConExtName tc1 == tyConExtName tc2 + where + env0 = mkRnEnv2 emptyInScopeSet + + eqAlgRhs AbstractTyCon _ = True + eqAlgRhs OpenTyCon{} OpenTyCon{} = True + eqAlgRhs tc1@DataTyCon{} tc2@DataTyCon{} = + eqListBy eqCon (data_cons tc1) (data_cons tc2) + eqAlgRhs tc1@NewTyCon{} tc2@NewTyCon{} = + eqCon (data_con tc1) (data_con tc2) + eqAlgRhs _ _ = False + + eqCon c1 c2 + = dataConName c1 == dataConName c2 + && dataConIsInfix c1 == dataConIsInfix c2 + && dataConStrictMarks c1 == dataConStrictMarks c2 + && dataConFieldLabels c1 == dataConFieldLabels c2 + && let tvs1 = dataConUnivTyVars c1 ++ dataConExTyVars c1 + tvs2 = dataConUnivTyVars c2 ++ dataConExTyVars c2 + env = rnBndrs2 env0 tvs1 tvs2 + in + equalLength tvs1 tvs2 && + eqListBy (tcEqPredX env) + (dataConEqTheta c1 ++ dataConDictTheta c1) + (dataConEqTheta c2 ++ dataConDictTheta c2) && + eqListBy (tcEqTypeX env) + (dataConOrigArgTys c1) + (dataConOrigArgTys c2) + +checkBootDecl (AClass c1) (AClass c2) + = let + (clas_tyvars1, clas_fds1, sc_theta1, _, _, op_stuff1) + = classExtraBigSig c1 + (clas_tyvars2, clas_fds2, sc_theta2, _, _, op_stuff2) + = classExtraBigSig c2 + + env0 = mkRnEnv2 emptyInScopeSet + env = rnBndrs2 env0 clas_tyvars1 clas_tyvars2 + + eqSig (id1, def_meth1) (id2, def_meth2) + = idName id1 == idName id2 && + tcEqTypeX env op_ty1 op_ty2 + where + (_, rho_ty1) = splitForAllTys (idType id1) + op_ty1 = funResultTy rho_ty1 + (_, rho_ty2) = splitForAllTys (idType id2) + op_ty2 = funResultTy rho_ty2 + + eqFD (as1,bs1) (as2,bs2) = + eqListBy (tcEqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) && + eqListBy (tcEqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2) + in + equalLength clas_tyvars1 clas_tyvars2 && + eqListBy eqFD clas_fds1 clas_fds2 && + (null sc_theta1 && null op_stuff1 + || + eqListBy (tcEqPredX env) sc_theta1 sc_theta2 && + eqListBy eqSig op_stuff1 op_stuff2) + +checkBootDecl (ADataCon dc1) (ADataCon dc2) + = pprPanic "checkBootDecl" (ppr dc1) + +checkBootDecl _ _ = False -- probably shouldn't happen + ---------------- 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 +876,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 +919,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,7 +1005,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,10 +1033,10 @@ 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:"), + 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 @@ -1012,7 +1121,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 +1146,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: @@ -1058,8 +1167,7 @@ tcGhciStmts stmts let { ret_ty = mkListTy unitTy ; io_ret_ty = mkTyConApp ioTyCon [ret_ty] ; - tc_io_stmts stmts = tcStmts DoExpr tcDoStmt stmts - (emptyRefinement, io_ret_ty) ; + tc_io_stmts stmts = tcStmts DoExpr tcDoStmt stmts io_ret_ty ; names = map unLoc (collectLStmtsBinders stmts) ; @@ -1083,7 +1191,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 @@ -1125,7 +1233,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 @@ -1147,7 +1255,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} @@ -1179,7 +1287,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 @@ -1308,7 +1416,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} @@ -1328,8 +1436,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) @@ -1342,8 +1450,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) } @@ -1363,8 +1471,16 @@ 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 (sortBy cmp_mp $ eltsUFM (imp_dep_mods imports)) + , ptext (sLit "Dependent packages:") <+> + ppr (sortBy stablePackageIdCmp $ imp_dep_pkgs imports)] + where -- The two uses of sortBy are just to reduce unnecessary + -- wobbling in testsuite output + cmp_mp (mod_name1, is_boot1) (mod_name2, is_boot2) + = (mod_name1 `stableModuleNameCmp` mod_name2) + `thenCmp` + (is_boot1 `compare` is_boot2) pprModGuts :: ModGuts -> SDoc pprModGuts (ModGuts { mg_types = type_env, @@ -1422,16 +1538,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}