X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcDeriv.lhs;h=1798be31000767eb58731395b4dee68c7f84f8cc;hb=b30f8b6540eb8fe10f06c6e12d0daa08464656c2;hp=4d1d448a24ad209fad447027bae61877f9d06488;hpb=a3bab0506498db41853543558c52a4fda0d183af;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 4d1d448..1798be3 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -317,15 +317,16 @@ tcDeriving tycl_decls inst_decls deriv_decls
 	; gen_binds <- mkGenericBinds is_boot tycl_decls
 	; (inst_info, rn_binds, rn_dus) <- renameDeriv is_boot gen_binds (insts1 ++ insts2)
 
-	; dflags <- getDOpts
-	; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
-	         (ddump_deriving inst_info rn_binds))
+        ; when (not (null inst_info)) $
+          dumpDerivingInfo (ddump_deriving inst_info rn_binds)
 
 	; return (inst_info, rn_binds, rn_dus) }
   where
     ddump_deriving :: [InstInfo Name] -> HsValBinds Name -> SDoc
     ddump_deriving inst_infos extra_binds
-      = vcat (map pprInstInfoDetails inst_infos) $$ ppr extra_binds
+      = hang (ptext (sLit "Derived instances"))
+           2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos)
+              $$ ppr extra_binds)
 
 renameDeriv :: Bool -> LHsBinds RdrName
 	    -> [(InstInfo RdrName, DerivAuxBinds)]
@@ -749,7 +750,7 @@ inferConstraints _ cls inst_tys rep_tc rep_tc_args
 
     get_constrained_tys :: [Type] -> [Type]
     get_constrained_tys tys 
-    	| is_functor_like = concatMap (deepSubtypesContaining last_tv) tys
+        | is_functor_like = concatMap (deepSubtypesContaining last_tv) tys
     	| otherwise	  = tys
 
     rep_tc_tvs = tyConTyVars rep_tc
@@ -901,7 +902,7 @@ cond_isEnumeration (_, rep_tc)
   where
     why = sep [ quotes (pprSourceTyCon rep_tc) <+> 
 	          ptext (sLit "is not an enumeration type")
-              , nest 2 $ ptext (sLit "(an enumeration consists of one or more nullary constructors)") ]
+              , ptext (sLit "(an enumeration consists of one or more nullary, non-GADT constructors)") ]
 		  -- See Note [Enumeration types] in TyCon
 
 cond_isProduct :: Condition
@@ -1281,7 +1282,7 @@ inferInstanceContexts oflag infer_specs
     gen_soln (DS { ds_loc = loc, ds_orig = orig, ds_tvs = tyvars 
 		 , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs })
       = setSrcSpan loc	$
-	addErrCtxt (derivInstCtxt clas inst_tys) $ 
+	addErrCtxt (derivInstCtxt the_pred) $ 
 	do {      -- Check for a bizarre corner case, when the derived instance decl should
 		  -- have form 	instance C a b => D (T a) where ...
 		  -- Note that 'b' isn't a parameter of T.  This gives rise to all sorts
@@ -1296,7 +1297,7 @@ inferInstanceContexts oflag infer_specs
                                      , not (tyVarsOfPred pred `subVarSet` tv_set)]  
 	   ; mapM_ (addErrTc . badDerivedPred) weird_preds	
 
-           ; theta <- simplifyDeriv orig tyvars deriv_rhs
+           ; theta <- simplifyDeriv orig the_pred tyvars deriv_rhs
 	   	-- checkValidInstance tyvars theta clas inst_tys
 		-- Not necessary; see Note [Exotic derived instance contexts]
 		-- 		  in TcSimplify
@@ -1306,6 +1307,8 @@ inferInstanceContexts oflag infer_specs
 		-- Hence no need to call:
 		--   checkValidInstance tyvars theta clas inst_tys
 	   ; return (sortLe (<=) theta) }	-- Canonicalise before returning the solution
+      where
+        the_pred = mkClassPred clas inst_tys
 
 ------------------------------------------------------------------
 mkInstance :: OverlapFlag -> ThetaType -> DerivSpec -> Instance
@@ -1510,9 +1513,9 @@ standaloneCtxt :: LHsType Name -> SDoc
 standaloneCtxt ty = hang (ptext (sLit "In the stand-alone deriving instance for")) 
 		       2 (quotes (ppr ty))
 
-derivInstCtxt :: Class -> [Type] -> Message
-derivInstCtxt clas inst_tys
-  = ptext (sLit "When deriving the instance for") <+> parens (pprClassPred clas inst_tys)
+derivInstCtxt :: PredType -> Message
+derivInstCtxt pred
+  = ptext (sLit "When deriving the instance for") <+> parens (ppr pred)
 
 badDerivedPred :: PredType -> Message
 badDerivedPred pred