X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnDriver.lhs;h=c1db86ae3cb335f173aa5ee3776f1923f7db0497;hb=365ab3dad0f9a77e01758a14bf3817dea0ee2a31;hp=86061be58d87d412498994426cb1dc313075069a;hpb=a835e9faf19400aa6b7999b6f64e60cb1c7737dd;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 86061be..c1db86a 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -380,7 +380,6 @@ tcRnSrcDecls decls TcGblEnv { tcg_type_env = type_env, tcg_binds = binds, tcg_rules = rules, tcg_fords = fords } = tcg_env } ; - tcDump tcg_env ; (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds) rules fords ; @@ -563,6 +562,7 @@ missingBootThing thing = ppr thing <+> ptext SLIT("is defined in the hs-boot file, but not in the module") bootMisMatch thing boot_decl real_decl = ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hs-boot file") + $+$ (ppr boot_decl) $+$ (ppr real_decl) instMisMatch inst = hang (ppr inst) 2 (ptext SLIT("is defined in the hs-boot file, but not in the module")) @@ -964,15 +964,20 @@ mkPlan stmt@(L loc (BindStmt {})) | [L _ v] <- collectLStmtBinders stmt -- One binder, for a bind stmt = do { let print_v = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar v)) (HsVar thenIOName) placeHolderType + + ; print_bind_result <- doptM Opt_PrintBindResult + ; 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 + ; return stuff } + -- The plans are: -- [stmt; print v] but not if v::() -- [stmt] - ; runPlans [do { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v] - ; v_ty <- zonkTcType (idType v_id) - ; ifM (isUnitTy v_ty || not (isTauTy v_ty)) failM - ; return stuff }, - tcGhciStmts [stmt] - ]} + ; runPlans ((if print_bind_result then [print_plan] else []) ++ + [tcGhciStmts [stmt]]) + } mkPlan stmt = tcGhciStmts [stmt]