X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FPprCore.lhs;h=37e22cf64a4d8087d50f91390680f70c6c7d0c2c;hp=26fe688bf2b88335368cc7068e9ae850457cf023;hb=a90dc3907a491bfb478262441534b24fb0eb22f4;hpb=a5b8f5c544e977a230da67456455aca9cd576637

diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs
index 26fe688..37e22cf 100644
--- a/compiler/coreSyn/PprCore.lhs
+++ b/compiler/coreSyn/PprCore.lhs
@@ -252,30 +252,28 @@ pprCoreBinder LetBind binder
 		     ppIdInfo binder (idInfo binder)
 
 -- Lambda bound type variables are preceded by "@"
-pprCoreBinder LambdaBind bndr 
-  | isDeadBinder bndr
+pprCoreBinder bind_site bndr 
   = getPprStyle $ \ sty ->
-    if debugStyle sty then
-	parens (pprTypedBinder bndr)
-    else
-	char '_'
-  | otherwise
-  = parens (pprTypedBinder bndr)
-
--- Case bound things don't get a signature or a herald, unless we have debug on
-pprCoreBinder CaseBind bndr 
-  = getPprStyle $ \ sty ->
-    if debugStyle sty then
-	parens (pprTypedBinder bndr)
-    else
-	if isDeadBinder bndr then char '_'
-	else pprUntypedBinder bndr
+    pprTypedLCBinder bind_site (debugStyle sty) bndr
 
 pprUntypedBinder :: Var -> SDoc
 pprUntypedBinder binder
   | isTyVar binder = ptext (sLit "@") <+> ppr binder	-- NB: don't print kind
   | otherwise      = pprIdBndr binder
 
+pprTypedLCBinder :: BindingSite -> Bool -> Var -> SDoc
+-- For lambda and case binders, show the unfolding info (usually none)
+pprTypedLCBinder bind_site debug_on var
+  | not debug_on && isDeadBinder var    = char '_'
+  | not debug_on, CaseBind <- bind_site = pprUntypedBinder var  -- No parens, no kind info
+  | isTyVar var                         = parens (pprKindedTyVarBndr var)
+  | otherwise = parens (hang (pprIdBndr var) 
+                           2 (vcat [ dcolon <+> pprType (idType var), pp_unf]))
+              where
+		unf_info = unfoldingInfo (idInfo var)
+                pp_unf | hasSomeUnfolding unf_info = ptext (sLit "Unf=") <> ppr unf_info
+                       | otherwise                 = empty
+
 pprTypedBinder :: Var -> SDoc
 -- Print binder with a type or kind signature (not paren'd)
 pprTypedBinder binder
@@ -388,10 +386,11 @@ instance Outputable UnfoldingSource where
   ppr InlineRhs         = ptext (sLit "<vanilla>")
 
 instance Outputable Unfolding where
-  ppr NoUnfolding             = ptext (sLit "No unfolding")
-  ppr (OtherCon cs)           = ptext (sLit "OtherCon") <+> ppr cs
-  ppr (DFunUnfolding con ops) = ptext (sLit "DFun") <+> ppr con
-                                 <+> brackets (pprWithCommas pprParendExpr ops)
+  ppr NoUnfolding             	 = ptext (sLit "No unfolding")
+  ppr (OtherCon cs)           	 = ptext (sLit "OtherCon") <+> ppr cs
+  ppr (DFunUnfolding ar con ops) = ptext (sLit "DFun") <> parens (ptext (sLit "arity=") <> int ar)  
+                                   <+> ppr con
+                                   <+> brackets (pprWithCommas pprParendExpr ops)
   ppr (CoreUnfolding { uf_src = src
                      , uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf
                      , uf_is_conlike=conlike, uf_is_cheap=cheap