From: Jose Pedro Magalhaes <jpm@cs.uu.nl>
Date: Wed, 25 May 2011 09:57:44 +0000 (+0200)
Subject: Better output for -ddump-deriv when using generics.
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=74e1e73af872e63fbbec2bc9442494c3657053c3

Better output for -ddump-deriv when using generics.
---

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index b278ab4..fab7c61 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -332,7 +332,7 @@ tcDeriving tycl_decls inst_decls deriv_decls
 
 	; dflags <- getDOpts
 	; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
-	         (ddump_deriving inst_info rn_binds))
+	         (ddump_deriving inst_info rn_binds repMetaTys repTyCons metaInsts))
 {-
         ; when (not (null inst_info)) $
           dumpDerivingInfo (ddump_deriving inst_info rn_binds)
@@ -340,11 +340,26 @@ tcDeriving tycl_decls inst_decls deriv_decls
 	; return ( inst_info, rn_binds, rn_dus
                  , concat (map metaTyCons2TyCons repMetaTys), repTyCons) }
   where
-    ddump_deriving :: [InstInfo Name] -> HsValBinds Name -> SDoc
-    ddump_deriving inst_infos extra_binds
-      = hang (ptext (sLit "Derived instances"))
-           2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos)
-              $$ ppr extra_binds)
+    ddump_deriving :: [InstInfo Name] -> HsValBinds Name 
+                   -> [MetaTyCons] -- ^ Empty data constructors
+                   -> [TyCon]      -- ^ Rep type family instances
+                   -> [[(InstInfo RdrName, DerivAuxBinds)]] 
+                      -- ^ Instances for the repMetaTys
+                   -> SDoc
+    ddump_deriving inst_infos extra_binds repMetaTys repTyCons metaInsts
+      =    hang (ptext (sLit "Derived instances"))
+              2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos)
+                 $$ ppr extra_binds)
+        $$ hangP "Generic representation" (
+              hangP "Generated datatypes for meta-information"
+               (vcat (map ppr repMetaTys))
+           -- The Outputable instance for TyCon unfortunately only prints the name...
+           $$ hangP "Representation types" 
+                (vcat (map ppr  repTyCons))
+           $$ hangP "Meta-information instances"
+                (vcat (map (pprInstInfoDetails . fst) (concat metaInsts))))
+    
+    hangP s x = text "" $$ hang (ptext (sLit s)) 2 x
 
 
 renameDeriv :: Bool -> LHsBinds RdrName
diff --git a/compiler/types/Generics.lhs b/compiler/types/Generics.lhs
index 57b2655..323da41 100644
--- a/compiler/types/Generics.lhs
+++ b/compiler/types/Generics.lhs
@@ -218,7 +218,7 @@ data MetaTyCons = MetaTyCons { -- One meta datatype per dataype
                              , metaS :: [[TyCon]] }
                              
 instance Outputable MetaTyCons where
-  ppr (MetaTyCons d c s) = ppr d <+> ppr c <+> ppr s
+  ppr (MetaTyCons d c s) = ppr d $$ vcat (map ppr c) $$ vcat (map ppr (concat s))
                                    
 metaTyCons2TyCons :: MetaTyCons -> [TyCon]
 metaTyCons2TyCons (MetaTyCons d c s) = d : c ++ concat s