[project @ 2005-02-25 13:57:05 by simonpj]

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

diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs
index 29a822a..04aeb5c 100644 (file)
--- a/ghc/compiler/coreSyn/PprCore.lhs
+++ b/ghc/compiler/coreSyn/PprCore.lhs
@@ -21,9 +21,6 @@ import CostCentre     ( pprCostCentreCore )
 import Var             ( Var )
 import Id              ( Id, idType, isDataConWorkId_maybe, idLBVarInfo, idArity,
                          idInfo, idInlinePragma, idOccInfo,
-#ifdef OLD_STRICTNESS
-                         idDemandInfo, 
-#endif
                          globalIdDetails, isGlobalId, isExportedId, 
                          isSpecPragmaId, idNewDemandInfo
                        )
@@ -33,11 +30,13 @@ import IdInfo               ( IdInfo, megaSeqIdInfo,
                          specInfo, pprNewStrictness,
                          workerInfo, ppWorkerInfo,
                          newStrictnessInfo, cafInfo, ppCafInfo,
+                       )
+
 #ifdef OLD_STRICTNESS
-                         cprInfo, ppCprInfo, 
-                         strictnessInfo, ppStrictnessInfo, 
+import Id              ( idDemandInfo )
+import IdInfo          ( cprInfo, ppCprInfo, strictnessInfo, ppStrictnessInfo ) 
 #endif
-                       )
+
 import DataCon         ( dataConTyCon )
 import TyCon           ( tupleTyConBoxity, isTupleTyCon )
 import Type            ( pprParendType, pprType, pprParendKind )
@@ -153,11 +152,11 @@ ppr_expr add_par expr@(App fun arg)
        other -> add_par (hang (pprParendExpr fun) 2 pp_args)
     }
 
-ppr_expr add_par (Case expr var [(con,args,rhs)])
+ppr_expr add_par (Case expr var ty [(con,args,rhs)])
   = add_par $
-    sep [sep [ptext SLIT("case") <+> pprCoreExpr expr,
+    sep [sep [ptext SLIT("case") <+> pprParendType ty <+> pprCoreExpr expr,
              hsep [ptext SLIT("of"),
-                   ppr_bndr var,
+                   ppr_bndr var, 
                    char '{',
                    ppr_case_pat con args
          ]],
@@ -167,9 +166,9 @@ ppr_expr add_par (Case expr var [(con,args,rhs)])
   where
     ppr_bndr = pprBndr CaseBind
 
-ppr_expr add_par (Case expr var alts)
+ppr_expr add_par (Case expr var ty alts)
   = add_par $
-    sep [sep [ptext SLIT("case") <+> pprCoreExpr expr,
+    sep [sep [ptext SLIT("case") <+> pprParendType ty <+> pprCoreExpr expr,
              ptext SLIT("of") <+> ppr_bndr var <+> char '{'],
         nest 2 (sep (punctuate semi (map pprCoreAlt alts))),
         char '}'
@@ -275,7 +274,7 @@ pprCoreBinder LetBind binder
     pragmas = ppIdInfo binder (idInfo binder)
 
 -- Lambda bound type variables are preceded by "@"
-pprCoreBinder LambdaBind bndr = pprTypedBinder bndr
+pprCoreBinder LambdaBind bndr = parens (pprTypedBinder bndr)
 
 -- Case bound things don't get a signature or a herald
 pprCoreBinder CaseBind bndr = pprUntypedBinder bndr
@@ -287,12 +286,6 @@ pprUntypedBinder binder
 pprTypedBinder binder
   | isTyVar binder  = ptext SLIT("@") <+> pprTyVarBndr binder
   | otherwise      = pprIdBndr binder <+> dcolon <+> pprType (idType binder)
-       -- The space before the :: is important; it helps the lexer
-       -- when reading inferfaces.  Otherwise it would lex "a::b" as one thing.
-       --
-       -- It's important that the type is parenthesised too, at least when
-       -- printing interfaces, because we get \ x::(a->b) y::(c->d) -> ...
-       --      [Jun 2002: interfaces are now binary, so this doesn't matter]
 
 pprTyVarBndr :: TyVar -> SDoc
 pprTyVarBndr tyvar
@@ -356,7 +349,7 @@ pprIdRules :: [IdCoreRule] -> SDoc
 pprIdRules rules = vcat (map pprIdRule rules)
 
 pprIdRule :: IdCoreRule -> SDoc
-pprIdRule (id,rule) = pprCoreRule (ppr id) rule
+pprIdRule (IdCoreRule id _ rule) = pprCoreRule (ppr id) rule
 
 pprCoreRule :: SDoc -> CoreRule -> SDoc
 pprCoreRule pp_fn (BuiltinRule name _)