[project @ 2000-08-07 23:37:19 by qrczak]

[ghc-hetmet.git] / ghc / compiler / hsSyn / HsCore.lhs

diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs
index c7f3c2f..e91e601 100644 (file)
--- a/ghc/compiler/hsSyn/HsCore.lhs
+++ b/ghc/compiler/hsSyn/HsCore.lhs
@@ -38,19 +38,18 @@ import IdInfo               ( ArityInfo, UpdateInfo, InlinePragInfo,
                          pprInlinePragInfo, ppArityInfo, ppStrictnessInfo
                        )
 import RdrName         ( RdrName )
-import Name            ( Name, toRdrName )
+import Name            ( toRdrName )
 import CoreSyn
 import CostCentre      ( pprCostCentreCore )
 import PrimOp          ( PrimOp(CCallOp) )
-import Demand          ( Demand, StrictnessInfo )
+import Demand          ( StrictnessInfo )
 import Literal         ( Literal, maybeLitLit )
 import PrimOp          ( CCall, pprCCallOp )
 import DataCon         ( dataConTyCon )
 import TyCon           ( isTupleTyCon, tupleTyConBoxity )
-import Type            ( Type, Kind )
+import Type            ( Kind )
 import CostCentre
 import SrcLoc          ( SrcLoc )
-import BasicTypes      ( Arity )
 import Outputable
 \end{code}
 
@@ -191,10 +190,13 @@ pprUfExpr :: Outputable name => (SDoc -> SDoc) -> UfExpr name -> SDoc
 
 pprUfExpr add_par (UfVar v)       = ppr v
 pprUfExpr add_par (UfLit l)       = ppr l
-pprUfExpr add_par (UfLitLit l ty) = add_par (hsep [ptext SLIT("__litlit"), pprFSAsString l, pprParendHsType ty])
+pprUfExpr add_par (UfLitLit l ty) = add_par (hsep [ptext SLIT("__litlit"), pprHsString l, pprParendHsType ty])
 pprUfExpr add_par (UfCCall cc ty) = braces (pprCCallOp cc <+> ppr ty)
 pprUfExpr add_par (UfType ty)     = char '@' <+> pprParendHsType ty
-pprUfExpr add_par (UfLam b body)  = add_par (hsep [char '\\', ppr b, ptext SLIT("->"), pprUfExpr noParens body])
+
+pprUfExpr add_par e@(UfLam _ _)   = add_par (char '\\' <+> hsep (map ppr bndrs)
+                                             <+> ptext SLIT("->") <+> pprUfExpr noParens body)
+                                  where (bndrs,body) = collectUfBndrs e
 pprUfExpr add_par (UfApp fun arg) = add_par (pprUfExpr noParens fun <+> pprUfExpr parens arg)
 pprUfExpr add_par (UfTuple c as)  = hsTupParens c (interpp'SP as)
 
@@ -220,6 +222,13 @@ pprUfExpr add_par (UfLet (UfRec pairs) body)
 
 pprUfExpr add_par (UfNote note body) = add_par (ppr note <+> pprUfExpr parens body)
 
+collectUfBndrs :: UfExpr name -> ([UfBinder name], UfExpr name)
+collectUfBndrs expr
+  = go [] expr
+  where
+    go bs (UfLam b e) = go (b:bs) e
+    go bs e           = (reverse bs, e)
+
 instance Outputable name => Outputable (UfNote name) where
     ppr (UfSCC cc)    = pprCostCentreCore cc
     ppr (UfCoerce ty) = ptext SLIT("__coerce") <+> pprParendHsType ty
@@ -229,7 +238,7 @@ instance Outputable name => Outputable (UfNote name) where
 instance Outputable name => Outputable (UfConAlt name) where
     ppr UfDefault         = text "__DEFAULT"
     ppr (UfLitAlt l)       = ppr l
-    ppr (UfLitLitAlt l ty) = parens (hsep [ptext SLIT("__litlit"), pprFSAsString l, pprParendHsType ty])
+    ppr (UfLitLitAlt l ty) = parens (hsep [ptext SLIT("__litlit"), pprHsString l, pprParendHsType ty])
     ppr (UfDataAlt d)     = ppr d
 
 instance Outputable name => Outputable (UfBinder name) where