X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnDriver.lhs;h=88dfe81f9eb7adb9cc561139c18381af91accf23;hb=2423c249f5ca7785d0ec89eb33e72662da7561c1;hp=94c55a7f17469ab6825943379cb005e4c9b7415f;hpb=f1842cac3b167b4597b4708aaf4a8392834aa06d;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 94c55a7..88dfe81 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -37,6 +37,7 @@ import TcExpr import TcRnMonad import TcType import Inst +import FamInst import InstEnv import FamInstEnv import TcBinds @@ -64,7 +65,6 @@ import Module import UniqFM import Name import NameSet -import NameEnv import TyCon import SrcLoc import HscTypes @@ -173,6 +173,13 @@ tcRnModule hsc_env hsc_src save_rn_syntax loadOrphanModules (imp_orphs imports) False ; loadOrphanModules (imp_finsts imports) True ; + traceRn (text "rn1: checking family instance consistency") ; + let { directlyImpMods = map (\(mod, _, _) -> mod) + . moduleEnvElts + . imp_mods + $ imports } ; + checkFamInstConsistency (imp_finsts imports) directlyImpMods ; + traceRn (text "rn1a") ; -- Rename and type check the declarations tcg_env <- if isHsBoot hsc_src then @@ -181,6 +188,8 @@ tcRnModule hsc_env hsc_src save_rn_syntax tcRnSrcDecls local_decls ; setGblEnv tcg_env $ do { + failIfErrsM ; -- reportDeprecations crashes sometimes + -- as a result of typechecker repairs (e.g. unboundNames) traceRn (text "rn3") ; -- Report the use of any deprecated things @@ -193,6 +202,8 @@ tcRnModule hsc_env hsc_src save_rn_syntax -- Process the export list (rn_exports, exports) <- rnExports (isJust maybe_mod) export_ies ; + traceRn (text "rn4") ; + -- Rename the Haddock documentation header rn_module_doc <- rnMbHsDoc maybe_doc ; @@ -294,7 +305,8 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) mg_rdr_env = emptyGlobalRdrEnv, mg_fix_env = emptyFixityEnv, mg_deprecs = NoDeprecs, - mg_foreign = NoStubs + mg_foreign = NoStubs, + mg_hpc_info = noHpcInfo } } ; tcCoreDump mod_guts ; @@ -326,29 +338,34 @@ tcRnSrcDecls decls boot_iface <- tcHiBootIface mod ; -- Do all the declarations - (tc_envs, lie) <- getLIE (tc_rn_src_decls boot_iface decls) ; + (tc_envs, lie) <- getLIE $ tc_rn_src_decls boot_iface decls ; + -- Finish simplifying class constraints + -- -- tcSimplifyTop deals with constant or ambiguous InstIds. -- How could there be ambiguous ones? They can only arise if a - -- top-level decl falls under the monomorphism - -- restriction, and no subsequent decl instantiates its - -- type. (Usually, ambiguous type variables are resolved - -- during the generalisation step.) + -- top-level decl falls under the monomorphism restriction + -- and no subsequent decl instantiates its type. + -- + -- We do this after checkMain, so that we use the type info + -- thaat checkMain adds + -- + -- We do it with both global and local env in scope: + -- * the global env exposes the instances to tcSimplifyTop + -- * the local env exposes the local Ids to tcSimplifyTop, + -- so that we get better error messages (monomorphism restriction) traceTc (text "Tc8") ; inst_binds <- setEnvs tc_envs (tcSimplifyTop lie) ; - -- Setting the global env exposes the instances to tcSimplifyTop - -- Setting the local env exposes the local Ids to tcSimplifyTop, - -- so that we get better error messages (monomorphism restriction) -- Backsubstitution. This must be done last. -- Even tcSimplifyTop may do some unification. traceTc (text "Tc9") ; - let { (tcg_env, _) = tc_envs ; - TcGblEnv { tcg_type_env = type_env, tcg_binds = binds, - tcg_rules = rules, tcg_fords = fords } = tcg_env } ; + let { (tcg_env, _) = tc_envs + ; TcGblEnv { tcg_type_env = type_env, tcg_binds = binds, + tcg_rules = rules, tcg_fords = fords } = tcg_env + ; all_binds = binds `unionBags` inst_binds } ; - (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds) - rules fords ; + (bind_ids, binds', fords', rules') <- zonkTopDecls all_binds rules fords ; let { final_type_env = extendTypeEnvWithIds type_env bind_ids ; tcg_env' = tcg_env { tcg_type_env = final_type_env, @@ -372,21 +389,17 @@ tc_rn_src_decls boot_details ds = do { let { (first_group, group_tail) = findSplice ds } ; -- If ds is [] we get ([], Nothing) - -- Type check the decls up to, but not including, the first splice - tc_envs@(tcg_env,tcl_env) <- tcRnGroup boot_details first_group ; - - -- Bale out if errors; for example, error recovery when checking - -- the RHS of 'main' can mean that 'main' is not in the envt for - -- the subsequent checkMain test - failIfErrsM ; - - setEnvs tc_envs $ + -- Deal with decls up to, but not including, the first splice + (tcg_env, rn_decls) <- checkNoErrs $ rnTopSrcDecls first_group ; + -- checkNoErrs: don't typecheck if renaming failed + tc_envs <- setGblEnv tcg_env $ + tcTopSrcDecls boot_details rn_decls ; -- If there is no splice, we're nearly done + setEnvs tc_envs $ case group_tail of { - Nothing -> do { -- Last thing: check for `main' - tcg_env <- checkMain ; - return (tcg_env, tcl_env) + Nothing -> do { tcg_env <- checkMain ; -- Check for `main' + return (tcg_env, snd tc_envs) } ; -- If there's a splice, we must carry on @@ -396,8 +409,8 @@ tc_rn_src_decls boot_details ds #else -- Rename the splice expression, and get its supporting decls - (rn_splice_expr, splice_fvs) <- rnLExpr splice_expr ; - failIfErrsM ; -- Don't typecheck if renaming failed + (rn_splice_expr, splice_fvs) <- checkNoErrs (rnLExpr splice_expr) ; + -- checkNoErrs: don't typecheck if renaming failed rnDump (ppr rn_splice_expr) ; -- Execute the splice @@ -407,7 +420,7 @@ tc_rn_src_decls boot_details ds setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $ tc_rn_src_decls boot_details (spliced_decls ++ rest_ds) #endif /* GHCI */ - }}} + } } } \end{code} %************************************************************************ @@ -454,7 +467,7 @@ tcRnHsBootDecls decls ; gbl_env <- getGblEnv -- Make the final type-env - -- Include the dfun_ids so that their type sigs get + -- Include the dfun_ids so that their type sigs -- are written into the interface file ; let { type_env0 = tcg_type_env gbl_env ; type_env1 = extendTypeEnvWithIds type_env0 val_ids @@ -558,17 +571,6 @@ declarations. It expects there to be an incoming TcGblEnv in the monad; it augments it and returns the new TcGblEnv. \begin{code} -tcRnGroup :: ModDetails -> HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv) - -- Returns the variables free in the decls, for unused-binding reporting -tcRnGroup boot_details decls - = do { -- Rename the declarations - (tcg_env, rn_decls) <- rnTopSrcDecls decls ; - setGblEnv tcg_env $ do { - - -- Typecheck the declarations - tcTopSrcDecls boot_details rn_decls - }} - ------------------------------------------------ rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name) rnTopSrcDecls group @@ -1269,6 +1271,7 @@ pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, tcg_rules = rules, tcg_imports = imports }) = vcat [ ppr_types insts type_env + , ppr_tycons fam_insts type_env , ppr_insts insts , ppr_fam_insts fam_insts , vcat (map ppr rules) @@ -1297,6 +1300,17 @@ ppr_types insts type_env -- that the type checker has invented. Top-level user-defined things -- have External names. +ppr_tycons :: [FamInst] -> TypeEnv -> SDoc +ppr_tycons fam_insts type_env + = text "TYPE CONSTRUCTORS" $$ nest 4 (ppr_tydecls tycons) + where + fi_tycons = map famInstTyCon fam_insts + tycons = [tycon | tycon <- typeEnvTyCons type_env, want_tycon tycon] + want_tycon tycon | opt_PprStyle_Debug = True + | otherwise = not (isImplicitTyCon tycon) && + isExternalName (tyConName tycon) && + not (tycon `elem` fi_tycons) + ppr_insts :: [Instance] -> SDoc ppr_insts [] = empty ppr_insts ispecs = text "INSTANCES" $$ nest 2 (pprInstances ispecs) @@ -1314,6 +1328,16 @@ ppr_sigs ids le_sig id1 id2 = getOccName id1 <= getOccName id2 ppr_sig id = ppr id <+> dcolon <+> ppr (tidyTopType (idType id)) +ppr_tydecls :: [TyCon] -> SDoc +ppr_tydecls tycons + -- Print type constructor info; sort by OccName + = vcat (map ppr_tycon (sortLe le_sig tycons)) + where + le_sig tycon1 tycon2 = getOccName tycon1 <= getOccName tycon2 + ppr_tycon 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"),