Improve printing for -ddump-deriv

diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index 15b142b..d0a8a86 100644 (file)
--- a/compiler/main/ErrUtils.lhs
+++ b/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
 

diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs
index 542ce20..0f91f6b 100644 (file)
--- a/compiler/typecheck/TcClassDcl.lhs
+++ b/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]

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 4d1d448..88236a6 100644 (file)
--- 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)]
@@ -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

diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs
index 4b5730b..c51f786 100644 (file)
--- a/compiler/typecheck/TcEnv.lhs
+++ b/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))

diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs
index 6e5aedc..54d786f 100644 (file)
--- a/compiler/typecheck/TcGenDeriv.lhs
+++ b/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
 

diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index 92fa190..553fe5b 100644 (file)
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/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}