X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FPprCore.lhs;h=e2109375fbd4698267dd633b9f597d973d8d2f91;hp=d01c710bfbc742a0626a5d6170aee1c614c8ec84;hb=4bc25e8c30559b7a6a87b39afcc79340ae778788;hpb=b643165c4ac9d8a7864fbf268bd88b0b9a667443

diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs
index d01c710..e210937 100644
--- a/compiler/coreSyn/PprCore.lhs
+++ b/compiler/coreSyn/PprCore.lhs
@@ -6,13 +6,6 @@
 Printing of Core syntax
 
 \begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
 module PprCore (
 	pprCoreExpr, pprParendExpr,
 	pprCoreBinding, pprCoreBindings, pprCoreAlt,
@@ -72,8 +65,10 @@ instance OutputableBndr b => Outputable (Expr b) where
 %************************************************************************
 
 \begin{code}
+pprTopBinds :: OutputableBndr a => [Bind a] -> SDoc
 pprTopBinds binds = vcat (map pprTopBind binds)
 
+pprTopBind :: OutputableBndr a => Bind a -> SDoc
 pprTopBind (NonRec binder expr)
  = ppr_binding (binder,expr) $$ text ""
 
@@ -113,8 +108,8 @@ ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc
 
 ppr_expr add_par (Type ty)  = add_par (ptext (sLit "TYPE") <+> ppr ty)	-- Wierd
 	           
-ppr_expr add_par (Var name) = ppr name
-ppr_expr add_par (Lit lit)  = ppr lit
+ppr_expr _       (Var name) = ppr name
+ppr_expr _       (Lit lit)  = ppr lit
 
 ppr_expr add_par (Cast expr co) 
   = add_par $
@@ -132,7 +127,7 @@ ppr_expr add_par expr@(Lam _ _)
     hang (ptext (sLit "\\") <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow)
 	 2 (pprCoreExpr body)
 
-ppr_expr add_par expr@(App fun arg)
+ppr_expr add_par expr@(App {})
   = case collectArgs expr of { (fun, args) -> 
     let
 	pp_args     = sep (map pprArg args)
@@ -149,9 +144,9 @@ ppr_expr add_par expr@(App fun arg)
 			     tc	       = dataConTyCon dc
 			     saturated = val_args `lengthIs` idArity f
 
-		   other -> add_par (hang (ppr f) 2 pp_args)
+		   _ -> add_par (hang (ppr f) 2 pp_args)
 
-	other -> add_par (hang (pprParendExpr fun) 2 pp_args)
+	_ -> add_par (hang (pprParendExpr fun) 2 pp_args)
     }
 
 ppr_expr add_par (Case expr var ty [(con,args,rhs)])
@@ -222,10 +217,12 @@ ppr_expr add_par (Note (CoreNote s) expr)
     sep [sep [ptext (sLit "__core_note"), pprHsString (mkFastString s)],
          pprParendExpr expr]
 
+pprCoreAlt :: OutputableBndr a => (AltCon, [a] , Expr a) -> SDoc
 pprCoreAlt (con, args, rhs) 
   = hang (ppr_case_pat con args) 2 (pprCoreExpr rhs)
 
-ppr_case_pat con@(DataAlt dc) args
+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
   where
@@ -237,6 +234,7 @@ ppr_case_pat con args
   where
     ppr_bndr = pprBndr CaseBind
 
+pprArg :: OutputableBndr a => Expr a -> SDoc
 pprArg (Type ty) = ptext (sLit "@") <+> pprParendType ty
 pprArg expr      = pprParendExpr expr
 \end{code}
@@ -250,13 +248,23 @@ instance OutputableBndr Var where
 
 pprCoreBinder :: BindingSite -> Var -> SDoc
 pprCoreBinder LetBind binder
-  = vcat [sig, pprIdDetails binder, pragmas]
+  | isTyVar binder = pprKindedTyVarBndr binder
+  | otherwise
+  = vcat [sig, pprIdExtras binder, pragmas]
   where
     sig     = pprTypedBinder binder
     pragmas = ppIdInfo binder (idInfo binder)
 
 -- Lambda bound type variables are preceded by "@"
-pprCoreBinder LambdaBind bndr = parens (pprTypedBinder bndr)
+pprCoreBinder LambdaBind bndr 
+  | isDeadBinder 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 
@@ -264,31 +272,36 @@ pprCoreBinder CaseBind bndr
     if debugStyle sty then
 	parens (pprTypedBinder bndr)
     else
-	pprUntypedBinder bndr
+	if isDeadBinder bndr then char '_'
+	else pprUntypedBinder bndr
 
+pprUntypedBinder :: Var -> SDoc
 pprUntypedBinder binder
   | isTyVar binder = ptext (sLit "@") <+> ppr binder	-- NB: don't print kind
   | otherwise      = pprIdBndr binder
 
+pprTypedBinder :: Var -> SDoc
+-- Print binder with a type or kind signature (not paren'd)
 pprTypedBinder binder
-  | isTyVar binder  = ptext (sLit "@") <+> pprTyVarBndr binder
+  | isTyVar binder  = pprKindedTyVarBndr binder
   | otherwise	    = pprIdBndr binder <+> dcolon <+> pprType (idType binder)
 
-pprTyVarBndr :: TyVar -> SDoc
-pprTyVarBndr tyvar
-  = getPprStyle $ \ sty ->
-    if debugStyle sty then
-        hsep [ppr tyvar, dcolon, pprParendKind kind]
-		-- See comments with ppDcolon in PprCore.lhs
-    else
-        ppr tyvar
+pprKindedTyVarBndr :: TyVar -> SDoc
+-- Print a type variable binder with its kind (but not if *)
+pprKindedTyVarBndr tyvar
+  = ptext (sLit "@") <+> ppr tyvar <> opt_kind
   where
+    opt_kind 	-- Print the kind if not *
+	| isLiftedTypeKind kind = empty
+	| otherwise = dcolon <> pprKind kind
     kind = tyVarKind tyvar
 
 -- pprIdBndr does *not* print the type
 -- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
+pprIdBndr :: Id -> SDoc
 pprIdBndr id = ppr id <+> pprIdBndrInfo (idInfo id)
 
+pprIdBndrInfo :: IdInfo -> SDoc
 pprIdBndrInfo info 
   = megaSeqIdInfo info `seq` doc -- The seq is useful for poking on black holes
   where
@@ -297,7 +310,7 @@ pprIdBndrInfo info
     dmd_info  = newDemandInfo info
     lbv_info  = lbvarInfo info
 
-    no_info = isAlwaysActive prag_info && isNoOcc occ_info && 
+    no_info = isDefaultInlinePragma prag_info && isNoOcc occ_info && 
 	      (case dmd_info of { Nothing -> True; Just d -> isTop d }) &&
 	      hasNoLBVarInfo lbv_info
 
@@ -313,13 +326,15 @@ pprIdBndrInfo info
 
 
 \begin{code}
-pprIdDetails :: Id -> SDoc
-pprIdDetails id | isGlobalId id     = ppr (globalIdDetails id)
-		| isExportedId id   = ptext (sLit "[Exported]")
-		| otherwise	    = empty
+pprIdExtras :: Id -> SDoc
+pprIdExtras id = pp_scope <> ppr (idDetails id)
+  where
+    pp_scope | isGlobalId id   = ptext (sLit "GblId")
+    	     | isExportedId id = ptext (sLit "LclIdX")
+    	     | otherwise       = ptext (sLit "LclId")
 
 ppIdInfo :: Id -> IdInfo -> SDoc
-ppIdInfo b info
+ppIdInfo _ info
   = brackets $
     vcat [  ppArityInfo a,
 	    ppWorkerInfo (workerInfo info),