From: simonpj <unknown>
Date: Mon, 11 Jun 2001 12:24:53 +0000 (+0000)
Subject: [project @ 2001-06-11 12:24:51 by simonpj]
X-Git-Tag: Approximately_9120_patches~1780
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=2c6d73e2ca9a545c4295c6f532cd3612e7fd3d8d;p=ghc-hetmet.git

[project @ 2001-06-11 12:24:51 by simonpj]
--------------------------------------
	Tidy up and improve "pattern contexts"
	--------------------------------------

In various places (renamer, typechecker, desugarer) we need to know
what the context of a pattern match is (case expression, function defn,
let binding, etc).  This commit tidies up the story quite a bit.  I
think it represents a net decrease in code, and certainly it improves the
error messages from:

	f x x = 3

Prevsiously we got a message like "Conflicting bindings for x in a pattern match",
but not it says "..in a defn of function f".

WARNING: the tidy up had a more global effect than I originally expected,
so it's possible that some other error messages look a bit peculiar.  They
should be easy to fix, but tell us!
---

diff --git a/ghc/compiler/NOTES b/ghc/compiler/NOTES
index 67b4c62..14725dd 100644
--- a/ghc/compiler/NOTES
+++ b/ghc/compiler/NOTES
@@ -54,3 +54,57 @@ completeLazyBind: 	[given a simplified RHS]
 
   - add unfolding [this is the only place we add an unfolding]
     add arity
+
+
+
+Right hand sides and arguments
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In many ways we want to treat 
+	(a) the right hand side of a let(rec), and 
+	(b) a function argument
+in the same way.  But not always!  In particular, we would
+like to leave these arguments exactly as they are, so they
+will match a RULE more easily.
+	
+	f (g x, h x)	
+	g (+ x)
+
+It's harder to make the rule match if we ANF-ise the constructor,
+or eta-expand the PAP:
+
+	f (let { a = g x; b = h x } in (a,b))
+	g (\y. + x y)
+
+On the other hand if we see the let-defns
+
+	p = (g x, h x)
+	q = + x
+
+then we *do* want to ANF-ise and eta-expand, so that p and q
+can be safely inlined.   
+
+Even floating lets out is a bit dubious.  For let RHS's we float lets
+out if that exposes a value, so that the value can be inlined more vigorously.
+For example
+
+	r = let x = e in (x,x)
+
+Here, if we float the let out we'll expose a nice constructor. We did experiments
+that showed this to be a generally good thing.  But it was a bad thing to float
+lets out unconditionally, because that meant they got allocated more often.
+
+For function arguments, there's less reason to expose a constructor (it won't
+get inlined).  Just possibly it might make a rule match, but I'm pretty skeptical.
+So for the moment we don't float lets out of function arguments either.
+
+
+Eta expansion
+~~~~~~~~~~~~~~
+For eta expansion, we want to catch things like
+
+	case e of (a,b) -> \x -> case a of (p,q) -> \y -> r
+
+If the \x was on the RHS of a let, we'd eta expand to bring the two
+lambdas together.  And in general that's a good thing to do.  Perhaps
+we should eta expand wherever we find a (value) lambda?  Then the eta
+expansion at a let RHS can concentrate solely on the PAP case.
diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs
index cc9c363..f045619 100644
--- a/ghc/compiler/deSugar/DsBinds.lhs
+++ b/ghc/compiler/deSugar/DsBinds.lhs
@@ -78,11 +78,9 @@ dsMonoBinds _ (VarMonoBind var expr) rest
 
 dsMonoBinds auto_scc (FunMonoBind fun _ matches locn) rest
   = putSrcLocDs locn	$
-    matchWrapper (FunRhs (idName fun)) matches error_string	`thenDs` \ (args, body) ->
-    addAutoScc auto_scc (fun, mkLams args body)			`thenDs` \ pair ->
+    matchWrapper (FunRhs fun) matches 			`thenDs` \ (args, body) ->
+    addAutoScc auto_scc (fun, mkLams args body)		`thenDs` \ pair ->
     returnDs (pair : rest)
-  where
-    error_string = "function " ++ showSDoc (ppr fun)
 
 dsMonoBinds auto_scc (PatMonoBind pat grhss locn) rest
   = putSrcLocDs locn $
diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs
index a7f8267..c435500 100644
--- a/ghc/compiler/deSugar/DsExpr.lhs
+++ b/ghc/compiler/deSugar/DsExpr.lhs
@@ -11,11 +11,12 @@ module DsExpr ( dsExpr, dsLet ) where
 
 import HsSyn		( failureFreePat,
 			  HsExpr(..), OutPat(..), HsLit(..), ArithSeqInfo(..),
-			  Stmt(..), HsMatchContext(..), Match(..), HsBinds(..), MonoBinds(..), 
+			  Stmt(..), HsMatchContext(..), HsDoContext(..), 
+			  Match(..), HsBinds(..), MonoBinds(..), 
 			  mkSimpleMatch, isDoExpr
 			)
 import TcHsSyn		( TypecheckedHsExpr, TypecheckedHsBinds,
-			  TypecheckedStmt
+			  TypecheckedStmt, TypecheckedMatchContext
 			)
 import CoreSyn
 import CoreUtils	( exprType, mkIfThenElse, bindNonRec )
@@ -122,14 +123,13 @@ dsExpr (HsLit lit)       = dsLit lit
 -- HsOverLit has been gotten rid of by the type checker
 
 dsExpr expr@(HsLam a_Match)
-  = matchWrapper LambdaExpr [a_Match] "lambda"	`thenDs` \ (binders, matching_code) ->
+  = matchWrapper LambdaExpr [a_Match]	`thenDs` \ (binders, matching_code) ->
     returnDs (mkLams binders matching_code)
 
 dsExpr expr@(HsApp fun arg)      
   = dsExpr fun		`thenDs` \ core_fun ->
     dsExpr arg		`thenDs` \ core_arg ->
     returnDs (core_fun `App` core_arg)
-
 \end{code}
 
 Operator sections.  At first it looks as if we can convert
@@ -204,7 +204,7 @@ dsExpr (HsCase discrim matches src_loc)
  | all ubx_tuple_match matches
  =  putSrcLocDs src_loc $
     dsExpr discrim			`thenDs` \ core_discrim ->
-    matchWrapper CaseAlt matches "case"	`thenDs` \ ([discrim_var], matching_code) ->
+    matchWrapper CaseAlt matches 	`thenDs` \ ([discrim_var], matching_code) ->
     case matching_code of
 	Case (Var x) bndr alts | x == discrim_var -> 
 		returnDs (Case core_discrim bndr alts)
@@ -216,7 +216,7 @@ dsExpr (HsCase discrim matches src_loc)
 dsExpr (HsCase discrim matches src_loc)
   = putSrcLocDs src_loc $
     dsExpr discrim			`thenDs` \ core_discrim ->
-    matchWrapper CaseAlt matches "case"	`thenDs` \ ([discrim_var], matching_code) ->
+    matchWrapper CaseAlt matches	`thenDs` \ ([discrim_var], matching_code) ->
     returnDs (bindNonRec discrim_var core_discrim matching_code)
 
 dsExpr (HsLet binds body)
@@ -430,8 +430,8 @@ dsExpr (RecordUpdOut record_expr record_out_ty dicts rbinds)
 	-- and the right hand sides with applications of the wrapper Id
 	-- so that everything works when we are doing fancy unboxing on the
 	-- constructor aguments.
-    mapDs mk_alt cons_to_upd			`thenDs` \ alts ->
-    matchWrapper RecUpd alts "record update"	`thenDs` \ ([discrim_var], matching_code) ->
+    mapDs mk_alt cons_to_upd		`thenDs` \ alts ->
+    matchWrapper RecUpd alts		`thenDs` \ ([discrim_var], matching_code) ->
 
     returnDs (bindNonRec discrim_var record_expr' matching_code)
 
@@ -490,7 +490,7 @@ dsExpr (ArithSeqIn _)	    = panic "dsExpr:ArithSeqIn"
 Basically does the translation given in the Haskell~1.3 report:
 
 \begin{code}
-dsDo	:: HsMatchContext
+dsDo	:: HsDoContext
 	-> [TypecheckedStmt]
 	-> Id		-- id for: return m
 	-> Id		-- id for: (>>=) m
@@ -501,6 +501,9 @@ dsDo	:: HsMatchContext
 dsDo do_or_lc stmts return_id then_id fail_id result_ty
   = let
 	(_, b_ty) = splitAppTy result_ty	-- result_ty must be of the form (m b)
+	is_do	  = case do_or_lc of
+			DoExpr   -> True
+			ListComp -> False
 	
 	-- For ExprStmt, see the comments near HsExpr.HsStmt about 
 	-- exactly what ExprStmts mean!
@@ -508,12 +511,12 @@ dsDo do_or_lc stmts return_id then_id fail_id result_ty
 	-- In dsDo we can only see DoStmt and ListComp (no gaurds)
 
 	go [ResultStmt expr locn]
-	  | isDoExpr do_or_lc = do_expr expr locn
-	  | otherwise	      = do_expr expr locn	`thenDs` \ expr2 ->
-				returnDs (mkApps (Var return_id) [Type b_ty, expr2])
+	  | is_do     = do_expr expr locn
+	  | otherwise = do_expr expr locn	`thenDs` \ expr2 ->
+			returnDs (mkApps (Var return_id) [Type b_ty, expr2])
 
 	go (ExprStmt expr locn : stmts)
-	   | isDoExpr do_or_lc
+	  | is_do	-- Do expression
 	  = do_expr expr locn		`thenDs` \ expr2 ->
 	    go stmts     		`thenDs` \ rest  ->
 	    let
@@ -556,8 +559,7 @@ dsDo do_or_lc stmts return_id then_id fail_id result_ty
 		      , mkSimpleMatch [WildPat a_ty] fail_expr (Just result_ty) locn
 		      ]
 	    in
-	    matchWrapper DoExpr the_matches match_msg
-				`thenDs` \ (binders, matching_code) ->
+	    matchWrapper (DoCtxt do_or_lc) the_matches	`thenDs` \ (binders, matching_code) ->
 	    returnDs (mkApps (Var then_id) [Type a_ty, Type b_ty, expr2,
 				            mkLams binders matching_code])
     in
@@ -565,10 +567,6 @@ dsDo do_or_lc stmts return_id then_id fail_id result_ty
 
   where
     do_expr expr locn = putSrcLocDs locn (dsExpr expr)
-
-    match_msg = case do_or_lc of
-			DoExpr   -> "`do' statement"
-			ListComp -> "comprehension"
 \end{code}
 
 
diff --git a/ghc/compiler/deSugar/DsGRHSs.lhs b/ghc/compiler/deSugar/DsGRHSs.lhs
index ab236f9..57ef74f 100644
--- a/ghc/compiler/deSugar/DsGRHSs.lhs
+++ b/ghc/compiler/deSugar/DsGRHSs.lhs
@@ -12,7 +12,7 @@ import {-# SOURCE #-} DsExpr  ( dsExpr, dsLet )
 import {-# SOURCE #-} Match   ( matchSinglePat )
 
 import HsSyn		( Stmt(..), HsExpr(..), GRHSs(..), GRHS(..), HsMatchContext(..) )
-import TcHsSyn		( TypecheckedGRHSs, TypecheckedPat, TypecheckedStmt )
+import TcHsSyn		( TypecheckedGRHSs, TypecheckedPat, TypecheckedStmt, TypecheckedMatchContext )
 import CoreSyn		( CoreExpr )
 import Type		( Type )
 
@@ -45,8 +45,8 @@ dsGuarded grhss
 In contrast, @dsGRHSs@ produces a @MatchResult@.
 
 \begin{code}
-dsGRHSs :: HsMatchContext -> [TypecheckedPat]	-- These are to build a MatchContext from
-	-> TypecheckedGRHSs			-- Guarded RHSs
+dsGRHSs :: TypecheckedMatchContext -> [TypecheckedPat]	-- These are to build a MatchContext from
+	-> TypecheckedGRHSs				-- Guarded RHSs
 	-> DsM (Type, MatchResult)
 
 dsGRHSs kind pats (GRHSs grhss binds (Just ty))
diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs
index ef622eb..929dd3e 100644
--- a/ghc/compiler/deSugar/DsListComp.lhs
+++ b/ghc/compiler/deSugar/DsListComp.lhs
@@ -11,7 +11,7 @@ module DsListComp ( dsListComp ) where
 import {-# SOURCE #-} DsExpr ( dsExpr, dsLet )
 
 import BasicTypes	( Boxity(..) )
-import HsSyn		( OutPat(..), HsExpr(..), Stmt(..), HsMatchContext(..) )
+import HsSyn		( OutPat(..), HsExpr(..), Stmt(..), HsMatchContext(..), HsDoContext(..) )
 import TcHsSyn		( TypecheckedStmt, TypecheckedPat, TypecheckedHsExpr )
 import DsHsSyn		( outPatType )
 import CoreSyn
@@ -193,7 +193,7 @@ deBindComp pat core_list1 quals core_list2
 	letrec_body = App (Var h) core_list1
     in
     deListComp quals core_fail			`thenDs` \ rest_expr ->
-    matchSimply (Var u2) ListComp pat
+    matchSimply (Var u2) (DoCtxt ListComp) pat
 		rest_expr core_fail		`thenDs` \ core_match ->
     let
 	rhs = Lam u1 $
@@ -306,7 +306,8 @@ dfListComp c_id n_id (BindStmt pat list1 locn : quals)
     dfListComp c_id b quals			`thenDs` \ core_rest ->
 
     -- build the pattern match
-    matchSimply (Var x) ListComp pat core_rest (Var b)	`thenDs` \ core_expr ->
+    matchSimply (Var x) (DoCtxt ListComp) 
+		pat core_rest (Var b)		`thenDs` \ core_expr ->
 
     -- now build the outermost foldr, and return
     dsLookupGlobalValue foldrName		`thenDs` \ foldr_id ->
diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs
index 3c783ed..6fc4aa7 100644
--- a/ghc/compiler/deSugar/DsMonad.lhs
+++ b/ghc/compiler/deSugar/DsMonad.lhs
@@ -25,7 +25,7 @@ module DsMonad (
 
 #include "HsVersions.h"
 
-import HsSyn		( HsMatchContext )
+import TcHsSyn		( TypecheckedPat, TypecheckedMatchContext )
 import Bag		( emptyBag, snocBag, Bag )
 import ErrUtils 	( WarnMsg )
 import Id		( mkSysLocal, setIdUnique, Id )
@@ -33,7 +33,6 @@ import Module		( Module )
 import Var		( TyVar, setTyVarUnique )
 import Outputable
 import SrcLoc		( noSrcLoc, SrcLoc )
-import TcHsSyn		( TypecheckedPat )
 import Type             ( Type )
 import UniqSupply	( initUs_, splitUniqSupply, uniqFromSupply, uniqsFromSupply,
 			  UniqSM, UniqSupply )
@@ -218,7 +217,7 @@ dsLookupGlobalValue name dflags us genv loc mod warns
 
 \begin{code}
 data DsMatchContext
-  = DsMatchContext HsMatchContext [TypecheckedPat] SrcLoc
+  = DsMatchContext TypecheckedMatchContext [TypecheckedPat] SrcLoc
   | NoMatchContext
   deriving ()
 \end{code}
diff --git a/ghc/compiler/deSugar/Match.hi-boot b/ghc/compiler/deSugar/Match.hi-boot
index 2db27a8..f069e91 100644
--- a/ghc/compiler/deSugar/Match.hi-boot
+++ b/ghc/compiler/deSugar/Match.hi-boot
@@ -4,6 +4,6 @@ Match match matchExport matchSimply matchSinglePat;
 _declarations_
 1 match _:_ [Var.Id] -> [DsUtils.EquationInfo] -> DsMonad.DsM DsUtils.MatchResult ;;
 1 matchExport _:_ [Var.Id] -> [DsUtils.EquationInfo] -> DsMonad.DsM DsUtils.MatchResult ;;
-1 matchSimply _:_ CoreSyn.CoreExpr -> HsExpr.HsMatchContext -> TcHsSyn.TypecheckedPat -> CoreSyn.CoreExpr -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr ;;
+1 matchSimply _:_ CoreSyn.CoreExpr -> HsExpr.HsMatchContext Var.Id -> TcHsSyn.TypecheckedPat -> CoreSyn.CoreExpr -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr ;;
 1 matchSinglePat _:_ CoreSyn.CoreExpr -> DsMonad.DsMatchContext -> TcHsSyn.TypecheckedPat -> DsUtils.MatchResult -> DsMonad.DsM DsUtils.MatchResult ;;
 
diff --git a/ghc/compiler/deSugar/Match.hi-boot-5 b/ghc/compiler/deSugar/Match.hi-boot-5
index a0727f4..2e4d223 100644
--- a/ghc/compiler/deSugar/Match.hi-boot-5
+++ b/ghc/compiler/deSugar/Match.hi-boot-5
@@ -2,5 +2,5 @@ __interface Match 1 0 where
 __export Match match matchExport matchSimply matchSinglePat;
 1 match :: [Var.Id] -> [DsUtils.EquationInfo] -> DsMonad.DsM DsUtils.MatchResult ;
 1 matchExport :: [Var.Id] -> [DsUtils.EquationInfo] -> DsMonad.DsM DsUtils.MatchResult ;
-1 matchSimply :: CoreSyn.CoreExpr -> HsExpr.HsMatchContext -> TcHsSyn.TypecheckedPat -> CoreSyn.CoreExpr -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr ;
+1 matchSimply :: CoreSyn.CoreExpr -> HsExpr.HsMatchContext Var.Id -> TcHsSyn.TypecheckedPat -> CoreSyn.CoreExpr -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr ;
 1 matchSinglePat :: CoreSyn.CoreExpr -> DsMonad.DsMatchContext -> TcHsSyn.TypecheckedPat -> DsUtils.MatchResult -> DsMonad.DsM DsUtils.MatchResult ;
diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs
index 0ca118b..92dae22 100644
--- a/ghc/compiler/deSugar/Match.lhs
+++ b/ghc/compiler/deSugar/Match.lhs
@@ -10,7 +10,7 @@ module Match ( match, matchExport, matchWrapper, matchSimply, matchSinglePat ) w
 
 import CmdLineOpts	( DynFlag(..), dopt )
 import HsSyn		
-import TcHsSyn		( TypecheckedPat, TypecheckedMatch )
+import TcHsSyn		( TypecheckedPat, TypecheckedMatch, TypecheckedMatchContext )
 import DsHsSyn		( outPatType )
 import Check            ( check, ExhaustivePat )
 import CoreSyn
@@ -622,9 +622,8 @@ Call @match@ with all of this information!
 \end{enumerate}
 
 \begin{code}
-matchWrapper :: HsMatchContext		-- For shadowing warning messages
+matchWrapper :: TypecheckedMatchContext	-- For shadowing warning messages
 	     -> [TypecheckedMatch]	-- Matches being desugared
-	     -> String 			-- Error message if the match fails
 	     -> DsM ([Id], CoreExpr) 	-- Results
 \end{code}
 
@@ -651,11 +650,12 @@ one pattern, and match simply only accepts one pattern.
 JJQC 30-Nov-1997
 
 \begin{code}
-matchWrapper kind matches error_string
+matchWrapper ctxt matches
   = getDOptsDs					`thenDs` \ dflags ->
-    flattenMatches kind matches			`thenDs` \ (result_ty, eqns_info) ->
+    flattenMatches ctxt matches			`thenDs` \ (result_ty, eqns_info) ->
     let
 	EqnInfo _ _ arg_pats _ : _ = eqns_info
+	error_string = matchContextErrString ctxt
     in
     mapDs selectMatchVar arg_pats		`thenDs` \ new_vars ->
     match_fun dflags new_vars eqns_info 	`thenDs` \ match_result ->
@@ -664,7 +664,7 @@ matchWrapper kind matches error_string
     extractMatchResult match_result fail_expr		`thenDs` \ result_expr ->
     returnDs (new_vars, result_expr)
   where match_fun dflags
-           = case kind of 
+           = case ctxt of 
                 LambdaExpr | dopt Opt_WarnSimplePatterns dflags -> matchExport 
                            | otherwise                          -> match
                 _                                               -> matchExport
@@ -681,11 +681,11 @@ situation where we want to match a single expression against a single
 pattern. It returns an expression.
 
 \begin{code}
-matchSimply :: CoreExpr		-- Scrutinee
-	    -> HsMatchContext	-- Match kind
-	    -> TypecheckedPat	-- Pattern it should match
-	    -> CoreExpr		-- Return this if it matches
-	    -> CoreExpr		-- Return this if it doesn't
+matchSimply :: CoreExpr			-- Scrutinee
+	    -> TypecheckedMatchContext	-- Match kind
+	    -> TypecheckedPat		-- Pattern it should match
+	    -> CoreExpr			-- Return this if it matches
+	    -> CoreExpr			-- Return this if it doesn't
 	    -> DsM CoreExpr
 
 matchSimply scrut kind pat result_expr fail_expr
@@ -726,7 +726,7 @@ matchSinglePat scrut ctx pat match_result
 This is actually local to @matchWrapper@.
 
 \begin{code}
-flattenMatches :: HsMatchContext
+flattenMatches :: TypecheckedMatchContext
 	       -> [TypecheckedMatch]
 	       -> DsM (Type, [EquationInfo])
 
diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs
index 9576c6d..4050a2e 100644
--- a/ghc/compiler/hsSyn/HsBinds.lhs
+++ b/ghc/compiler/hsSyn/HsBinds.lhs
@@ -10,7 +10,9 @@ module HsBinds where
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-} HsExpr ( pprExpr, HsExpr, pprMatches, Match, pprGRHSs, GRHSs )
+import {-# SOURCE #-} HsExpr ( HsExpr, pprExpr,
+			       Match,  pprFunBind,
+			       GRHSs,  pprPatBind )
 
 -- friends:
 import HsTypes		( HsType )
@@ -199,11 +201,8 @@ ppr_monobind EmptyMonoBinds = empty
 ppr_monobind (AndMonoBinds binds1 binds2)
       = ppr_monobind binds1 $$ ppr_monobind binds2
 
-ppr_monobind (PatMonoBind pat grhss locn)
-      = sep [ppr pat, nest 4 (pprGRHSs False grhss)]
-
-ppr_monobind (FunMonoBind fun inf matches locn)
-      = pprMatches (False, ppr fun) matches
+ppr_monobind (PatMonoBind pat grhss locn)	= pprPatBind pat grhss
+ppr_monobind (FunMonoBind fun inf matches locn) = pprFunBind fun matches
       -- ToDo: print infix if appropriate
 
 ppr_monobind (VarMonoBind name expr)
diff --git a/ghc/compiler/hsSyn/HsExpr.hi-boot b/ghc/compiler/hsSyn/HsExpr.hi-boot
index a631f59..2341419 100644
--- a/ghc/compiler/hsSyn/HsExpr.hi-boot
+++ b/ghc/compiler/hsSyn/HsExpr.hi-boot
@@ -1,12 +1,11 @@
 _interface_ HsExpr 1
 _exports_
-HsExpr HsExpr pprExpr Match GRHSs pprMatch pprMatches pprGRHSs ;
+HsExpr HsExpr pprExpr Match GRHSs pprFunBind pprPatBind ;
 _declarations_
 1 data HsExpr i p;
 1 pprExpr _:_ _forall_ [i p] {Outputable.Outputable i, Outputable.Outputable p} => HsExpr.HsExpr i p -> Outputable.SDoc ;;
 
 1 data Match a b ;
 1 data GRHSs a b ;
-1 pprGRHSs _:_ _forall_ [i p] {Outputable.Outputable i, Outputable.Outputable p} => PrelBase.Bool -> HsExpr.GRHSs i p -> Outputable.SDoc ;;
-1 pprMatch _:_ _forall_ [i p] {Outputable.Outputable i, Outputable.Outputable p} => (PrelBase.Bool, Outputable.SDoc) -> HsExpr.Match i p -> Outputable.SDoc ;;
-1 pprMatches _:_ _forall_ [i p] {Outputable.Outputable i, Outputable.Outputable p} => (PrelBase.Bool, Outputable.SDoc) -> [HsExpr.Match i p] -> Outputable.SDoc ;;
+1 pprPatBind _:_ _forall_ [i p] {Outputable.Outputable i, Outputable.Outputable p} => p -> HsExpr.GRHSs i p -> Outputable.SDoc ;;
+1 pprFunBind _:_ _forall_ [i p] {Outputable.Outputable i, Outputable.Outputable p} => i -> [HsExpr.Match i p] -> Outputable.SDoc ;;
diff --git a/ghc/compiler/hsSyn/HsExpr.hi-boot-5 b/ghc/compiler/hsSyn/HsExpr.hi-boot-5
index 5f17708..bf952e3 100644
--- a/ghc/compiler/hsSyn/HsExpr.hi-boot-5
+++ b/ghc/compiler/hsSyn/HsExpr.hi-boot-5
@@ -1,13 +1,12 @@
 __interface HsExpr 1 0 where
-__export HsExpr HsExpr pprExpr Match GRHSs pprMatch pprMatches pprGRHSs ;
+__export HsExpr HsExpr pprExpr Match GRHSs pprPatBind pprFunBind ;
 
 1 data HsExpr i p ;
 1 pprExpr :: __forall [i p] {Outputable.Outputable i, Outputable.Outputable p} => HsExpr.HsExpr i p -> Outputable.SDoc ;
 
-
 1 data Match a b ;
 1 data GRHSs a b ;
-1 pprGRHSs :: __forall [i p] {Outputable.Outputable i, Outputable.Outputable p} => PrelBase.Bool -> HsExpr.GRHSs i p -> Outputable.SDoc ;
-1 pprMatch :: __forall [i p] {Outputable.Outputable i, Outputable.Outputable p} => (PrelBase.Bool, Outputable.SDoc) -> HsExpr.Match i p -> Outputable.SDoc ;
-1 pprMatches :: __forall [i p] {Outputable.Outputable i, Outputable.Outputable p} => (PrelBase.Bool, Outputable.SDoc) -> [HsExpr.Match i p] -> Outputable.SDoc ;
+
+1 pprPatBind :: __forall [i p] {Outputable.Outputable i, Outputable.Outputable p} => p -> HsExpr.GRHSs i p -> Outputable.SDoc ;
+1 pprFunBind :: __forall [i p] {Outputable.Outputable i, Outputable.Outputable p} => i -> [HsExpr.Match i p] -> Outputable.SDoc ;
 
diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs
index 153c7d7..60a1b83 100644
--- a/ghc/compiler/hsSyn/HsExpr.lhs
+++ b/ghc/compiler/hsSyn/HsExpr.lhs
@@ -83,11 +83,11 @@ data HsExpr id pat
   | HsWith	(HsExpr id pat)	-- implicit parameter binding
   		[(id, HsExpr id pat)]
 
-  | HsDo	HsMatchContext
+  | HsDo	HsDoContext
 		[Stmt id pat]	-- "do":one or more stmts
 		SrcLoc
 
-  | HsDoOut	HsMatchContext
+  | HsDoOut	HsDoContext
 		[Stmt id pat]	-- "do":one or more stmts
 		id		-- id for return
 		id		-- id for >>=
@@ -222,7 +222,7 @@ ppr_expr (HsLit lit)     = ppr lit
 ppr_expr (HsOverLit lit) = ppr lit
 
 ppr_expr (HsLam match)
-  = hsep [char '\\', nest 2 (pprMatch (True,empty) match)]
+  = hsep [char '\\', nest 2 (pprMatch LambdaExpr match)]
 
 ppr_expr expr@(HsApp e1 e2)
   = let (fun, args) = collect_args expr [] in
@@ -278,7 +278,7 @@ ppr_expr (SectionR op expr)
 
 ppr_expr (HsCase expr matches _)
   = sep [ sep [ptext SLIT("case"), nest 4 (pprExpr expr), ptext SLIT("of")],
-	    nest 2 (pprMatches (True, empty) matches) ]
+	    nest 2 (pprMatches CaseAlt matches) ]
 
 ppr_expr (HsIf e1 e2 e3 _)
   = sep [hsep [ptext SLIT("if"), nest 2 (pprExpr e1), ptext SLIT("then")],
@@ -479,46 +479,56 @@ We know the list must have at least one @Match@ in it.
 
 \begin{code}
 pprMatches :: (Outputable id, Outputable pat)
-	   => (Bool, SDoc) -> [Match id pat] -> SDoc
-pprMatches print_info matches = vcat (map (pprMatch print_info) matches)
+	   => HsMatchContext id -> [Match id pat] -> SDoc
+pprMatches ctxt matches = vcat (map (pprMatch ctxt) matches)
+
+-- Exported to HsBinds, which can't see the defn of HsMatchContext
+pprFunBind :: (Outputable id, Outputable pat)
+	   => id -> [Match id pat] -> SDoc
+pprFunBind fun matches = pprMatches (FunRhs fun) matches
+
+-- Exported to HsBinds, which can't see the defn of HsMatchContext
+pprPatBind :: (Outputable id, Outputable pat)
+	   => pat -> GRHSs id pat -> SDoc
+pprPatBind pat grhss = sep [ppr pat, nest 4 (pprGRHSs PatBindRhs grhss)]
 
 
 pprMatch :: (Outputable id, Outputable pat)
-	   => (Bool, SDoc) -> Match id pat -> SDoc
-pprMatch print_info@(is_case, name) (Match _ pats maybe_ty grhss)
-  = maybe_name <+> sep [sep (map ppr pats), 
-			ppr_maybe_ty,
-			nest 2 (pprGRHSs is_case grhss)]
+	   => HsMatchContext id -> Match id pat -> SDoc
+pprMatch ctxt (Match _ pats maybe_ty grhss)
+  = pp_name ctxt <+> sep [sep (map ppr pats), 
+		     ppr_maybe_ty,
+		     nest 2 (pprGRHSs ctxt grhss)]
   where
-    maybe_name | is_case   = empty
-	       | otherwise = name
+    pp_name (FunRhs fun) = ppr fun
+    pp_name other	 = empty
     ppr_maybe_ty = case maybe_ty of
 			Just ty -> dcolon <+> ppr ty
 			Nothing -> empty
 
 
 pprGRHSs :: (Outputable id, Outputable pat)
-	 => Bool -> GRHSs id pat -> SDoc
-pprGRHSs is_case (GRHSs grhss binds maybe_ty)
-  = vcat (map (pprGRHS is_case) grhss)
+	 => HsMatchContext id -> GRHSs id pat -> SDoc
+pprGRHSs ctxt (GRHSs grhss binds maybe_ty)
+  = vcat (map (pprGRHS ctxt) grhss)
     $$
     (if nullBinds binds then empty
      else text "where" $$ nest 4 (pprDeeper (ppr binds)))
 
 
 pprGRHS :: (Outputable id, Outputable pat)
-	=> Bool -> GRHS id pat -> SDoc
+	=> HsMatchContext id -> GRHS id pat -> SDoc
 
-pprGRHS is_case (GRHS [ResultStmt expr _] locn)
- =  pp_rhs is_case expr
+pprGRHS ctxt (GRHS [ResultStmt expr _] locn)
+ =  pp_rhs ctxt expr
 
-pprGRHS is_case (GRHS guarded locn)
- = sep [char '|' <+> interpp'SP guards, pp_rhs is_case expr]
+pprGRHS ctxt (GRHS guarded locn)
+ = sep [char '|' <+> interpp'SP guards, pp_rhs ctxt expr]
  where
     ResultStmt expr _ = last guarded	-- Last stmt should be a ResultStmt for guards
     guards	      = init guarded
 
-pp_rhs is_case rhs = text (if is_case then "->" else "=") <+> pprDeeper (ppr rhs)
+pp_rhs ctxt rhs = ptext (matchSeparator ctxt) <+> pprDeeper (ppr rhs)
 \end{code}
 
 
@@ -596,7 +606,7 @@ pprStmt (ParStmt stmtss)
 pprStmt (ParStmtOut stmtss)
  = hsep (map (\stmts -> ptext SLIT("| ") <> ppr stmts) stmtss)
 
-pprDo :: (Outputable id, Outputable pat) => HsMatchContext -> [Stmt id pat] -> SDoc
+pprDo :: (Outputable id, Outputable pat) => HsDoContext -> [Stmt id pat] -> SDoc
 pprDo DoExpr stmts   = hang (ptext SLIT("do")) 2 (vcat (map ppr stmts))
 pprDo ListComp stmts = brackets $
 		       hang (pprExpr expr <+> char '|')
@@ -644,30 +654,21 @@ pp_dotdot = ptext SLIT(" .. ")
 %************************************************************************
 
 \begin{code}
-data HsMatchContext	-- Context of a Match or Stmt
-  = ListComp		-- List comprehension
-  | DoExpr		-- Do Statment
-
-  | FunRhs Name		-- Function binding for f
+data HsMatchContext id	-- Context of a Match or Stmt
+  = DoCtxt HsDoContext	-- Do-stmt or list comprehension
+  | FunRhs id		-- Function binding for f
   | CaseAlt		-- Guard on a case alternative
   | LambdaExpr		-- Lambda
   | PatBindRhs		-- Pattern binding
   | RecUpd		-- Record update
   deriving ()
 
--- It's convenient to have FunRhs as a Name
--- throughout so that HsMatchContext doesn't
--- need to be parameterised.
--- In the RdrName world we never use the FunRhs variant.
+data HsDoContext = ListComp | DoExpr
 \end{code}
 
 \begin{code}
-isDoExpr DoExpr = True
-isDoExpr other  = False
-
-isDoOrListComp ListComp = True
-isDoOrListComp DoExpr   = True
-isDoOrListComp other    = False
+isDoExpr (DoCtxt DoExpr) = True
+isDoExpr other 		 = False
 \end{code}
 
 \begin{code}
@@ -675,17 +676,25 @@ matchSeparator (FunRhs _)   = SLIT("=")
 matchSeparator CaseAlt      = SLIT("->") 
 matchSeparator LambdaExpr   = SLIT("->") 
 matchSeparator PatBindRhs   = SLIT("=") 
-matchSeparator DoExpr       = SLIT("<-")  
-matchSeparator ListComp     = SLIT("<-")  
+matchSeparator (DoCtxt _)   = SLIT("<-")  
 matchSeparator RecUpd       = panic "When is this used?"
 \end{code}
 
 \begin{code}
-pprMatchContext (FunRhs fun) = ptext SLIT("In the definition of") <+> quotes (ppr fun)
-pprMatchContext CaseAlt	     = ptext SLIT("In a group of case alternatives beginning")
-pprMatchContext RecUpd	     = ptext SLIT("In a record-update construct")
-pprMatchContext PatBindRhs   = ptext SLIT("In a pattern binding")
-pprMatchContext LambdaExpr   = ptext SLIT("In a lambda abstraction")
-pprMatchContext DoExpr       = ptext SLIT("In a 'do' expression pattern binding")
-pprMatchContext ListComp     = ptext SLIT("In a 'list comprehension' pattern binding")
+pprMatchContext (FunRhs fun) 	  = ptext SLIT("In the definition of") <+> quotes (ppr fun)
+pprMatchContext CaseAlt	     	  = ptext SLIT("In a case alternative")
+pprMatchContext RecUpd	     	  = ptext SLIT("In a record-update construct")
+pprMatchContext PatBindRhs   	  = ptext SLIT("In a pattern binding")
+pprMatchContext LambdaExpr   	  = ptext SLIT("In a lambda abstraction")
+pprMatchContext (DoCtxt DoExpr)   = ptext SLIT("In a 'do' expression pattern binding")
+pprMatchContext (DoCtxt ListComp) = ptext SLIT("In a 'list comprehension' pattern binding")
+
+-- Used to generate the string for a *runtime* error message
+matchContextErrString (FunRhs fun)    	= "function " ++ showSDoc (ppr fun)
+matchContextErrString CaseAlt	      	= "case"
+matchContextErrString PatBindRhs      	= "pattern binding"
+matchContextErrString RecUpd	      	= "record update"
+matchContextErrString LambdaExpr      	=  "lambda"
+matchContextErrString (DoCtxt DoExpr)   = "'do' expression"
+matchContextErrString (DoCtxt ListComp) = "list comprehension"
 \end{code}
diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs
index 33dacd7..aea97d3 100644
--- a/ghc/compiler/rename/RnBinds.lhs
+++ b/ghc/compiler/rename/RnBinds.lhs
@@ -217,7 +217,7 @@ rnMonoBinds mbinds sigs	thing_inside -- Non-empty monobinds
   =	-- Extract all the binders in this group,
 	-- and extend current scope, inventing new names for the new binders
 	-- This also checks that the names form a set
-    bindLocatedLocalsRn (text "a binding group") 
+    bindLocatedLocalsRn (text "In a binding group") 
 			mbinders_w_srclocs	$ \ new_mbinders ->
     let
 	binder_set = mkNameSet new_mbinders
@@ -327,7 +327,7 @@ flattenMonoBinds sigs (FunMonoBind name inf matches locn)
 	names_bound_here = unitNameSet new_name
     in
     sigsForMe names_bound_here sigs			`thenRn` \ sigs_for_me ->
-    mapFvRn rnMatch matches				`thenRn` \ (new_matches, fvs) ->
+    mapFvRn (rnMatch (FunRhs name)) matches		`thenRn` \ (new_matches, fvs) ->
     mapRn_ (checkPrecMatch inf new_name) new_matches	`thenRn_`
     returnRn
       [(unitNameSet new_name,
@@ -387,12 +387,12 @@ rnMethodBinds gen_tyvars (FunMonoBind name inf matches locn)
 	-- Gruesome; bring into scope the correct members of the generic type variables
 	-- See comments in RnSource.rnSourceDecl(ClassDecl)
     rn_match match@(Match _ (TypePatIn ty : _) _ _)
-	= extendTyVarEnvFVRn gen_tvs (rnMatch match)
+	= extendTyVarEnvFVRn gen_tvs (rnMatch (FunRhs name) match)
 	where
 	  tvs     = map rdrNameOcc (extractHsTyRdrNames ty)
 	  gen_tvs = [tv | tv <- gen_tyvars, nameOccName tv `elem` tvs] 
 
-    rn_match match = rnMatch match
+    rn_match match = rnMatch (FunRhs name) match
 	
 
 -- Can't handle method pattern-bindings which bind multiple methods.
diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs
index 4d04154..e5a185d 100644
--- a/ghc/compiler/rename/RnEnv.lhs
+++ b/ghc/compiler/rename/RnEnv.lhs
@@ -983,7 +983,7 @@ dupNamesErr descriptor ((name,loc) : dup_things)
   = pushSrcLocRn loc $
     addErrRn ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name))
 	      $$ 
-	      (ptext SLIT("in") <+> descriptor))
+	      descriptor)
 
 warnDeprec :: Name -> DeprecTxt -> RnM d ()
 warnDeprec name txt
@@ -992,3 +992,4 @@ warnDeprec name txt
 		     quotes (ppr name) <+> text "is deprecated:", 
 		     nest 4 (ppr txt) ])
 \end{code}
+
diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index 1b28b1a..c89a88b 100644
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -159,9 +159,9 @@ rnPat (TypePatIn name) =
 ************************************************************************
 
 \begin{code}
-rnMatch :: RdrNameMatch -> RnMS (RenamedMatch, FreeVars)
+rnMatch :: HsMatchContext RdrName -> RdrNameMatch -> RnMS (RenamedMatch, FreeVars)
 
-rnMatch match@(Match _ pats maybe_rhs_sig grhss)
+rnMatch ctxt match@(Match _ pats maybe_rhs_sig grhss)
   = pushSrcLocRn (getMatchLoc match)	$
 
 	-- Bind pattern-bound type variables
@@ -170,8 +170,8 @@ rnMatch match@(Match _ pats maybe_rhs_sig grhss)
 				Nothing -> []
 				Just ty -> [ty]
 	pat_sig_tys = collectSigTysFromPats pats
-	doc_sig     = text "a result type-signature"
- 	doc_pat     = text "a pattern match"
+	doc_sig     = text "In a result type-signature"
+ 	doc_pat     = pprMatchContext ctxt
     in
     bindPatSigTyVars (rhs_sig_tys ++ pat_sig_tys)	$ \ sig_tyvars ->
 
@@ -212,7 +212,7 @@ bindPatSigTyVars tys thing_inside
     let
 	tyvars_in_sigs = extractHsTysRdrTyVars tys
 	forall_tyvars  = filter (not . (`elemFM` name_env)) tyvars_in_sigs
-	doc_sig        = text "a pattern type-signature"
+	doc_sig        = text "In a pattern type-signature"
     in
     bindNakedTyVarsFVRn doc_sig forall_tyvars thing_inside
 \end{code}
@@ -306,7 +306,7 @@ rnExpr (HsOverLit lit)
     returnRn (HsOverLit lit', fvs)
 
 rnExpr (HsLam match)
-  = rnMatch match	`thenRn` \ (match', fvMatch) ->
+  = rnMatch LambdaExpr match	`thenRn` \ (match', fvMatch) ->
     returnRn (HsLam match', fvMatch)
 
 rnExpr (HsApp fun arg)
@@ -370,8 +370,8 @@ rnExpr (HsSCC lbl expr)
 
 rnExpr (HsCase expr ms src_loc)
   = pushSrcLocRn src_loc $
-    rnExpr expr		 	`thenRn` \ (new_expr, e_fvs) ->
-    mapFvRn rnMatch ms		`thenRn` \ (new_ms, ms_fvs) ->
+    rnExpr expr		 		`thenRn` \ (new_expr, e_fvs) ->
+    mapFvRn (rnMatch CaseAlt) ms	`thenRn` \ (new_ms, ms_fvs) ->
     returnRn (HsCase new_expr new_ms src_loc, e_fvs `plusFV` ms_fvs)
 
 rnExpr (HsLet binds expr)
@@ -594,7 +594,7 @@ rnStmt (BindStmt pat expr src_loc) thing_inside
     returnRn ((new_binders ++ rest_binders, result),
 	      fv_expr `plusFV` fvs `plusFV` fv_pat)
   where
-    doc = text "a pattern in do binding" 
+    doc = text "In a pattern in 'do' binding" 
 
 rnStmt (ExprStmt expr src_loc) thing_inside
   = pushSrcLocRn src_loc $
diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs
index a1fbfeb..4789d89 100644
--- a/ghc/compiler/rename/RnHsSyn.lhs
+++ b/ghc/compiler/rename/RnHsSyn.lhs
@@ -35,6 +35,7 @@ type RenamedHsBinds		= HsBinds		Name RenamedPat
 type RenamedHsExpr		= HsExpr		Name RenamedPat
 type RenamedHsModule		= HsModule		Name RenamedPat
 type RenamedInstDecl		= InstDecl		Name RenamedPat
+type RenamedMatchContext	= HsMatchContext	Name
 type RenamedMatch		= Match			Name RenamedPat
 type RenamedMonoBinds		= MonoBinds		Name RenamedPat
 type RenamedPat			= InPat			Name
diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index 71fe8ff..6bb8bc0 100644
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -119,7 +119,7 @@ rnSourceDecl (DefD (DefaultDecl tys src_loc))
     mapFvRn (rnHsTypeFVs doc_str) tys		`thenRn` \ (tys', fvs) ->
     returnRn (DefD (DefaultDecl tys' src_loc), fvs)
   where
-    doc_str = text "a `default' declaration"
+    doc_str = text "In a `default' declaration"
 \end{code}
 
 
@@ -178,7 +178,7 @@ finishSourceInstDecl (InstDecl _       mbinds uprags _               _      )
 	-- Used for both source decls only
   = ASSERT( not (maybeToBool maybe_dfun_name) )	-- Source decl!
     let
-	meth_doc    = text "the bindings in an instance declaration"
+	meth_doc    = text "In the bindings in an instance declaration"
 	meth_names  = collectLocatedMonoBinders mbinds
 	inst_tyvars = case inst_ty of
 			HsForAllTy (Just inst_tyvars) _ _ -> inst_tyvars
@@ -246,7 +246,7 @@ rnHsRuleDecl (HsRule rule_name tvs vars lhs rhs src_loc)
     returnRn (HsRule rule_name sig_tvs' vars' lhs' rhs' src_loc,
 	      fv_vars `plusFV` fv_lhs `plusFV` fv_rhs)
   where
-    doc = text "the transformation rule" <+> ptext rule_name
+    doc = text "In the transformation rule" <+> ptext rule_name
     sig_tvs = extractRuleBndrsTyVars vars
   
     get_var (RuleBndr v)      = v
@@ -285,7 +285,7 @@ rnTyClDecl (IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc
     mapRn rnIdInfo id_infos		`thenRn` \ id_infos' -> 
     returnRn (IfaceSig {tcdName = name', tcdType = ty', tcdIdInfo = id_infos', tcdLoc = loc})
   where
-    doc_str = text "the interface signature for" <+> quotes (ppr name)
+    doc_str = text "In the interface signature for" <+> quotes (ppr name)
 
 rnTyClDecl (ForeignType {tcdName = name, tcdFoType = spec, tcdLoc = loc})
   = pushSrcLocRn loc 			$
@@ -300,13 +300,24 @@ rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon,
     bindTyVarsRn data_doc tyvars		$ \ tyvars' ->
     rnContext data_doc context 			`thenRn` \ context' ->
     checkDupOrQualNames data_doc con_names	`thenRn_`
+
+	-- Check that there's at least one condecl,
+	-- or else we're reading an interface file, or -fglasgow-exts
+    (if null condecls then
+	doptRn Opt_GlasgowExts	`thenRn` \ glaExts ->
+	getModeRn		`thenRn` \ mode ->
+	checkRn (glaExts || isInterfaceMode mode)
+		(emptyConDeclsErr tycon)
+     else returnRn ()
+    )						`thenRn_` 
+
     mapRn rnConDecl condecls			`thenRn` \ condecls' ->
     mapRn lookupSysBinder sys_names	        `thenRn` \ sys_names' ->
     returnRn (TyData {tcdND = new_or_data, tcdCtxt = context', tcdName = tycon',
 		      tcdTyVars = tyvars', tcdCons = condecls', tcdNCons = nconstrs,
 		      tcdDerivs = Nothing, tcdLoc = src_loc, tcdSysNames = sys_names'})
   where
-    data_doc = text "the data type declaration for" <+> quotes (ppr tycon)
+    data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
     con_names = map conDeclName condecls
 
 rnTyClDecl (TySynonym {tcdName = name, tcdTyVars = tyvars, tcdSynRhs = ty, tcdLoc = src_loc})
@@ -317,7 +328,7 @@ rnTyClDecl (TySynonym {tcdName = name, tcdTyVars = tyvars, tcdSynRhs = ty, tcdLo
     rnHsType syn_doc (unquantify glaExts ty)	`thenRn` \ ty' ->
     returnRn (TySynonym {tcdName = name', tcdTyVars = tyvars', tcdSynRhs = ty', tcdLoc = src_loc})
   where
-    syn_doc = text "the declaration for type synonym" <+> quotes (ppr name)
+    syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
 
 	-- For H98 we do *not* universally quantify on the RHS of a synonym
 	-- Silently discard context... but the tyvars in the rest won't be in scope
@@ -370,8 +381,8 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdName = cname,
 			  tcdFDs = fds', tcdSigs = non_ops' ++ sigs', tcdMeths = Nothing, 
 			  tcdSysNames = names', tcdLoc = src_loc})
   where
-    cls_doc  = text "the declaration for class" 	<+> ppr cname
-    sig_doc  = text "the signatures for class"  	<+> ppr cname
+    cls_doc  = text "In the declaration for class" 	<+> ppr cname
+    sig_doc  = text "In the signatures for class"  	<+> ppr cname
 
 rnClassOp clas clas_tyvars clas_fds sig@(ClassOpSig op dm_stuff ty locn)
   = pushSrcLocRn locn $
@@ -433,7 +444,7 @@ finishSourceTyClDecl (ClassDecl {tcdMeths = Just mbinds, tcdLoc = src_loc})	-- G
     rnMethodBinds gen_tyvars mbinds			`thenRn` \ (mbinds', meth_fvs) ->
     returnRn (rn_cls_decl {tcdMeths = Just mbinds'}, meth_fvs)
   where
-    meth_doc = text "the default-methods for class"	<+> ppr (tcdName rn_cls_decl)
+    meth_doc = text "In the default-methods for class"	<+> ppr (tcdName rn_cls_decl)
 
 finishSourceTyClDecl _ tycl_decl = returnRn (tycl_decl, emptyFVs)
 	-- Not a class or data type declaration
@@ -473,7 +484,7 @@ rnConDecl (ConDecl name wkr tvs cxt details locn)
     rnConDetails doc locn details	`thenRn` \ new_details -> 
     returnRn (ConDecl new_name new_wkr new_tyvars new_context new_details locn)
   where
-    doc = text "the definition of data constructor" <+> quotes (ppr name)
+    doc = text "In the definition of data constructor" <+> quotes (ppr name)
 
 rnConDetails doc locn (VanillaCon tys)
   = mapRn (rnBangTy doc) tys	`thenRn` \ new_tys  ->
@@ -537,7 +548,7 @@ rnHsSigType :: SDoc -> RdrNameHsType -> RnMS RenamedHsType
 	-- rnHsSigType is used for source-language type signatures,
 	-- which use *implicit* universal quantification.
 rnHsSigType doc_str ty
-  = rnHsType (text "the type signature for" <+> doc_str) ty
+  = rnHsType (text "In the type signature for" <+> doc_str) ty
     
 ---------------------------------------
 rnHsType :: SDoc -> RdrNameHsType -> RnMS RenamedHsType
@@ -872,7 +883,7 @@ forAllWarn doc ty tyvar
 		   sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
 		   nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
 		   $$
-		   (ptext SLIT("In") <+> doc)
+		   doc
                 )
           }
 
@@ -896,4 +907,7 @@ dupClassAssertWarn ctxt (assertion : dups)
 naughtyCCallContextErr (HsClassP clas _)
   = sep [ptext SLIT("Can't use class") <+> quotes (ppr clas), 
 	 ptext SLIT("in a context")]
+emptyConDeclsErr tycon
+  = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"),
+	 nest 4 (ptext SLIT("(-fglasgow-exts permits this)"))]
 \end{code}
diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index 44e9477..70ee5bd 100644
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -674,7 +674,7 @@ tcMonoBinds mbinds tc_ty_sigs is_rec
 	   complete_it xve = tcAddSrcLoc locn		 		$
 			     tcAddErrCtxt (patMonoBindsCtxt bind)	$
 			     tcExtendLocalValEnv xve			$
-			     tcGRHSs grhss pat_ty PatBindRhs		`thenTc` \ (grhss', lie) ->
+			     tcGRHSs PatBindRhs grhss pat_ty		`thenTc` \ (grhss', lie) ->
 			     returnTc (PatMonoBind pat' grhss' locn, lie)
 	in
 	returnTc (complete_it, lie_req, tvs, ids, lie_avail)
diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index 9be3c54..793abd1 100644
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -9,7 +9,7 @@ module TcExpr ( tcApp, tcExpr, tcMonoExpr, tcPolyExpr, tcId ) where
 #include "HsVersions.h"
 
 import HsSyn		( HsExpr(..), HsLit(..), ArithSeqInfo(..), 
-			  HsMatchContext(..), mkMonoBind
+			  HsMatchContext(..), HsDoContext(..), mkMonoBind
 			)
 import RnHsSyn		( RenamedHsExpr, RenamedRecordBinds )
 import TcHsSyn		( TcExpr, TcRecordBinds, mkHsLet )
@@ -779,7 +779,7 @@ tcDoStmts do_or_lc stmts src_loc res_ty
 		   returnNF_Tc (m_ty, (mkAppTy m_ty, elt_ty))
     )							`thenNF_Tc` \ (tc_ty, m_ty) ->
 
-    tcStmts do_or_lc m_ty stmts				`thenTc`   \ (stmts', stmts_lie) ->
+    tcStmts (DoCtxt do_or_lc) m_ty stmts		`thenTc`   \ (stmts', stmts_lie) ->
 
 	-- Build the then and zero methods in case we need them
 	-- It's important that "then" and "return" appear just once in the final LIE,
diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs
index 9939a58..1c840a1 100644
--- a/ghc/compiler/typecheck/TcGenDeriv.lhs
+++ b/ghc/compiler/typecheck/TcGenDeriv.lhs
@@ -28,7 +28,7 @@ module TcGenDeriv (
 
 import HsSyn		( InPat(..), HsExpr(..), MonoBinds(..),
 			  Match(..), GRHSs(..), Stmt(..), HsLit(..),
-			  HsBinds(..), HsType(..), HsMatchContext(..),
+			  HsBinds(..), HsType(..), HsDoContext(..),
 			  unguardedRHS, mkSimpleMatch, mkMonoBind, andMonoBindList
 			)
 import RdrHsSyn		( mkHsOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat )
diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index 78a6676..ab8f3ad 100644
--- a/ghc/compiler/typecheck/TcHsSyn.lhs
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -21,6 +21,7 @@ module TcHsSyn (
 	TypecheckedMatch, TypecheckedHsModule,
 	TypecheckedGRHSs, TypecheckedGRHS,
 	TypecheckedRecordBinds, TypecheckedDictBinds,
+	TypecheckedMatchContext,
 
 	mkHsTyApp, mkHsDictApp, mkHsConApp,
 	mkHsTyLam, mkHsDictLam, mkHsLet,
@@ -91,6 +92,7 @@ type TypecheckedHsExpr		= HsExpr	Id TypecheckedPat
 type TypecheckedArithSeqInfo	= ArithSeqInfo	Id TypecheckedPat
 type TypecheckedStmt		= Stmt		Id TypecheckedPat
 type TypecheckedMatch		= Match		Id TypecheckedPat
+type TypecheckedMatchContext	= HsMatchContext Id
 type TypecheckedGRHSs		= GRHSs		Id TypecheckedPat
 type TypecheckedGRHS		= GRHS		Id TypecheckedPat
 type TypecheckedRecordBinds	= HsRecordBinds Id TypecheckedPat
diff --git a/ghc/compiler/typecheck/TcMatches.hi-boot b/ghc/compiler/typecheck/TcMatches.hi-boot
index 593f18e..1ec6b18 100644
--- a/ghc/compiler/typecheck/TcMatches.hi-boot
+++ b/ghc/compiler/typecheck/TcMatches.hi-boot
@@ -3,9 +3,9 @@ _exports_
 TcMatches tcGRHSs tcMatchesFun;
 _declarations_
 2 tcGRHSs _:_ _forall_ [s] => 
-	      RnHsSyn.RenamedGRHSs
+	      HsExpr.HsMatchContext Name.Name
+	      -> RnHsSyn.RenamedGRHSs
 	      -> TcMonad.TcType
-	      -> HsExpr.HsMatchContext
 	      -> TcMonad.TcM s (TcHsSyn.TcGRHSs, Inst.LIE) ;;
 3 tcMatchesFun _:_ _forall_ [s] => 
 		[(Name.Name,Var.Id)]
diff --git a/ghc/compiler/typecheck/TcMatches.hi-boot-5 b/ghc/compiler/typecheck/TcMatches.hi-boot-5
index 044339d..d54594a 100644
--- a/ghc/compiler/typecheck/TcMatches.hi-boot-5
+++ b/ghc/compiler/typecheck/TcMatches.hi-boot-5
@@ -1,9 +1,8 @@
 __interface TcMatches 1 0 where
 __export TcMatches tcGRHSs tcMatchesFun;
-1 tcGRHSs :: 
-	      RnHsSyn.RenamedGRHSs
+1 tcGRHSs ::  HsExpr.HsMatchContext Name.Name
+	      -> RnHsSyn.RenamedGRHSs
 	      -> TcMonad.TcType
-	      -> HsExpr.HsMatchContext
 	      -> TcMonad.TcM (TcHsSyn.TcGRHSs, Inst.LIE) ;
 1 tcMatchesFun :: 
 		[(Name.Name,Var.Id)]
diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs
index d6ce7a9..20c2a44 100644
--- a/ghc/compiler/typecheck/TcMatches.lhs
+++ b/ghc/compiler/typecheck/TcMatches.lhs
@@ -13,13 +13,13 @@ module TcMatches ( tcMatchesFun, tcMatchesCase, tcMatchLambda,
 import {-# SOURCE #-}	TcExpr( tcExpr )
 
 import HsSyn		( HsBinds(..), Match(..), GRHSs(..), GRHS(..),
-			  MonoBinds(..), Stmt(..), HsMatchContext(..),
+			  MonoBinds(..), Stmt(..), HsMatchContext(..), HsDoContext(..),
 			  pprMatch, getMatchLoc, pprMatchContext, isDoExpr,
 			  mkMonoBind, nullMonoBinds, collectSigTysFromPats
 			)
 import RnHsSyn		( RenamedMatch, RenamedGRHSs, RenamedStmt, RenamedPat, RenamedHsType,
-			  extractHsTyVars )
-import TcHsSyn		( TcMatch, TcGRHSs, TcStmt, TcDictBinds, TypecheckedPat )
+			  RenamedMatchContext, extractHsTyVars )
+import TcHsSyn		( TcMatch, TcGRHSs, TcStmt, TcDictBinds, TypecheckedPat, TypecheckedMatchContext )
 
 import TcMonad
 import TcMonoType	( kcHsSigTypes, tcScopedTyVars, checkSigTyVars, tcHsSigType, sigPatCtxt )
@@ -80,7 +80,7 @@ tcMatchesFun xve fun_name expected_ty matches@(first_match:_)
 	-- may show up as something wrong with the (non-existent) type signature
 
 	-- No need to zonk expected_ty, because unifyFunTy does that on the fly
-    tcMatches xve matches expected_ty (FunRhs fun_name)
+    tcMatches xve (FunRhs fun_name) matches expected_ty
 \end{code}
 
 @tcMatchesCase@ doesn't do the argument-count check because the
@@ -95,26 +95,26 @@ tcMatchesCase :: [RenamedMatch]		-- The case alternatives
 
 tcMatchesCase matches expr_ty
   = newTyVarTy openTypeKind 					`thenNF_Tc` \ scrut_ty ->
-    tcMatches [] matches (mkFunTy scrut_ty expr_ty) CaseAlt	`thenTc` \ (matches', lie) ->
+    tcMatches [] CaseAlt matches (mkFunTy scrut_ty expr_ty)	`thenTc` \ (matches', lie) ->
     returnTc (scrut_ty, matches', lie)
 
 tcMatchLambda :: RenamedMatch -> TcType -> TcM (TcMatch, LIE)
-tcMatchLambda match res_ty = tcMatch [] match res_ty LambdaExpr
+tcMatchLambda match res_ty = tcMatch [] LambdaExpr match res_ty
 \end{code}
 
 
 \begin{code}
 tcMatches :: [(Name,Id)]
+	  -> RenamedMatchContext 
 	  -> [RenamedMatch]
 	  -> TcType
-	  -> HsMatchContext 
 	  -> TcM ([TcMatch], LIE)
 
-tcMatches xve matches expected_ty fun_or_case
+tcMatches xve fun_or_case matches expected_ty
   = mapAndUnzipTc tc_match matches	`thenTc` \ (matches, lies) ->
     returnTc (matches, plusLIEs lies)
   where
-    tc_match match = tcMatch xve match expected_ty fun_or_case
+    tc_match match = tcMatch xve fun_or_case match expected_ty
 \end{code}
 
 
@@ -126,13 +126,13 @@ tcMatches xve matches expected_ty fun_or_case
 
 \begin{code}
 tcMatch :: [(Name,Id)]
+	-> RenamedMatchContext
 	-> RenamedMatch
 	-> TcType 		-- Expected result-type of the Match.
 				-- Early unification with this guy gives better error messages
-	-> HsMatchContext
 	-> TcM (TcMatch, LIE)
 
-tcMatch xve1 match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty ctxt
+tcMatch xve1 ctxt match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty
   = tcAddSrcLoc (getMatchLoc match)		$	-- At one stage I removed this;
     tcAddErrCtxt (matchCtxt ctxt match)		$	-- I'm not sure why, so I put it back
     
@@ -150,7 +150,7 @@ tcMatch xve1 match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty ctxt
 
 		-- Typecheck the body
 		tcExtendLocalValEnv xve1 	$
-		tcGRHSs grhss rhs_ty ctxt	`thenTc` \ (grhss', lie) ->
+		tcGRHSs ctxt grhss rhs_ty	`thenTc` \ (grhss', lie) ->
 		returnTc ((pats', grhss'), lie)
 	  )
 
@@ -172,11 +172,11 @@ glue_on _ EmptyMonoBinds grhss = grhss		-- The common case
 glue_on is_rec mbinds (GRHSs grhss binds ty)
   = GRHSs grhss (mkMonoBind mbinds [] is_rec `ThenBinds` binds) ty
 
-tcGRHSs :: RenamedGRHSs
-	-> TcType -> HsMatchContext
+tcGRHSs :: RenamedMatchContext -> RenamedGRHSs
+	-> TcType
 	-> TcM (TcGRHSs, LIE)
 
-tcGRHSs (GRHSs grhss binds _) expected_ty ctxt
+tcGRHSs ctxt (GRHSs grhss binds _) expected_ty
   = tcBindsAndThen glue_on binds (tc_grhss grhss)
   where
     tc_grhss grhss
@@ -337,7 +337,7 @@ tcStmts do_or_lc m_ty stmts
 
 tcStmtsAndThen
 	:: (TcStmt -> thing -> thing)	-- Combiner
-	-> HsMatchContext
+	-> RenamedMatchContext
         -> (TcType -> TcType, TcType)	-- m, the relationship type of pat and rhs in pat <- rhs
 					-- elt_ty, where type of the comprehension is (m elt_ty)
         -> [RenamedStmt]
@@ -384,7 +384,7 @@ tcStmtAndThen combine do_or_lc m_ty (ParStmtOut bndr_stmts_s) thing_inside
 
     loop ((bndrs,stmts) : pairs)
       = tcStmtsAndThen 
-		combine_par ListComp m_ty stmts
+		combine_par (DoCtxt ListComp) m_ty stmts
 			-- Notice we pass on m_ty; the result type is used only
 			-- to get escaping type variables for checkExistentialPat
 		(tcLookupLocalIds bndrs	`thenNF_Tc` \ bndrs' ->
@@ -451,25 +451,12 @@ sameNoOfArgs matches = length (nub (map args_in_match matches)) == 1
 \end{code}
 
 \begin{code}
-matchCtxt CaseAlt match
-  = hang (ptext SLIT("In a case alternative:"))
-	 4 (pprMatch (True,empty) {-is_case-} match)
-
-matchCtxt (FunRhs fun) match
-  = hang (hcat [ptext SLIT("In an equation for function "), quotes (ppr_fun), char ':'])
-	 4 (pprMatch (False, ppr_fun) {-not case-} match)
-  where
-    ppr_fun = ppr fun
-
-matchCtxt LambdaExpr match
-  = hang (ptext SLIT("In the lambda expression"))
-	 4 (pprMatch (True, empty) match)
+matchCtxt ctxt  match  = hang (pprMatchContext ctxt     <> colon) 4 (pprMatch ctxt match)
+stmtCtxt do_or_lc stmt = hang (pprMatchContext do_or_lc <> colon) 4 (ppr stmt)
 
 varyingArgsErr name matches
   = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
 
 lurkingRank2SigErr
   = ptext SLIT("Too few explicit arguments when defining a function with a rank-2 type")
-
-stmtCtxt do_or_lc stmt = hang (pprMatchContext do_or_lc <> colon) 4 (ppr stmt)
 \end{code}
diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs
index 8842be5..6b7d0c4 100644
--- a/ghc/compiler/typecheck/TcModule.lhs
+++ b/ghc/compiler/typecheck/TcModule.lhs
@@ -13,7 +13,7 @@ module TcModule (
 
 import CmdLineOpts	( DynFlag(..), DynFlags, dopt )
 import HsSyn		( HsBinds(..), MonoBinds(..), HsDecl(..), HsExpr(..),
-			  Stmt(..), InPat(..), HsMatchContext(..), RuleDecl(..),
+			  Stmt(..), InPat(..), HsMatchContext(..), HsDoContext(..), RuleDecl(..),
 			  isIfaceRuleDecl, nullBinds, andMonoBindList, mkSimpleMatch
 			)
 import PrelNames	( SyntaxMap, mAIN_Name, mainName, ioTyConName, printName,
@@ -196,7 +196,7 @@ tc_stmts names stmts
     in
 
     traceTc (text "tcs 2") `thenNF_Tc_`
-    tcStmtsAndThen combine DoExpr io_ty stmts	(
+    tcStmtsAndThen combine (DoCtxt DoExpr) io_ty stmts	(
 	-- Look up the names right in the middle,
 	-- where they will all be in scope
 	mapNF_Tc tcLookupId names			`thenNF_Tc` \ ids ->