Improve printing for -ddump-deriv

compiler/main/ErrUtils.lhs

@@ -22,7 +22,7 @@ module ErrUtils (
         mkDumpDoc, dumpSDoc,
 
 	--  * Messages during compilation
-	putMsg,
+        putMsg, putMsgWith,
 	errorMsg,
 	fatalErrorMsg,
 	compilationProgressMsg,
@@ -275,6 +275,12 @@ ifVerbose dflags val act
 putMsg :: DynFlags -> Message -> IO ()
 putMsg dflags msg = log_action dflags SevInfo noSrcSpan defaultUserStyle msg
 
+putMsgWith :: DynFlags -> PrintUnqualified -> Message -> IO ()
+putMsgWith dflags print_unqual msg
+  = log_action dflags SevInfo noSrcSpan sty msg
+  where
+    sty = mkUserStyle print_unqual AllTheWay
+
 errorMsg :: DynFlags -> Message -> IO ()
 errorMsg dflags msg = log_action dflags SevError noSrcSpan defaultErrStyle msg
 

compiler/typecheck/TcClassDcl.lhs

@@ -408,9 +408,8 @@ getGenericInstances class_decls
 	  else do 
 
 	-- Otherwise print it out
-	{ dflags <- getDOpts
-	; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Generic instances"
-	         (vcat (map pprInstInfoDetails gen_inst_info)))	
+        { dumpDerivingInfo $ hang (ptext (sLit "Generic instances"))
+                                2 (vcat (map pprInstInfoDetails gen_inst_info))
 	; return gen_inst_info }}
 
 get_generics :: TyClDecl Name -> TcM [InstInfo Name]

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)]
@@ -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

compiler/typecheck/TcEnv.lhs

@@ -637,7 +637,13 @@ data InstBindings a
                         -- in TcDeriv
 
 pprInstInfo :: InstInfo a -> SDoc
-pprInstInfo info = vcat [ptext (sLit "InstInfo:") <+> ppr (idType (iDFunId info))]
+pprInstInfo info = hang (ptext (sLit "instance"))
+                      2 (sep [ ifPprDebug (pprForAll tvs)
+                             , pprThetaArrow theta, ppr tau
+                             , ptext (sLit "where")])
+  where
+    (tvs, theta, tau) = tcSplitSigmaTy (idType (iDFunId info))
+
 
 pprInstInfoDetails :: OutputableBndr a => InstInfo a -> SDoc
 pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info))

compiler/typecheck/TcGenDeriv.lhs

@@ -168,7 +168,7 @@ gen_Eq_binds loc tycon
   where
     (nullary_cons, nonnullary_cons)
        | isNewTyCon tycon = ([], tyConDataCons tycon)
-       | otherwise	      = partition isNullarySrcDataCon (tyConDataCons tycon)
+       | otherwise        = partition isNullarySrcDataCon (tyConDataCons tycon)
 
     no_nullary_cons = null nullary_cons
 

compiler/typecheck/TcRnMonad.lhs

@@ -608,6 +608,14 @@ addLongErrAt loc msg extra
 	 let { err = mkLongErrMsg loc (mkPrintUnqualified dflags rdr_env) msg extra } ;
 	 (warns, errs) <- readTcRef errs_var ;
   	 writeTcRef errs_var (warns, errs `snocBag` err) }
+
+dumpDerivingInfo :: SDoc -> TcM ()
+dumpDerivingInfo doc
+  = do { dflags <- getDOpts
+       ; when (dopt Opt_D_dump_deriv dflags) $ do
+       { rdr_env <- getGlobalRdrEnv
+       ; let unqual = mkPrintUnqualified dflags rdr_env
+       ; liftIO (putMsgWith dflags unqual doc) } }
 \end{code}