X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FPprCore.lhs;h=1504ab9b58fc5928a9d86d381b93c5c627089bf4;hb=9ffadf219cbc4f8ec57264786df936a3cee88aec;hp=39d5b354f657b636a1877563fa5f53abc97ba0c8;hpb=eaa6fbdfd2077515e86979ae4b14f4a7124a0698;p=ghc-hetmet.git

diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs
index 39d5b35..1504ab9 100644
--- a/compiler/coreSyn/PprCore.lhs
+++ b/compiler/coreSyn/PprCore.lhs
@@ -248,15 +248,23 @@ instance OutputableBndr Var where
 
 pprCoreBinder :: BindingSite -> Var -> SDoc
 pprCoreBinder LetBind binder
-  | isTyVar binder = pprTypedBinder binder
+  | isTyVar binder = pprKindedTyVarBndr binder
   | otherwise
-  = vcat [sig, pprIdDetails binder, pragmas]
+  = 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,7 +272,8 @@ 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
@@ -272,19 +281,19 @@ pprUntypedBinder binder
   | 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
@@ -317,10 +326,12 @@ 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 _ info