X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FPprCore.lhs;h=041b842b811bd24797de20852fe8ba1ead6e4088;hb=b6264a6b8a8e22e24464da39ca0a3a0176d91f4e;hp=3752d1d5bd4239f96653998a4996bc0ad31618de;hpb=a51fe79ebcdcb8285573a18f12cade2101533419;p=ghc-hetmet.git

diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs
index 3752d1d..041b842 100644
--- a/compiler/coreSyn/PprCore.lhs
+++ b/compiler/coreSyn/PprCore.lhs
@@ -152,11 +152,27 @@ ppr_expr add_par expr@(App {})
     }
 
 ppr_expr add_par (Case expr var ty [(con,args,rhs)])
+  | opt_PprCaseAsLet
+  = add_par $
+    sep [sep 	[ ptext (sLit "let")
+			<+> char '{'
+			<+> ppr_case_pat con args 
+			<+> ptext (sLit "~")
+			<+> ppr_bndr var
+		, ptext (sLit "<-") 
+		  	<+> ppr_expr id expr
+		, char '}' 
+			<+> ptext (sLit "in")
+	  	]
+	, pprCoreExpr rhs
+    	]
+
+  | otherwise
   = add_par $
     sep [sep [ptext (sLit "case") <+> pprCoreExpr expr,
 	      ifPprDebug (braces (ppr ty)),
 	      sep [ptext (sLit "of") <+> ppr_bndr var, 
-		   char '{' <+> ppr_case_pat con args]
+		   char '{' <+> ppr_case_pat con args <+> arrow]
 	  ],
 	 pprCoreExpr rhs,
 	 char '}'
@@ -170,7 +186,7 @@ ppr_expr add_par (Case expr var ty alts)
 		<+> pprCoreExpr expr
 		<+> ifPprDebug (braces (ppr ty)),
 	      ptext (sLit "of") <+> ppr_bndr var <+> char '{'],
-	 nest 2 (sep (punctuate semi (map pprCoreAlt alts))),
+	 nest 2 (vcat (punctuate semi (map pprCoreAlt alts))),
 	 char '}'
     ]
   where
@@ -218,23 +234,28 @@ ppr_expr add_par (Note (CoreNote s) expr)
 
 pprCoreAlt :: OutputableBndr a => (AltCon, [a] , Expr a) -> SDoc
 pprCoreAlt (con, args, rhs) 
-  = hang (ppr_case_pat con args) 2 (pprCoreExpr rhs)
+  = hang (ppr_case_pat con args <+> arrow) 2 (pprCoreExpr rhs)
 
 ppr_case_pat :: OutputableBndr a => AltCon -> [a] -> SDoc
 ppr_case_pat (DataAlt dc) args
   | isTupleTyCon tc
-  = tupleParens (tupleTyConBoxity tc) (hsep (punctuate comma (map ppr_bndr args))) <+> arrow
+  = tupleParens (tupleTyConBoxity tc) (hsep (punctuate comma (map ppr_bndr args)))
   where
     ppr_bndr = pprBndr CaseBind
     tc = dataConTyCon dc
 
 ppr_case_pat con args
-  = ppr con <+> sep (map ppr_bndr args) <+> arrow
+  = ppr con <+> sep (map ppr_bndr args)
   where
     ppr_bndr = pprBndr CaseBind
 
+
+-- | Pretty print the argument in a function application.
 pprArg :: OutputableBndr a => Expr a -> SDoc
-pprArg (Type ty) = ptext (sLit "@") <+> pprParendType ty
+pprArg (Type ty) 
+ | opt_SuppressTypeApplications	= empty
+ | otherwise			= ptext (sLit "@") <+> pprParendType ty
+
 pprArg expr      = pprParendExpr expr
 \end{code}
 
@@ -277,8 +298,9 @@ pprTypedLCBinder bind_site debug_on var
 pprTypedBinder :: Var -> SDoc
 -- Print binder with a type or kind signature (not paren'd)
 pprTypedBinder binder
-  | isTyCoVar binder  = pprKindedTyVarBndr binder
-  | otherwise	    = hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder))
+  | isTyCoVar binder		= pprKindedTyVarBndr binder
+  | opt_SuppressTypeSignatures	= empty
+  | otherwise			= hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder))
 
 pprKindedTyVarBndr :: TyVar -> SDoc
 -- Print a type variable binder with its kind (but not if *)
@@ -297,6 +319,8 @@ pprIdBndr id = ppr id <+> pprIdBndrInfo (idInfo id)
 
 pprIdBndrInfo :: IdInfo -> SDoc
 pprIdBndrInfo info 
+  | opt_SuppressIdInfo = empty
+  | otherwise
   = megaSeqIdInfo info `seq` doc -- The seq is useful for poking on black holes
   where
     prag_info = inlinePragInfo info
@@ -325,6 +349,8 @@ pprIdBndrInfo info
 \begin{code}
 ppIdInfo :: Id -> IdInfo -> SDoc
 ppIdInfo id info
+  | opt_SuppressIdInfo	= empty
+  | otherwise
   = showAttributes
     [ (True, pp_scope <> ppr (idDetails id))
     , (has_arity,      ptext (sLit "Arity=") <> int arity)
@@ -389,8 +415,7 @@ instance Outputable Unfolding where
   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 con <+> brackets (pprWithCommas ppr 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
@@ -411,6 +436,11 @@ instance Outputable Unfolding where
              | otherwise          = empty
             -- Don't print the RHS or we get a quadratic 
 	    -- blowup in the size of the printout!
+
+instance Outputable e => Outputable (DFunArg e) where
+  ppr (DFunPolyArg e)  = braces (ppr e)
+  ppr (DFunConstArg e) = ppr e
+  ppr (DFunLamArg i)   = char '<' <> int i <> char '>'
 \end{code}
 
 -----------------------------------------------------