merge GHC HEAD

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

diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs
index 104bf81..e9452dc 100644 (file)
--- a/compiler/coreSyn/PprCore.lhs
+++ b/compiler/coreSyn/PprCore.lhs
@@ -106,7 +106,9 @@ ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc
        -- The function adds parens in context that need
        -- an atomic value (e.g. function args)
 
-ppr_expr add_par (Type ty)  = add_par (ptext (sLit "TYPE") <+> ppr ty) -- Wierd
+ppr_expr add_par (Type ty) = add_par (ptext (sLit "TYPE") <+> ppr ty)  -- Wierd
+
+ppr_expr add_par (Coercion co) = add_par (ptext (sLit "CO") <+> ppr co)
                   
 ppr_expr _       (Var name) = ppr name
 ppr_expr _       (Lit lit)  = ppr lit
@@ -152,11 +154,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 +188,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,18 +236,18 @@ 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
 
@@ -239,8 +257,8 @@ pprArg :: OutputableBndr a => Expr a -> SDoc
 pprArg (Type ty) 
  | opt_SuppressTypeApplications        = empty
  | otherwise                   = ptext (sLit "@") <+> pprParendType ty
-
-pprArg expr      = pprParendExpr expr
+pprArg (Coercion co) = ptext (sLit "@~") <+> pprParendCo co
+pprArg expr          = pprParendExpr expr
 \end{code}
 
 Other printing bits-and-bobs used with the general @pprCoreBinding@
@@ -252,7 +270,7 @@ instance OutputableBndr Var where
 
 pprCoreBinder :: BindingSite -> Var -> SDoc
 pprCoreBinder LetBind binder
-  | isTyCoVar binder = pprKindedTyVarBndr binder
+  | isTyVar binder = pprKindedTyVarBndr binder
   | otherwise      = pprTypedBinder binder $$ 
                     ppIdInfo binder (idInfo binder)
 
@@ -263,7 +281,7 @@ pprCoreBinder bind_site bndr
 
 pprUntypedBinder :: Var -> SDoc
 pprUntypedBinder binder
-  | isTyCoVar binder = ptext (sLit "@") <+> ppr binder -- NB: don't print kind
+  | isTyVar binder = ptext (sLit "@") <+> ppr binder   -- NB: don't print kind
   | otherwise      = pprIdBndr binder
 
 pprTypedLCBinder :: BindingSite -> Bool -> Var -> SDoc
@@ -271,7 +289,7 @@ pprTypedLCBinder :: BindingSite -> Bool -> Var -> SDoc
 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
-  | isTyCoVar var                         = parens (pprKindedTyVarBndr var)
+  | isTyVar var                         = parens (pprKindedTyVarBndr var)
   | otherwise = parens (hang (pprIdBndr var) 
                            2 (vcat [ dcolon <+> pprType (idType var), pp_unf]))
               where
@@ -282,7 +300,7 @@ 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
+  | isTyVar binder             = pprKindedTyVarBndr binder
   | opt_SuppressTypeSignatures = empty
   | otherwise                  = hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder))
 
@@ -303,6 +321,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
@@ -397,8 +417,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
@@ -419,6 +438,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}
 
 -----------------------------------------------------