X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnDriver.lhs;h=f7acc1927ee9841a936ec90ed10d9d82c6f1359a;hb=084a2fc52452bc2aba0511dd191923d677088d02;hp=cc7d63dbf6450dc900d205cc63c8f25051f424fc;hpb=9ffadf219cbc4f8ec57264786df936a3cee88aec;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index cc7d63d..f7acc19 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -25,7 +25,7 @@ module TcRnDriver ( tcRnExtCore ) where -import IO +import System.IO #ifdef GHCI import {-# SOURCE #-} TcSplice ( tcSpliceDecls ) #endif @@ -34,7 +34,6 @@ import DynFlags import StaticFlags import HsSyn import RdrHsSyn - import PrelNames import RdrName import TcHsSyn @@ -112,8 +111,6 @@ import Data.Maybe ( isJust ) #include "HsVersions.h" \end{code} - - %************************************************************************ %* * Typecheck and rename a module @@ -131,7 +128,7 @@ tcRnModule :: HscEnv tcRnModule hsc_env hsc_src save_rn_syntax (L loc (HsModule maybe_mod export_ies import_decls local_decls mod_deprec - module_info maybe_doc)) + maybe_doc_hdr)) = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ; let { this_pkg = thisPackage (hsc_dflags hsc_env) ; @@ -189,8 +186,9 @@ tcRnModule hsc_env hsc_src save_rn_syntax -- because the latter might add new bindings for boot_dfuns, -- which may be mentioned in imported unfoldings - -- Rename the Haddock documentation - tcg_env <- rnHaddock module_info maybe_doc tcg_env ; + -- Don't need to rename the Haddock documentation, + -- it's not parsed by GHC anymore. + tcg_env <- return (tcg_env { tcg_doc_hdr = maybe_doc_hdr }) ; -- Report unused names reportUnusedNames export_ies tcg_env ; @@ -237,7 +235,7 @@ tcRnImports hsc_env this_mod import_decls gbl { tcg_rdr_env = plusOccEnv (tcg_rdr_env gbl) rdr_env, tcg_imports = tcg_imports gbl `plusImportAvails` imports, - tcg_rn_imports = fmap (const rn_imports) (tcg_rn_imports gbl), + tcg_rn_imports = rn_imports, tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts, tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl) home_fam_insts, @@ -645,6 +643,53 @@ checkBootDecl (AnId id1) (AnId id2) (idType id1 `tcEqType` idType id2) checkBootDecl (ATyCon tc1) (ATyCon tc2) + = checkBootTyCon tc1 tc2 + +checkBootDecl (AClass c1) (AClass c2) + = let + (clas_tyvars1, clas_fds1, sc_theta1, _, ats1, op_stuff1) + = classExtraBigSig c1 + (clas_tyvars2, clas_fds2, sc_theta2, _, ats2, 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) + + same_kind tv1 tv2 = eqKind (tyVarKind tv1) (tyVarKind tv2) + in + eqListBy same_kind clas_tyvars1 clas_tyvars2 && + -- Checks kind of class + eqListBy eqFD clas_fds1 clas_fds2 && + (null sc_theta1 && null op_stuff1 && null ats1 + || -- Above tests for an "abstract" class + eqListBy (tcEqPredX env) sc_theta1 sc_theta2 && + eqListBy eqSig op_stuff1 op_stuff2 && + eqListBy checkBootTyCon ats1 ats2) + +checkBootDecl (ADataCon dc1) (ADataCon dc2) + = pprPanic "checkBootDecl" (ppr dc1) + +checkBootDecl _ _ = False -- probably shouldn't happen + +---------------- +checkBootTyCon :: TyCon -> TyCon -> Bool +checkBootTyCon tc1 tc2 + | not (eqKind (tyConKind tc1) (tyConKind tc2)) + = False -- First off, check the kind + | isSynTyCon tc1 && isSynTyCon tc2 = ASSERT(tc1 == tc2) let tvs1 = tyConTyVars tc1; tvs2 = tyConTyVars tc2 @@ -660,11 +705,13 @@ checkBootDecl (ATyCon tc1) (ATyCon tc2) | isAlgTyCon tc1 && isAlgTyCon tc2 = ASSERT(tc1 == tc2) - eqListBy tcEqPred (tyConStupidTheta tc1) (tyConStupidTheta tc2) - && eqAlgRhs (algTyConRhs tc1) (algTyConRhs tc2) + eqKind (tyConKind tc1) (tyConKind tc2) && + eqListBy tcEqPred (tyConStupidTheta tc1) (tyConStupidTheta tc2) && + eqAlgRhs (algTyConRhs tc1) (algTyConRhs tc2) | isForeignTyCon tc1 && isForeignTyCon tc2 - = tyConExtName tc1 == tyConExtName tc2 + = eqKind (tyConKind tc1) (tyConKind tc2) && + tyConExtName tc1 == tyConExtName tc2 where env0 = mkRnEnv2 emptyInScopeSet @@ -693,41 +740,6 @@ checkBootDecl (ATyCon tc1) (ATyCon tc2) (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") @@ -944,6 +956,12 @@ check_main dflags tcg_env pp_main_fn | main_fn == main_RDR_Unqual = ptext (sLit "function") <+> quotes (ppr main_fn) | otherwise = ptext (sLit "main function") <+> quotes (ppr main_fn) +-- | Get the unqualified name of the function to use as the \"main\" for the main module. +-- Either returns the default name or the one configured on the command line with -main-is +getMainFun :: DynFlags -> RdrName +getMainFun dflags = case (mainFunIs dflags) of + Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn)) + Nothing -> main_RDR_Unqual \end{code} Note [Root-main Id] @@ -1266,7 +1284,7 @@ tcRnType hsc_env ictxt rdr_type failIfErrsM ; -- Now kind-check the type - (ty', kind) <- kcHsType rn_type ; + (ty', kind) <- kcLHsType rn_type ; return kind } where @@ -1374,7 +1392,7 @@ tcRnGetInfo :: HscEnv -> Name -> IO (Messages, Maybe (TyThing, Fixity, [Instance])) --- Used to implemnent :info in GHCi +-- Used to implement :info in GHCi -- -- Look up a RdrName and return all the TyThings it might be -- A capitalised RdrName is given to us in the DataName namespace,