X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnDriver.lhs;h=88695bcf9dd96526cf46eb418f550a027c65dab7;hp=7d023dd70a01645218369273217ea2d91ce8f55d;hb=e1cae1230d5b334c045d0c568d5bf7d02a26dbd7;hpb=459870b70715b066aadd6a9defc87fb1ffb45bf4 diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 7d023dd..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 ) @@ -68,6 +66,7 @@ import PprCore import CoreSyn import ErrUtils import Id +import VarEnv import Var import Module import LazyUniqFM @@ -80,10 +79,13 @@ 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 @@ -105,6 +107,7 @@ import Bag 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 ; @@ -503,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 @@ -552,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 @@ -562,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) @@ -570,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") @@ -606,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} @@ -786,7 +888,7 @@ check_main dflags tcg_env -- :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 (mkTyConApp ioTyCon [res_ty]) @@ -817,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] @@ -934,7 +1036,7 @@ tcRnStmt hsc_env ictxt rdr_stmt 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 @@ -1131,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 @@ -1153,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} @@ -1185,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 @@ -1314,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} @@ -1369,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, @@ -1428,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}