Improvements to pretty-printing of Core

[ghc-hetmet.git] / compiler / coreSyn / PprCore.lhs

diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs
index 9213e9c..df2978e 100644 (file)
--- a/compiler/coreSyn/PprCore.lhs
+++ b/compiler/coreSyn/PprCore.lhs
@@ -123,7 +123,7 @@ ppr_expr add_par (Cast expr co)
   where
     pprCo co | opt_SuppressCoercions = ptext (sLit "...")
              | otherwise = parens
-                         $ sep [ppr co, dcolon <+> ppr (coercionKindPredTy co)]
+                         $ sep [ppr co, dcolon <+> pprEqPred (coercionKind co)]
         
 
 ppr_expr add_par expr@(Lam _ _)
@@ -269,9 +269,6 @@ pprCoreBinder LambdaBind bndr
 
 -- Case bound things don't get a signature or a herald, unless we have debug on
 pprCoreBinder CaseBind bndr 
-  | isDeadBinder bndr   -- False for tyvars
-  = ptext (sLit "_")
-  | otherwise
   = getPprStyle $ \ sty ->
     if debugStyle sty then
        parens (pprTypedBinder bndr)
@@ -379,20 +376,24 @@ showAttributes stuff
 \begin{code}
 instance Outputable UnfoldingGuidance where
     ppr UnfoldNever  = ptext (sLit "NEVER")
-    ppr UnfoldAlways = ptext (sLit "ALWAYS")
-    ppr (InlineRule { ug_ir_info = inl_info, ug_small = small })
-      = ptext (sLit "InlineRule") <> ppr (inl_info,small)
+    ppr (InlineRule { ir_info = info, ir_sat = sat })
+      = ptext (sLit "InlineRule") <> ppr (sat,info)
     ppr (UnfoldIfGoodArgs { ug_args = cs, ug_size = size, ug_res = discount })
       = hsep [ ptext (sLit "IF_ARGS"), 
               brackets (hsep (map int cs)),
               int size,
               int discount ]
 
-instance Outputable InlineRuleInfo where
-  ppr (InlWrapper w) = ptext (sLit "worker=") <> ppr w
+instance Outputable InlSatFlag where
   ppr InlSat         = ptext (sLit "sat")
   ppr InlUnSat       = ptext (sLit "unsat")
 
+instance Outputable InlineRuleInfo where
+  ppr (InlWrapper w) = ptext (sLit "worker=") <> ppr w
+  ppr InlSmall       = ptext (sLit "small")
+  ppr InlAlways      = ptext (sLit "always")
+  ppr InlVanilla     = ptext (sLit "-")
+
 instance Outputable Unfolding where
   ppr NoUnfolding             = ptext (sLit "No unfolding")
   ppr (OtherCon cs)           = ptext (sLit "OtherCon") <+> ppr cs
@@ -403,19 +404,22 @@ instance Outputable Unfolding where
                     , uf_expandable=exp, uf_guidance=g, uf_arity=arity}) 
        = ptext (sLit "Unf") <> braces (pp_info $$ pp_rhs)
     where
-      pp_info = hsep [ ptext (sLit "TopLvl=") <> ppr top 
-                     , ptext (sLit "Arity=") <> int arity
-                     , ptext (sLit "Value=") <> ppr hnf
-                     , ptext (sLit "ConLike=") <> ppr conlike
-                     , ptext (sLit "Cheap=") <> ppr cheap
-                     , ptext (sLit "Expandable=") <> ppr exp
-                     , ppr g ]
+      pp_info = fsep $ punctuate comma 
+                [ ptext (sLit "TopLvl=")     <> ppr top 
+                , ptext (sLit "Arity=")      <> int arity
+                , ptext (sLit "Value=")      <> ppr hnf
+                , ptext (sLit "ConLike=")    <> ppr conlike
+                , ptext (sLit "Cheap=")      <> ppr cheap
+                , ptext (sLit "Expandable=") <> ppr exp
+                , ptext (sLit "Guidance=")   <> ppr g ]
+      pp_tmpl = ptext (sLit "Tmpl=") <+> ppr rhs
       pp_rhs = case g of
                  UnfoldNever         -> usually_empty
                  UnfoldIfGoodArgs {} -> usually_empty
-                  _other              -> ppr rhs
-      usually_empty = ifPprDebug (ppr rhs)
-            -- In this case show 'rhs' only in debug mode
+                  _other              -> pp_tmpl
+      usually_empty = ifPprDebug (ptext (sLit "<rhs>"))
+            -- Don't print the RHS or we get a quadratic 
+           -- blowup in the size of the printout!
 \end{code}
 
 -----------------------------------------------------