X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsExpr.lhs;h=6a07e4cf7c2d031550dc96d6ee9d1f2d8bbe00b5;hb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;hp=b08debd8a1dcd7f2577ad213075d0adf3fef5842;hpb=8de16184643ea3c2f9f30b5eaed18db6ef247760;p=ghc-hetmet.git

diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs
index b08debd..6a07e4c 100644
--- a/ghc/compiler/hsSyn/HsExpr.lhs
+++ b/ghc/compiler/hsSyn/HsExpr.lhs
@@ -1,32 +1,29 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 \section[HsExpr]{Abstract Haskell syntax: expressions}
 
 \begin{code}
-#include "HsVersions.h"
-
 module HsExpr where
 
-IMP_Ubiq(){-uitous-}
-IMPORT_DELOOPER(HsLoop) -- for paranoia checking
+#include "HsVersions.h"
 
 -- friends:
+import {-# SOURCE #-} HsMatches ( pprMatches, pprMatch, Match )
+
 import HsBinds		( HsBinds )
-import HsBasic		( HsLit, Fixity(..), FixityDirection(..) )
-import HsMatches	( pprMatches, pprMatch, Match )
+import HsBasic		( HsLit )
+import BasicTypes	( Fixity(..), FixityDirection(..) )
 import HsTypes		( HsType )
 
 -- others:
-import Id		( SYN_IE(DictVar), GenId, SYN_IE(Id) )
-import Name		( pprNonSym, pprSym )
-import Outputable	( interppSP, interpp'SP, ifnotPprForUser )
-import PprType		( pprGenType, pprParendGenType, GenType{-instance-} )
-import Pretty
-import PprStyle		( PprStyle(..) )
+import Name		( Name, NamedThing(..), isLexSym, occNameString )
+import Outputable	
+import PprType		( pprType, pprParendType )
+import Type		( GenType )
+import Var		( GenTyVar, Id )
+import DataCon		( DataCon )
 import SrcLoc		( SrcLoc )
-import Usage		( GenUsage{-instance-} )
---import Util		( panic{-ToDo:rm eventually-} )
 \end{code}
 
 %************************************************************************
@@ -36,15 +33,15 @@ import Usage		( GenUsage{-instance-} )
 %************************************************************************
 
 \begin{code}
-data HsExpr tyvar uvar id pat
+data HsExpr flexi id pat
   = HsVar	id				-- variable
   | HsLit	HsLit				-- literal
   | HsLitOut	HsLit				-- TRANSLATION
-		(GenType tyvar uvar)		-- (with its type)
+		(GenType flexi)		-- (with its type)
 
-  | HsLam	(Match  tyvar uvar id pat)	-- lambda
-  | HsApp	(HsExpr tyvar uvar id pat)	-- application
-		(HsExpr tyvar uvar id pat)
+  | HsLam	(Match  flexi id pat)	-- lambda
+  | HsApp	(HsExpr flexi id pat)	-- application
+		(HsExpr flexi id pat)
 
   -- Operator applications:
   -- NB Bracketed ops such as (+) come out as Vars.
@@ -52,83 +49,95 @@ data HsExpr tyvar uvar id pat
   -- NB We need an expr for the operator in an OpApp/Section since
   -- the typechecker may need to apply the operator to a few types.
 
-  | OpApp	(HsExpr tyvar uvar id pat)	-- left operand
-		(HsExpr tyvar uvar id pat)	-- operator
+  | OpApp	(HsExpr flexi id pat)	-- left operand
+		(HsExpr flexi id pat)	-- operator
 		Fixity				-- Renamer adds fixity; bottom until then
-		(HsExpr tyvar uvar id pat)	-- right operand
+		(HsExpr flexi id pat)	-- right operand
 
   -- We preserve prefix negation and parenthesis for the precedence parser.
   -- They are eventually removed by the type checker.
 
-  | NegApp	(HsExpr tyvar uvar id pat)	-- negated expr
-		(HsExpr tyvar uvar id pat)	-- the negate id (in a HsVar)
+  | NegApp	(HsExpr flexi id pat)	-- negated expr
+		(HsExpr flexi id pat)	-- the negate id (in a HsVar)
 
-  | HsPar	(HsExpr tyvar uvar id pat)	-- parenthesised expr
+  | HsPar	(HsExpr flexi id pat)	-- parenthesised expr
 
-  | SectionL	(HsExpr tyvar uvar id pat)	-- operand
-		(HsExpr tyvar uvar id pat)	-- operator
-  | SectionR	(HsExpr tyvar uvar id pat)	-- operator
-		(HsExpr tyvar uvar id pat)	-- operand
+  | SectionL	(HsExpr flexi id pat)	-- operand
+		(HsExpr flexi id pat)	-- operator
+  | SectionR	(HsExpr flexi id pat)	-- operator
+		(HsExpr flexi id pat)	-- operand
 				
-  | HsCase	(HsExpr tyvar uvar id pat)
-		[Match  tyvar uvar id pat]	-- must have at least one Match
+  | HsCase	(HsExpr flexi id pat)
+		[Match  flexi id pat]	-- must have at least one Match
 		SrcLoc
 
-  | HsIf	(HsExpr tyvar uvar id pat)	--  predicate
-		(HsExpr tyvar uvar id pat)	--  then part
-		(HsExpr tyvar uvar id pat)	--  else part
+  | HsIf	(HsExpr flexi id pat)	--  predicate
+		(HsExpr flexi id pat)	--  then part
+		(HsExpr flexi id pat)	--  else part
 		SrcLoc
 
-  | HsLet	(HsBinds tyvar uvar id pat)	-- let(rec)
-		(HsExpr  tyvar uvar id pat)
+  | HsLet	(HsBinds flexi id pat)	-- let(rec)
+		(HsExpr  flexi id pat)
 
-  | HsDo	[Stmt tyvar uvar id pat]	-- "do":one or more stmts
+  | HsDo	StmtCtxt
+		[Stmt flexi id pat]	-- "do":one or more stmts
 		SrcLoc
 
-  | HsDoOut	[Stmt   tyvar uvar id pat]	-- "do":one or more stmts
-		id				-- id for >>=,  types applied
-		id				-- id for zero, typed applied
+  | HsDoOut	StmtCtxt
+		[Stmt   flexi id pat]	-- "do":one or more stmts
+		id				-- id for return
+		id				-- id for >>=
+		id				-- id for zero
+		(GenType flexi)		-- Type of the whole expression
 		SrcLoc
 
-  | ListComp	(HsExpr    tyvar uvar id pat)	-- list comprehension
-		[Qualifier tyvar uvar id pat]	-- at least one Qualifier
-
   | ExplicitList		-- syntactic list
-		[HsExpr tyvar uvar id pat]
+		[HsExpr flexi id pat]
   | ExplicitListOut		-- TRANSLATION
-		(GenType tyvar uvar)	-- Gives type of components of list
-		[HsExpr tyvar uvar id pat]
+		(GenType flexi)	-- Gives type of components of list
+		[HsExpr flexi id pat]
 
   | ExplicitTuple		-- tuple
-		[HsExpr tyvar uvar id pat]
+		[HsExpr flexi id pat]
 				-- NB: Unit is ExplicitTuple []
 				-- for tuples, we can get the types
 				-- direct from the components
+		Bool		-- boxed?
+
+  | HsCon DataCon		-- TRANSLATION; a saturated constructor application
+	  [GenType flexi]
+	  [HsExpr flexi id pat]
 
 	-- Record construction
-  | RecordCon	(HsExpr tyvar uvar id pat)	-- Always (HsVar id) until type checker,
-						-- but the latter adds its type args too
-		(HsRecordBinds tyvar uvar id pat)
+  | RecordCon	id				-- The constructor
+		(HsRecordBinds flexi id pat)
+
+  | RecordConOut DataCon
+		(HsExpr flexi id pat)		-- Data con Id applied to type args
+		(HsRecordBinds flexi id pat)
+
 
 	-- Record update
-  | RecordUpd	(HsExpr tyvar uvar id pat)
-		(HsRecordBinds tyvar uvar id pat)
+  | RecordUpd	(HsExpr flexi id pat)
+		(HsRecordBinds flexi id pat)
 
-  | RecordUpdOut (HsExpr tyvar uvar id pat)	-- TRANSLATION
+  | RecordUpdOut (HsExpr flexi id pat)	-- TRANSLATION
+		 (GenType flexi)		-- Type of *result* record (may differ from
+						-- type of input record)
 		 [id]				-- Dicts needed for construction
-		 (HsRecordBinds tyvar uvar id pat)
+		 (HsRecordBinds flexi id pat)
 
   | ExprWithTySig		-- signature binding
-		(HsExpr tyvar uvar id pat)
+		(HsExpr flexi id pat)
 		(HsType id)
   | ArithSeqIn			-- arithmetic sequence
-		(ArithSeqInfo tyvar uvar id pat)
+		(ArithSeqInfo flexi id pat)
   | ArithSeqOut
-		(HsExpr       tyvar uvar id pat) -- (typechecked, of course)
-		(ArithSeqInfo tyvar uvar id pat)
+		(HsExpr       flexi id pat) -- (typechecked, of course)
+		(ArithSeqInfo flexi id pat)
 
   | CCall	FAST_STRING	-- call into the C world; string is
-		[HsExpr tyvar uvar id pat]	-- the C function; exprs are the
+		[HsExpr flexi id pat]	-- the C function; exprs are the
 				-- arguments to pass.
 		Bool		-- True <=> might cause Haskell
 				-- garbage-collection (must generate
@@ -137,45 +146,33 @@ data HsExpr tyvar uvar id pat
 				-- NOTE: this CCall is the *boxed*
 				-- version; the desugarer will convert
 				-- it into the unboxed "ccall#".
-		(GenType tyvar uvar)	-- The result type; will be *bottom*
+		(GenType flexi)	-- The result type; will be *bottom*
 				-- until the typechecker gets ahold of it
 
   | HsSCC	FAST_STRING	-- "set cost centre" (_scc_) annotation
-		(HsExpr tyvar uvar id pat) -- expr whose cost is to be measured
+		(HsExpr flexi id pat) -- expr whose cost is to be measured
 \end{code}
 
 Everything from here on appears only in typechecker output.
 
 \begin{code}
   | TyLam			-- TRANSLATION
-		[tyvar]
-		(HsExpr tyvar uvar id pat)
+		[GenTyVar flexi]
+		(HsExpr flexi id pat)
   | TyApp			-- TRANSLATION
-		(HsExpr  tyvar uvar id pat) -- generated by Spec
-		[GenType tyvar uvar]
+		(HsExpr  flexi id pat) -- generated by Spec
+		[GenType flexi]
 
   -- DictLam and DictApp are "inverses"
   |  DictLam
 		[id]
-		(HsExpr tyvar uvar id pat)
+		(HsExpr flexi id pat)
   |  DictApp
-		(HsExpr tyvar uvar id pat)
+		(HsExpr flexi id pat)
 		[id]
 
-  -- ClassDictLam and Dictionary are "inverses" (see note below)
-  |  ClassDictLam
-		[id]		-- superclass dicts
-		[id]		-- methods
-		(HsExpr tyvar uvar id pat)
-  |  Dictionary
-		[id]		-- superclass dicts
-		[id]		-- methods
-
-  |  SingleDict			-- a simple special case of Dictionary
-		id		-- local dictionary name
-
-type HsRecordBinds tyvar uvar id pat
-  = [(id, HsExpr tyvar uvar id pat, Bool)]
+type HsRecordBinds flexi id pat
+  = [(id, HsExpr flexi id pat, Bool)]
 	-- True <=> source code used "punning",
 	-- i.e. {op1, op2} rather than {op1=e1, op2=e2}
 \end{code}
@@ -187,202 +184,188 @@ A @Dictionary@, unless of length 0 or 1, becomes a tuple.  A
 \end{verbatim}
 
 \begin{code}
-instance (NamedThing id, Outputable id, Outputable pat,
-	  Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
-		Outputable (HsExpr tyvar uvar id pat) where
-    ppr = pprExpr
+instance (NamedThing id, Outputable id, Outputable pat) =>
+		Outputable (HsExpr flexi id pat) where
+    ppr expr = pprExpr expr
 \end{code}
 
 \begin{code}
-pprExpr sty (HsVar v) = ppr sty v
+pprExpr :: (NamedThing id, Outputable id, Outputable pat)
+        => HsExpr flexi id pat -> SDoc
+
+pprExpr e = pprDeeper (ppr_expr e)
+pprBinds b = pprDeeper (ppr b)
+
+ppr_expr (HsVar v) = ppr v
 
-pprExpr sty (HsLit    lit)   = ppr sty lit
-pprExpr sty (HsLitOut lit _) = ppr sty lit
+ppr_expr (HsLit    lit)   = ppr lit
+ppr_expr (HsLitOut lit _) = ppr lit
 
-pprExpr sty (HsLam match)
-  = ppCat [ppStr "\\", ppNest 2 (pprMatch sty True match)]
+ppr_expr (HsLam match)
+  = hsep [char '\\', nest 2 (pprMatch True match)]
 
-pprExpr sty expr@(HsApp e1 e2)
+ppr_expr expr@(HsApp e1 e2)
   = let (fun, args) = collect_args expr [] in
-    ppHang (pprExpr sty fun) 4 (ppSep (map (pprExpr sty) args))
+    (ppr_expr fun) <+> (sep (map ppr_expr args))
   where
     collect_args (HsApp fun arg) args = collect_args fun (arg:args)
     collect_args fun		 args = (fun, args)
 
-pprExpr sty (OpApp e1 op fixity e2)
+ppr_expr (OpApp e1 op fixity e2)
   = case op of
       HsVar v -> pp_infixly v
       _	      -> pp_prefixly
   where
-    pp_e1 = pprParendExpr sty e1		-- Add parens to make precedence clear
-    pp_e2 = pprParendExpr sty e2
+    pp_e1 = pprParendExpr e1		-- Add parens to make precedence clear
+    pp_e2 = pprParendExpr e2
 
     pp_prefixly
-      = ppHang (pprExpr sty op) 4 (ppSep [pp_e1, pp_e2])
+      = hang (pprExpr op) 4 (sep [pp_e1, pp_e2])
 
     pp_infixly v
-      = ppSep [pp_e1, ppCat [ppr sty v, pp_e2]]
+      = sep [pp_e1, hsep [pp_v, pp_e2]]
+      where
+        pp_v | isLexSym (occNameString (getOccName v)) = ppr v
+	     | otherwise			       = char '`' <> ppr v <> char '`'
 
-pprExpr sty (NegApp e _)
-  = ppBeside (ppChar '-') (pprParendExpr sty e)
+ppr_expr (NegApp e _)
+  = char '-' <+> pprParendExpr e
 
-pprExpr sty (HsPar e)
-  = ppParens (pprExpr sty e)
+ppr_expr (HsPar e) = parens (ppr_expr e)
 
-pprExpr sty (SectionL expr op)
+ppr_expr (SectionL expr op)
   = case op of
       HsVar v -> pp_infixly v
       _	      -> pp_prefixly
   where
-    pp_expr = pprParendExpr sty expr
+    pp_expr = pprParendExpr expr
 
-    pp_prefixly = ppHang (ppCat [ppStr "( \\ x_ ->", ppr sty op])
-		       4 (ppCat [pp_expr, ppStr "x_ )"])
-    pp_infixly v
-      = ppSep [ ppBeside ppLparen pp_expr,
-	    	ppBeside (ppr sty v) ppRparen ]
+    pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op])
+		       4 (hsep [pp_expr, ptext SLIT("x_ )")])
+    pp_infixly v = parens (sep [pp_expr, ppr v])
 
-pprExpr sty (SectionR op expr)
+ppr_expr (SectionR op expr)
   = case op of
       HsVar v -> pp_infixly v
       _	      -> pp_prefixly
   where
-    pp_expr = pprParendExpr sty expr
+    pp_expr = pprParendExpr expr
 
-    pp_prefixly = ppHang (ppCat [ppStr "( \\ x_ ->", ppr sty op, ppPStr SLIT("x_")])
-		       4 (ppBeside pp_expr ppRparen)
+    pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, ptext SLIT("x_")])
+		       4 ((<>) pp_expr rparen)
     pp_infixly v
-      = ppSep [ ppBeside ppLparen (ppr sty v),
-		ppBeside pp_expr  ppRparen ]
+      = parens (sep [ppr v, pp_expr])
 
-pprExpr sty (HsCase expr matches _)
-  = ppSep [ ppSep [ppPStr SLIT("case"), ppNest 4 (pprExpr sty expr), ppPStr SLIT("of")],
-	    ppNest 2 (pprMatches sty (True, ppNil) matches) ]
+ppr_expr (HsCase expr matches _)
+  = sep [ sep [ptext SLIT("case"), nest 4 (pprExpr expr), ptext SLIT("of")],
+	    nest 2 (pprMatches (True, empty) matches) ]
 
-pprExpr sty (HsIf e1 e2 e3 _)
-  = ppSep [ppCat [ppPStr SLIT("if"), ppNest 2 (pprExpr sty e1), ppPStr SLIT("then")],
-	   ppNest 4 (pprExpr sty e2),
-	   ppPStr SLIT("else"),
-	   ppNest 4 (pprExpr sty e3)]
+ppr_expr (HsIf e1 e2 e3 _)
+  = sep [hsep [ptext SLIT("if"), nest 2 (pprExpr e1), ptext SLIT("then")],
+	   nest 4 (pprExpr e2),
+	   ptext SLIT("else"),
+	   nest 4 (pprExpr e3)]
 
 -- special case: let ... in let ...
-pprExpr sty (HsLet binds expr@(HsLet _ _))
-  = ppSep [ppHang (ppPStr SLIT("let")) 2 (ppCat [ppr sty binds, ppPStr SLIT("in")]),
-	   ppr sty expr]
-
-pprExpr sty (HsLet binds expr)
-  = ppSep [ppHang (ppPStr SLIT("let")) 2 (ppr sty binds),
-	   ppHang (ppPStr SLIT("in"))  2 (ppr sty expr)]
-
-pprExpr sty (HsDo stmts _)
-  = ppHang (ppPStr SLIT("do")) 2 (ppAboves (map (ppr sty) stmts))
-pprExpr sty (HsDoOut stmts _ _ _)
-  = ppHang (ppPStr SLIT("do")) 2 (ppAboves (map (ppr sty) stmts))
-
-pprExpr sty (ListComp expr quals)
-  = ppHang (ppCat [ppLbrack, pprExpr sty expr, ppChar '|'])
-	 4 (ppSep [interpp'SP sty quals, ppRbrack])
-
-pprExpr sty (ExplicitList exprs)
-  = ppBracket (ppInterleave ppComma (map (pprExpr sty) exprs))
-pprExpr sty (ExplicitListOut ty exprs)
-  = ppBesides [ ppBracket (ppInterleave ppComma (map (pprExpr sty) exprs)),
-		ifnotPprForUser sty (ppBeside ppSP (ppParens (pprGenType sty ty))) ]
-
-pprExpr sty (ExplicitTuple exprs)
-  = ppParens (ppInterleave ppComma (map (pprExpr sty) exprs))
-
-pprExpr sty (RecordCon con  rbinds)
-  = pp_rbinds sty (ppr sty con) rbinds
-
-pprExpr sty (RecordUpd aexp rbinds)
-  = pp_rbinds sty (pprParendExpr sty aexp) rbinds
-pprExpr sty (RecordUpdOut aexp _ rbinds)
-  = pp_rbinds sty (pprParendExpr sty aexp) rbinds
-
-pprExpr sty (ExprWithTySig expr sig)
-  = ppHang (ppBeside (ppNest 2 (pprExpr sty expr)) (ppPStr SLIT(" ::")))
-	 4 (ppr sty sig)
-
-pprExpr sty (ArithSeqIn info)
-  = ppBracket (ppr sty info)
-pprExpr sty (ArithSeqOut expr info)
-  = case sty of
-  	PprForUser ->
-    	  ppBracket (ppr sty info)
-	_   	   ->
-    	  ppBesides [ppLbrack, ppParens (ppr sty expr), ppr sty info, ppRbrack]
-
-pprExpr sty (CCall fun args _ is_asm result_ty)
-  = ppHang (if is_asm
-	    then ppBesides [ppStr "_casm_ ``", ppPStr fun, ppStr "''"]
-	    else ppBeside  (ppPStr SLIT("_ccall_ ")) (ppPStr fun))
-	 4 (ppSep (map (pprParendExpr sty) args))
-
-pprExpr sty (HsSCC label expr)
-  = ppSep [ ppBeside (ppPStr SLIT("_scc_ ")) (ppBesides [ppChar '"', ppPStr label, ppChar '"']),
-	    pprParendExpr sty expr ]
-
-pprExpr sty (TyLam tyvars expr)
-  = ppHang (ppCat [ppStr "/\\", interppSP sty tyvars, ppStr "->"])
-	 4 (pprExpr sty expr)
-
-pprExpr sty (TyApp expr [ty])
-  = ppHang (pprExpr sty expr) 4 (pprParendGenType sty ty)
-
-pprExpr sty (TyApp expr tys)
-  = ppHang (pprExpr sty expr)
-	 4 (ppBracket (interpp'SP sty tys))
-
-pprExpr sty (DictLam dictvars expr)
-  = ppHang (ppCat [ppStr "\\{-dict-}", interppSP sty dictvars, ppStr "->"])
-	 4 (pprExpr sty expr)
-
-pprExpr sty (DictApp expr [dname])
-  = ppHang (pprExpr sty expr) 4 (ppr sty dname)
-
-pprExpr sty (DictApp expr dnames)
-  = ppHang (pprExpr sty expr)
-	 4 (ppBracket (interpp'SP sty dnames))
-
-pprExpr sty (ClassDictLam dicts methods expr)
-  = ppHang (ppCat [ppStr "\\{-classdict-}",
-		   ppBracket (interppSP sty dicts),
-		   ppBracket (interppSP sty methods),
-		   ppStr "->"])
-	 4 (pprExpr sty expr)
-
-pprExpr sty (Dictionary dicts methods)
-  = ppSep [ppBesides [ppLparen, ppPStr SLIT("{-dict-}")],
-	   ppBracket (interpp'SP sty dicts),
-	   ppBesides [ppBracket (interpp'SP sty methods), ppRparen]]
-
-pprExpr sty (SingleDict dname)
-  = ppCat [ppPStr SLIT("{-singleDict-}"), ppr sty dname]
+ppr_expr (HsLet binds expr@(HsLet _ _))
+  = sep [hang (ptext SLIT("let")) 2 (hsep [pprBinds binds, ptext SLIT("in")]),
+	 pprExpr expr]
+
+ppr_expr (HsLet binds expr)
+  = sep [hang (ptext SLIT("let")) 2 (pprBinds binds),
+	 hang (ptext SLIT("in"))  2 (ppr expr)]
+
+ppr_expr (HsDo do_or_list_comp stmts _)            = pprDo do_or_list_comp stmts
+ppr_expr (HsDoOut do_or_list_comp stmts _ _ _ _ _) = pprDo do_or_list_comp stmts
+
+ppr_expr (ExplicitList exprs)
+  = brackets (fsep (punctuate comma (map ppr_expr exprs)))
+ppr_expr (ExplicitListOut ty exprs)
+  = hcat [ brackets (fsep (punctuate comma (map ppr_expr exprs))),
+	   ifNotPprForUser ((<>) space (parens (pprType ty))) ]
+
+ppr_expr (ExplicitTuple exprs True)
+  = parens (sep (punctuate comma (map ppr_expr exprs)))
+
+ppr_expr (ExplicitTuple exprs False)
+  = ptext SLIT("(#") <> sep (punctuate comma (map ppr_expr exprs)) <> ptext SLIT("#)")
+
+ppr_expr (HsCon con_id tys args)
+  = ppr con_id <+> sep (map pprParendType tys ++
+		        map pprParendExpr args)
+
+ppr_expr (RecordCon con_id rbinds)
+  = pp_rbinds (ppr con_id) rbinds
+ppr_expr (RecordConOut data_con con rbinds)
+  = pp_rbinds (ppr con) rbinds
+
+ppr_expr (RecordUpd aexp rbinds)
+  = pp_rbinds (pprParendExpr aexp) rbinds
+ppr_expr (RecordUpdOut aexp _ _ rbinds)
+  = pp_rbinds (pprParendExpr aexp) rbinds
+
+ppr_expr (ExprWithTySig expr sig)
+  = hang (nest 2 (ppr_expr expr) <+> ptext SLIT("::"))
+	 4 (ppr sig)
+
+ppr_expr (ArithSeqIn info)
+  = brackets (ppr info)
+ppr_expr (ArithSeqOut expr info)
+  = brackets (ppr info)
+
+ppr_expr (CCall fun args _ is_asm result_ty)
+  = hang (if is_asm
+	  then ptext SLIT("_casm_ ``") <> ptext fun <> ptext SLIT("''")
+	  else ptext SLIT("_ccall_") <+> ptext fun)
+       4 (sep (map pprParendExpr args))
+
+ppr_expr (HsSCC label expr)
+  = sep [ ptext SLIT("_scc_") <+> doubleQuotes (ptext label), pprParendExpr expr ]
+
+ppr_expr (TyLam tyvars expr)
+  = hang (hsep [ptext SLIT("/\\"), interppSP tyvars, ptext SLIT("->")])
+	 4 (ppr_expr expr)
+
+ppr_expr (TyApp expr [ty])
+  = hang (ppr_expr expr) 4 (pprParendType ty)
+
+ppr_expr (TyApp expr tys)
+  = hang (ppr_expr expr)
+	 4 (brackets (interpp'SP tys))
+
+ppr_expr (DictLam dictvars expr)
+  = hang (hsep [ptext SLIT("\\{-dict-}"), interppSP dictvars, ptext SLIT("->")])
+	 4 (ppr_expr expr)
+
+ppr_expr (DictApp expr [dname])
+  = hang (ppr_expr expr) 4 (ppr dname)
+
+ppr_expr (DictApp expr dnames)
+  = hang (ppr_expr expr)
+	 4 (brackets (interpp'SP dnames))
 
 \end{code}
 
 Parenthesize unless very simple:
 \begin{code}
-pprParendExpr :: (NamedThing id, Outputable id, Outputable pat,
-		  Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
-	      => PprStyle -> HsExpr tyvar uvar id pat -> Pretty
+pprParendExpr :: (NamedThing id, Outputable id, Outputable pat)
+	      => HsExpr flexi id pat -> SDoc
 
-pprParendExpr sty expr
+pprParendExpr expr
   = let
-	pp_as_was = pprExpr sty expr
+	pp_as_was = pprExpr expr
     in
     case expr of
-      HsLit l		    -> ppr sty l
-      HsLitOut l _	    -> ppr sty l
+      HsLit l		    -> ppr l
+      HsLitOut l _	    -> ppr l
 
       HsVar _		    -> pp_as_was
       ExplicitList _	    -> pp_as_was
       ExplicitListOut _ _   -> pp_as_was
-      ExplicitTuple _	    -> pp_as_was
+      ExplicitTuple _ _	    -> pp_as_was
       HsPar _		    -> pp_as_was
 
-      _			    -> ppParens pp_as_was
+      _			    -> parens pp_as_was
 \end{code}
 
 %************************************************************************
@@ -392,53 +375,80 @@ pprParendExpr sty expr
 %************************************************************************
 
 \begin{code}
-pp_rbinds :: (NamedThing id, Outputable id, Outputable pat,
-		  Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
-	      => PprStyle -> Pretty 
-	      -> HsRecordBinds tyvar uvar id pat -> Pretty
-
-pp_rbinds sty thing rbinds
-  = ppHang thing 
-	 4 (ppCurlies (ppIntersperse pp'SP (map (pp_rbind sty) rbinds)))
+pp_rbinds :: (NamedThing id, Outputable id, Outputable pat)
+	      => SDoc 
+	      -> HsRecordBinds flexi id pat -> SDoc
+
+pp_rbinds thing rbinds
+  = hang thing 
+	 4 (braces (hsep (punctuate comma (map (pp_rbind) rbinds))))
   where
-    pp_rbind PprForUser (v, _, True) = ppr PprForUser v
-    pp_rbind sty        (v, e, _)    = ppCat [ppr sty v, ppStr "=", ppr sty e]
+    pp_rbind (v, e, pun_flag) 
+      = getPprStyle $ \ sty ->
+        if pun_flag && userStyle sty then
+	   ppr v
+	else
+	   hsep [ppr v, char '=', ppr e]
 \end{code}
 
 %************************************************************************
 %*									*
-\subsection{Do stmts}
+\subsection{Do stmts and list comprehensions}
 %*									*
 %************************************************************************
 
 \begin{code}
-data Stmt tyvar uvar id pat
+data StmtCtxt	-- Context of a Stmt
+  = DoStmt		-- Do Statment
+  | ListComp		-- List comprehension
+  | CaseAlt		-- Guard on a case alternative
+  | PatBindRhs		-- Guard on a pattern binding
+  | FunRhs Name		-- Guard on a function defn for f
+  | LambdaBody		-- Body of a lambda abstraction
+		
+pprDo DoStmt stmts
+  = hang (ptext SLIT("do")) 2 (vcat (map ppr stmts))
+pprDo ListComp stmts
+  = brackets $
+    hang (pprExpr expr <+> char '|')
+       4 (interpp'SP quals)
+  where
+    ReturnStmt expr = last stmts	-- Last stmt should be a ReturnStmt for list comps
+    quals	    = init stmts
+\end{code}
+
+\begin{code}
+data Stmt flexi id pat
   = BindStmt	pat
-		(HsExpr  tyvar uvar id pat)
+		(HsExpr  flexi id pat)
 		SrcLoc
-  | ExprStmt	(HsExpr  tyvar uvar id pat)
+
+  | LetStmt	(HsBinds flexi id pat)
+
+  | GuardStmt	(HsExpr  flexi id pat)		-- List comps only
+		SrcLoc
+
+  | ExprStmt	(HsExpr  flexi id pat)		-- Do stmts; and guarded things at the end
 		SrcLoc
-  | LetStmt	(HsBinds tyvar uvar id pat)
- 
-	-- Translations; the types are the "a" and "b" types of the monad.
-  | BindStmtOut	pat (HsExpr tyvar uvar id pat) SrcLoc (GenType tyvar uvar) (GenType tyvar uvar)
-  | ExprStmtOut	(HsExpr tyvar uvar id pat)     SrcLoc (GenType tyvar uvar) (GenType tyvar uvar)
+
+  | ReturnStmt	(HsExpr  flexi id pat)		-- List comps only, at the end
 \end{code}
 
 \begin{code}
-instance (NamedThing id, Outputable id, Outputable pat,
-	  Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
-		Outputable (Stmt tyvar uvar id pat) where
-    ppr sty (BindStmt pat expr _)
-     = ppCat [ppr sty pat, ppStr "<-", ppr sty expr]
-    ppr sty (LetStmt binds)
-     = ppCat [ppPStr SLIT("let"), ppr sty binds]
-    ppr sty (ExprStmt expr _)
-     = ppr sty expr
-    ppr sty (BindStmtOut pat expr _ _ _)
-     = ppCat [ppr sty pat, ppStr "<-", ppr sty expr]
-    ppr sty (ExprStmtOut expr _ _ _)
-     = ppr sty expr
+instance (NamedThing id, Outputable id, Outputable pat) =>
+		Outputable (Stmt flexi id pat) where
+    ppr stmt = pprStmt stmt
+
+pprStmt (BindStmt pat expr _)
+ = hsep [ppr pat, ptext SLIT("<-"), ppr expr]
+pprStmt (LetStmt binds)
+ = hsep [ptext SLIT("let"), pprBinds binds]
+pprStmt (ExprStmt expr _)
+ = ppr expr
+pprStmt (GuardStmt expr _)
+ = ppr expr
+pprStmt (ReturnStmt expr)
+ = hsep [ptext SLIT("return"), ppr expr]    
 \end{code}
 
 %************************************************************************
@@ -448,47 +458,25 @@ instance (NamedThing id, Outputable id, Outputable pat,
 %************************************************************************
 
 \begin{code}
-data ArithSeqInfo  tyvar uvar id pat
-  = From	    (HsExpr tyvar uvar id pat)
-  | FromThen 	    (HsExpr tyvar uvar id pat)
-		    (HsExpr tyvar uvar id pat)
-  | FromTo	    (HsExpr tyvar uvar id pat)
-		    (HsExpr tyvar uvar id pat)
-  | FromThenTo	    (HsExpr tyvar uvar id pat)
-		    (HsExpr tyvar uvar id pat)
-		    (HsExpr tyvar uvar id pat)
-\end{code}
-
-\begin{code}
-instance (NamedThing id, Outputable id, Outputable pat,
-	  Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
-		Outputable (ArithSeqInfo tyvar uvar id pat) where
-    ppr sty (From e1)		= ppBesides [ppr sty e1, pp_dotdot]
-    ppr sty (FromThen e1 e2)	= ppBesides [ppr sty e1, pp'SP, ppr sty e2, pp_dotdot]
-    ppr sty (FromTo e1 e3)	= ppBesides [ppr sty e1, pp_dotdot, ppr sty e3]
-    ppr sty (FromThenTo e1 e2 e3)
-      = ppBesides [ppr sty e1, pp'SP, ppr sty e2, pp_dotdot, ppr sty e3]
-
-pp_dotdot = ppPStr SLIT(" .. ")
-\end{code}
-
-``Qualifiers'' in list comprehensions:
-\begin{code}
-data Qualifier tyvar uvar id pat
-  = GeneratorQual   pat
-		    (HsExpr  tyvar uvar id pat)
-  | LetQual	    (HsBinds tyvar uvar id pat)
-  | FilterQual	    (HsExpr  tyvar uvar id pat)
+data ArithSeqInfo  flexi id pat
+  = From	    (HsExpr flexi id pat)
+  | FromThen 	    (HsExpr flexi id pat)
+		    (HsExpr flexi id pat)
+  | FromTo	    (HsExpr flexi id pat)
+		    (HsExpr flexi id pat)
+  | FromThenTo	    (HsExpr flexi id pat)
+		    (HsExpr flexi id pat)
+		    (HsExpr flexi id pat)
 \end{code}
 
 \begin{code}
-instance (NamedThing id, Outputable id, Outputable pat,
-	  Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
-		Outputable (Qualifier tyvar uvar id pat) where
-    ppr sty (GeneratorQual pat expr)
-     = ppCat [ppr sty pat, ppStr "<-", ppr sty expr]
-    ppr sty (LetQual binds)
-     = ppCat [ppPStr SLIT("let"), ppr sty binds]
-    ppr sty (FilterQual expr)
-     = ppr sty expr
+instance (NamedThing id, Outputable id, Outputable pat) =>
+		Outputable (ArithSeqInfo flexi id pat) where
+    ppr (From e1)		= hcat [ppr e1, pp_dotdot]
+    ppr (FromThen e1 e2)	= hcat [ppr e1, comma, space, ppr e2, pp_dotdot]
+    ppr (FromTo e1 e3)	= hcat [ppr e1, pp_dotdot, ppr e3]
+    ppr (FromThenTo e1 e2 e3)
+      = hcat [ppr e1, comma, space, ppr e2, pp_dotdot, ppr e3]
+
+pp_dotdot = ptext SLIT(" .. ")
 \end{code}