X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnDriver.lhs;h=fefb21aecfc9d44411e1875a56d6d5126508e5e1;hb=3ad8f84f6a75f240383e62a14472d14eb372dcd1;hp=ea29fb1256e125c4ad4337bd5037fa23b8e38b0c;hpb=e8a591c1a3dbdeccec2dd2aacccd7435004b0d51;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index ea29fb1..fefb21a 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -232,9 +232,10 @@ tcRnModule hsc_env hsc_src save_rn_syntax
 	reportDeprecations (hsc_dflags hsc_env) tcg_env ;
 
 		-- Process the export list
-	rn_exports <- rnExports export_ies ;
+	rn_exports <- rnExports export_ies;
         let { liftM2' fn a b = do a' <- a; b' <- b; return (fn a' b') } ;
-        exports <- mkExportNameSet (isJust maybe_mod) (liftM2' (,) rn_exports export_ies) ;
+        exports <- mkExportNameSet (isJust maybe_mod) 
+				   (liftM2' (,) rn_exports export_ies) ;
 
 		-- Check whether the entire module is deprecated
 		-- This happens only once per module
@@ -379,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 ;
 
@@ -473,7 +473,8 @@ tcRnHsBootDecls decls
 
 		-- Typecheck instance decls
 	; traceTc (text "Tc3")
-	; (tcg_env, inst_infos, _binds) <- tcInstDecls1 tycl_decls (hs_instds rn_group)
+	; (tcg_env, inst_infos, _binds) 
+            <- tcInstDecls1 tycl_decls (hs_instds rn_group) (hs_derivds rn_group)
 	; setGblEnv tcg_env	$ do {
 
 		-- Typecheck value declarations
@@ -562,6 +563,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"))
@@ -628,6 +630,7 @@ tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
 tcTopSrcDecls boot_details
 	(HsGroup { hs_tyclds = tycl_decls, 
 		   hs_instds = inst_decls,
+                   hs_derivds = deriv_decls,
 		   hs_fords  = foreign_decls,
 		   hs_defds  = default_decls,
 		   hs_ruleds = rule_decls,
@@ -648,7 +651,8 @@ tcTopSrcDecls boot_details
 		-- Source-language instances, including derivings,
 		-- and import the supporting declarations
         traceTc (text "Tc3") ;
-	(tcg_env, inst_infos, deriv_binds) <- tcInstDecls1 tycl_decls inst_decls ;
+	(tcg_env, inst_infos, deriv_binds) 
+            <- tcInstDecls1 tycl_decls inst_decls deriv_decls;
 	setGblEnv tcg_env	$ do {
 
 	        -- Foreign import declarations next.  No zonking necessary
@@ -963,15 +967,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]