[project @ 2004-09-30 10:35:15 by simonpj]

------------------------------------
	Add Generalised Algebraic Data Types
	------------------------------------

This rather big commit adds support for GADTs.  For example,

    data Term a where
 	  Lit :: Int -> Term Int
	  App :: Term (a->b) -> Term a -> Term b
	  If  :: Term Bool -> Term a -> Term a
	  ..etc..

    eval :: Term a -> a
    eval (Lit i) = i
    eval (App a b) = eval a (eval b)
    eval (If p q r) | eval p    = eval q
    		    | otherwise = eval r


Lots and lots of of related changes throughout the compiler to make
this fit nicely.

One important change, only loosely related to GADTs, is that skolem
constants in the typechecker are genuinely immutable and constant, so
we often get better error messages from the type checker.  See
TcType.TcTyVarDetails.

There's a new module types/Unify.lhs, which has purely-functional
unification and matching for Type. This is used both in the typechecker
(for type refinement of GADTs) and in Core Lint (also for type refinement).

8 files changed, 285 insertions, 249 deletions

diff --git a/ghc/compiler/hsSyn/Convert.lhs b/ghc/compiler/hsSyn/Convert.lhs
index 2d7c85add9..e709d4d9a9 100644
--- a/ghc/compiler/hsSyn/Convert.lhs
+++ b/ghc/compiler/hsSyn/Convert.lhs
@@ -53,13 +53,13 @@ mk_con con = L loc0 $ case con of
 	 -> ConDecl (noLoc (cName c)) noExistentials noContext
 		  (InfixCon (mk_arg st1) (mk_arg st2))
   where
-    mk_arg (IsStrict, ty)  = noLoc $ BangType HsStrict (cvtType ty)
-    mk_arg (NotStrict, ty) = noLoc $ BangType HsNoBang (cvtType ty)
+    mk_arg (IsStrict, ty)  = noLoc $ HsBangTy HsStrict (cvtType ty)
+    mk_arg (NotStrict, ty) = noLoc $ HsBangTy HsNoBang (cvtType ty)
 
     mk_id_arg (i, IsStrict, ty)
-        = (noLoc (vName i), noLoc $ BangType HsStrict (cvtType ty))
+        = (noLoc (vName i), noLoc $ HsBangTy HsStrict (cvtType ty))
     mk_id_arg (i, NotStrict, ty)
-        = (noLoc (vName i), noLoc $ BangType HsNoBang (cvtType ty))
+        = (noLoc (vName i), noLoc $ HsBangTy HsNoBang (cvtType ty))
 
 mk_derivs [] = Nothing
 mk_derivs cs = Just [noLoc $ HsPredTy $ HsClassP (tconName c) [] | c <- cs]
@@ -183,12 +183,12 @@ cvt (LitE l)
   | otherwise	    = HsLit (cvtLit l)
 
 cvt (AppE x y)     = HsApp (cvtl x) (cvtl y)
-cvt (LamE ps e)    = HsLam (mkSimpleMatch (map cvtlp ps) (cvtl e) void)
+cvt (LamE ps e)    = HsLam (mkMatchGroup [mkSimpleMatch (map cvtlp ps) (cvtl e)])
 cvt (TupE [e])	  = cvt e
 cvt (TupE es)	  = ExplicitTuple(map cvtl es) Boxed
 cvt (CondE x y z)  = HsIf (cvtl x) (cvtl y) (cvtl z)
 cvt (LetE ds e)	  = HsLet (cvtdecs ds) (cvtl e)
-cvt (CaseE e ms)   = HsCase (cvtl e) (map cvtm ms)
+cvt (CaseE e ms)   = HsCase (cvtl e) (mkMatchGroup (map cvtm ms))
 cvt (DoE ss)	  = HsDo DoExpr (cvtstmts ss) [] void
 cvt (CompE ss)     = HsDo ListComp (cvtstmts ss) [] void
 cvt (ArithSeqE dd) = ArithSeqIn (cvtdd dd)
@@ -223,11 +223,11 @@ cvtd :: TH.Dec -> LHsBind RdrName
 -- Used only for declarations in a 'let/where' clause,
 -- not for top level decls
 cvtd (TH.ValD (TH.VarP s) body ds) 
-  = noLoc $ FunBind (noLoc (vName s)) False [cvtclause (Clause [] body ds)]
+  = noLoc $ FunBind (noLoc (vName s)) False (mkMatchGroup [cvtclause (Clause [] body ds)])
 cvtd (FunD nm cls)
-  = noLoc $ FunBind (noLoc (vName nm)) False (map cvtclause cls)
+  = noLoc $ FunBind (noLoc (vName nm)) False (mkMatchGroup (map cvtclause cls))
 cvtd (TH.ValD p body ds)
-  = noLoc $ PatBind (cvtlp p) (GRHSs (cvtguard body) (cvtdecs ds) void)
+  = noLoc $ PatBind (cvtlp p) (GRHSs (cvtguard body) (cvtdecs ds)) void
 
 cvtd d = cvtPanic "Illegal kind of declaration in where clause" 
 		  (text (TH.pprint d))
@@ -235,7 +235,7 @@ cvtd d = cvtPanic "Illegal kind of declaration in where clause"
 
 cvtclause :: TH.Clause -> Hs.LMatch RdrName
 cvtclause (Clause ps body wheres)
-    = noLoc $ Hs.Match (map cvtlp ps) Nothing (GRHSs (cvtguard body) (cvtdecs wheres) void)
+    = noLoc $ Hs.Match (map cvtlp ps) Nothing (GRHSs (cvtguard body) (cvtdecs wheres))
 
 
 
@@ -256,7 +256,7 @@ cvtstmts (TH.ParS dss : ss)  = nlParStmt [(cvtstmts ds, undefined) | ds <- dss]
 
 cvtm :: TH.Match -> Hs.LMatch RdrName
 cvtm (TH.Match p body wheres)
-    = noLoc (Hs.Match [cvtlp p] Nothing (GRHSs (cvtguard body) (cvtdecs wheres) void))
+    = noLoc (Hs.Match [cvtlp p] Nothing (GRHSs (cvtguard body) (cvtdecs wheres)))
 
 cvtguard :: TH.Body -> [LGRHS RdrName]
 cvtguard (GuardedB pairs) = map cvtpair pairs
diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs
index c473fd3c6e..e3485b9478 100644
--- a/ghc/compiler/hsSyn/HsBinds.lhs
+++ b/ghc/compiler/hsSyn/HsBinds.lhs
@@ -11,21 +11,18 @@ module HsBinds where
 #include "HsVersions.h"
 
 import {-# SOURCE #-} HsExpr ( HsExpr, pprExpr, LHsExpr,
-			       LMatch, pprFunBind,
+			       MatchGroup, pprFunBind,
 			       GRHSs, pprPatBind )
+import {-# SOURCE #-} HsPat  ( LPat )
 
--- friends:
-import HsPat		( LPat )
-import HsTypes		( LHsType )
-
---others:
+import HsTypes		( LHsType, PostTcType )
 import Name		( Name )
 import NameSet		( NameSet, elemNameSet, nameSetToList )
 import BasicTypes	( IPName, RecFlag(..), Activation(..), Fixity )
 import Outputable	
 import SrcLoc		( Located(..), unLoc )
 import Var		( TyVar )
-import Bag		( Bag, bagToList )
+import Bag		( Bag, emptyBag, isEmptyBag, bagToList )
 \end{code}
 
 %************************************************************************
@@ -81,11 +78,20 @@ instance (OutputableBndr id) => Outputable (IPBind id) where
 
 -- -----------------------------------------------------------------------------
 
-type LHsBinds id = Bag (LHsBind id)
-type LHsBind  id = Located (HsBind id)
+type LHsBinds id  = Bag (LHsBind id)
+type DictBinds id = LHsBinds id		-- Used for dictionary or method bindings
+type LHsBind  id  = Located (HsBind id)
+
+emptyLHsBinds :: LHsBinds id
+emptyLHsBinds = emptyBag
+
+isEmptyLHsBinds :: LHsBinds id -> Bool
+isEmptyLHsBinds = isEmptyBag
 
 pprLHsBinds :: OutputableBndr id => LHsBinds id -> SDoc
-pprLHsBinds binds = lbrace <+> vcat (map ppr (bagToList binds)) <+> rbrace
+pprLHsBinds binds 
+  | isEmptyLHsBinds binds = empty
+  | otherwise = lbrace <+> vcat (map ppr (bagToList binds)) <+> rbrace
 
 data HsBind id
   = FunBind     (Located id)
@@ -98,11 +104,12 @@ data HsBind id
 			-- FunBinds, so if you change this, you'll need to
 			-- change e.g. rnMethodBinds
 		Bool	-- True => infix declaration
-		[LMatch id]
+		(MatchGroup id)
 
   | PatBind     (LPat id)	-- The pattern is never a simple variable;
 				-- That case is done by FunBind
 		(GRHSs id)
+		PostTcType	-- Type of the GRHSs
 
   | VarBind id (Located (HsExpr id))	-- Dictionary binding and suchlike;
 					-- located only for consistency
@@ -152,7 +159,7 @@ instance OutputableBndr id => Outputable (HsBind id) where
 
 ppr_monobind :: OutputableBndr id => HsBind id -> SDoc
 
-ppr_monobind (PatBind pat grhss)       = pprPatBind pat grhss
+ppr_monobind (PatBind pat grhss ty)    = pprPatBind pat grhss
 ppr_monobind (VarBind var rhs)         = ppr var <+> equals <+> pprExpr (unLoc rhs)
 ppr_monobind (FunBind fun inf matches) = pprFunBind (unLoc fun) matches
       -- ToDo: print infix if appropriate
diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs
index 3a610024a3..4b1b028a78 100644
--- a/ghc/compiler/hsSyn/HsDecls.lhs
+++ b/ghc/compiler/hsSyn/HsDecls.lhs
@@ -14,9 +14,7 @@ module HsDecls (
 	DefaultDecl(..), LDefaultDecl, HsGroup(..), SpliceDecl(..),
 	ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),
 	CImportSpec(..), FoType(..),
-	ConDecl(..), LConDecl,
-	LBangType, BangType(..), HsBang(..), 
-	getBangType, getBangStrictness, unbangedType, 
+	ConDecl(..), LConDecl,	
 	DeprecDecl(..),  LDeprecDecl,
 	tcdName, tyClDeclNames, tyClDeclTyVars,
 	isClassDecl, isSynDecl, isDataDecl, 
@@ -429,7 +427,10 @@ pp_decl_head :: OutputableBndr name
 pp_decl_head context thing tyvars
   = hsep [pprHsContext context, ppr thing, interppSP tyvars]
 
-pp_condecls cs = equals <+> sep (punctuate (ptext SLIT(" |")) (map ppr cs))
+pp_condecls cs@(L _ (GadtDecl _ _) : _) -- In GADT syntax
+  = hang (ptext SLIT("where")) 2 (vcat (map ppr cs))
+pp_condecls cs 			  -- In H98 syntax
+  = equals <+> sep (punctuate (ptext SLIT(" |")) (map ppr cs))
 
 pp_tydecl pp_head pp_decl_rhs derivings
   = hang pp_head 4 (sep [
@@ -461,8 +462,12 @@ data ConDecl name
 		[LHsTyVarBndr name]	-- Existentially quantified type variables
 		(LHsContext name)	-- ...and context
 					-- If both are empty then there are no existentials
-
 		(HsConDetails name (LBangType name))
+
+  | GadtDecl    (Located name)          -- Constructor name; this is used for the
+					-- DataCon itself, and for the user-callable wrapper Id
+                (LHsType name)          -- Constructor type; it may have HsBangs on the 
+					-- argument types
 \end{code}
 
 \begin{code}
@@ -481,32 +486,23 @@ conDeclsNames cons
     do_one (flds_seen, acc) (ConDecl lname _ _ _)
 	= (flds_seen, lname:acc)
 
+-- gaw 2004
+    do_one (flds_seen, acc) (GadtDecl lname _)
+	= (flds_seen, lname:acc)
+
 conDetailsTys details = map getBangType (hsConArgs details)
 \end{code}
   
-\begin{code}
-type LBangType name = Located (BangType name)
-
-data BangType name = BangType HsBang (LHsType name)
-
-data HsBang = HsNoBang
-	    | HsStrict	-- ! 
-	    | HsUnbox	-- {-# UNPACK #-} ! (GHC extension, meaning "unbox")
-
-getBangType       (BangType _ ty) = ty
-getBangStrictness (BangType s _)  = s
-
-unbangedType :: LHsType id -> LBangType id
-unbangedType ty@(L loc _) = L loc (BangType HsNoBang ty)
-\end{code}
 
 \begin{code}
 instance (OutputableBndr name) => Outputable (ConDecl name) where
     ppr (ConDecl con tvs cxt con_details)
       = sep [pprHsForAll Explicit tvs cxt, ppr_con_details con con_details]
+    ppr (GadtDecl con ty)
+      = ppr con <+> dcolon <+> ppr ty
 
 ppr_con_details con (InfixCon ty1 ty2)
-  = hsep [ppr ty1, ppr con, ppr ty2]
+  = hsep [ppr ty1, pprHsVar con, ppr ty2]
 
 -- ConDecls generated by MkIface.ifaceTyThing always have a PrefixCon, even
 -- if the constructor is an infix one.  This is because in an interface file
@@ -520,17 +516,8 @@ ppr_con_details con (RecCon fields)
   where
     ppr_field (n, ty) = ppr n <+> dcolon <+> ppr ty
 
-instance OutputableBndr name => Outputable (BangType name) where
-    ppr (BangType is_strict ty) 
-	= bang <> pprParendHsType (unLoc ty)
-	where
-	  bang = case is_strict of
-			HsNoBang -> empty
-			HsStrict -> char '!'
-			HsUnbox  -> ptext SLIT("!!")
 \end{code}
 
-
 %************************************************************************
 %*									*
 \subsection[InstDecl]{An instance declaration
diff --git a/ghc/compiler/hsSyn/HsExpr.hi-boot-6 b/ghc/compiler/hsSyn/HsExpr.hi-boot-6
index 30d90a0628..dd12cd5537 100644
--- a/ghc/compiler/hsSyn/HsExpr.hi-boot-6
+++ b/ghc/compiler/hsSyn/HsExpr.hi-boot-6
@@ -2,11 +2,10 @@ module HsExpr where
 
 data HsExpr i
 data HsSplice i
-data Match a
+data MatchGroup a
 data GRHSs a
 
 type LHsExpr a = SrcLoc.Located (HsExpr a)
-type LMatch a  = SrcLoc.Located (Match a)
 
 pprExpr :: (Outputable.OutputableBndr i) => 
 	HsExpr.HsExpr i -> Outputable.SDoc
@@ -14,8 +13,8 @@ pprExpr :: (Outputable.OutputableBndr i) =>
 pprSplice :: (Outputable.OutputableBndr i) => 
 	HsExpr.HsSplice i -> Outputable.SDoc
 
-pprPatBind :: (Outputable.OutputableBndr i) => 
-	HsPat.LPat i -> HsExpr.GRHSs i -> Outputable.SDoc
+pprPatBind :: (Outputable.OutputableBndr b, Outputable.OutputableBndr i) => 
+	HsPat.LPat b -> HsExpr.GRHSs i -> Outputable.SDoc
 
 pprFunBind :: (Outputable.OutputableBndr i) => 
-	i -> [HsExpr.LMatch i] -> Outputable.SDoc
+	i -> HsExpr.MatchGroup i -> Outputable.SDoc
diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs
index 88b681c8a0..e529e6fea4 100644
--- a/ghc/compiler/hsSyn/HsExpr.lhs
+++ b/ghc/compiler/hsSyn/HsExpr.lhs
@@ -43,8 +43,9 @@ data HsExpr id
   | HsOverLit	HsOverLit	-- Overloaded literals; eliminated by type checker
   | HsLit	HsLit		-- Simple (non-overloaded) literals
 
-  | HsLam	(LMatch  id)	-- lambda
-  | HsApp	(LHsExpr id)	-- application
+  | HsLam	(MatchGroup  id)	-- Currently always a single match
+
+  | HsApp	(LHsExpr id)		-- Application
 		(LHsExpr id)
 
   -- Operator applications:
@@ -72,7 +73,7 @@ data HsExpr id
 		(LHsExpr id)	-- operand
 				
   | HsCase	(LHsExpr id)
-		[LMatch id]
+		(MatchGroup id)
 
   | HsIf	(LHsExpr id)	--  predicate
 		(LHsExpr id)	--  then part
@@ -267,8 +268,6 @@ ppr_expr (HsIPVar v)     = ppr v
 ppr_expr (HsLit lit)     = ppr lit
 ppr_expr (HsOverLit lit) = ppr lit
 
-ppr_expr (HsLam match) = pprMatch LambdaExpr (unLoc match)
-
 ppr_expr (HsApp e1 e2)
   = let (fun, args) = collect_args e1 [e2] in
     (ppr_lexpr fun) <+> (sep (map pprParendExpr args))
@@ -317,6 +316,9 @@ ppr_expr (SectionR op expr)
     pp_infixly v
       = parens (sep [ppr v, pp_expr])
 
+ppr_expr (HsLam matches) 
+  = pprMatches LambdaExpr matches
+
 ppr_expr (HsCase expr matches)
   = sep [ sep [ptext SLIT("case"), nest 4 (ppr expr), ptext SLIT("of")],
 	    nest 2 (pprMatches CaseAlt matches) ]
@@ -590,6 +592,13 @@ a function defined by pattern matching must have the same number of
 patterns in each equation.
 
 \begin{code}
+data MatchGroup id 
+  = MatchGroup 
+	[LMatch id] 	-- The alternatives
+	PostTcType	-- The type is the type of the entire group
+			-- 	t1 -> ... -> tn -> tr
+			-- where there are n patterns
+
 type LMatch id = Located (Match id)
 
 data Match id
@@ -597,14 +606,18 @@ data Match id
 	[LPat id]		-- The patterns
 	(Maybe (LHsType id))	-- A type signature for the result of the match
 				--	Nothing after typechecking
-
 	(GRHSs id)
 
+-- gaw 2004
+hsLMatchPats :: LMatch id -> [LPat id]
+hsLMatchPats (L _ (Match pats _ _)) = pats
+
 -- GRHSs are used both for pattern bindings and for Matches
 data GRHSs id	
   = GRHSs [LGRHS id]		-- Guarded RHSs
 	  [HsBindGroup id]	-- The where clause
-	  PostTcType		-- Type of RHS (after type checking)
+-- gaw 2004
+--	  PostTcType		-- Type of RHS (after type checking)
 
 type LGRHS id = Located (GRHS id)
 
@@ -615,23 +628,24 @@ data GRHS id
 We know the list must have at least one @Match@ in it.
 
 \begin{code}
-pprMatches :: (OutputableBndr id) => HsMatchContext id -> [LMatch id] -> SDoc
-pprMatches ctxt matches = vcat (map (pprMatch ctxt) (map unLoc matches))
+pprMatches :: (OutputableBndr id) => HsMatchContext id -> MatchGroup id -> SDoc
+pprMatches ctxt (MatchGroup matches _) = vcat (map (pprMatch ctxt) (map unLoc matches))
 
 -- Exported to HsBinds, which can't see the defn of HsMatchContext
-pprFunBind :: (OutputableBndr id) => id -> [LMatch id] -> SDoc
+pprFunBind :: (OutputableBndr id) => id -> MatchGroup id -> SDoc
 pprFunBind fun matches = pprMatches (FunRhs fun) matches
 
 -- Exported to HsBinds, which can't see the defn of HsMatchContext
-pprPatBind :: (OutputableBndr id)
-	   => LPat id -> GRHSs id -> SDoc
+pprPatBind :: (OutputableBndr bndr, OutputableBndr id)
+	   => LPat bndr -> GRHSs id -> SDoc
 pprPatBind pat grhss = sep [ppr pat, nest 4 (pprGRHSs PatBindRhs grhss)]
 
 
 pprMatch :: OutputableBndr id => HsMatchContext id -> Match id -> SDoc
+-- gaw 2004
 pprMatch ctxt (Match pats maybe_ty grhss)
   = pp_name ctxt <+> sep [sep (map ppr pats), 
-		     ppr_maybe_ty,
+		     ppr_maybe_ty, 
 		     nest 2 (pprGRHSs ctxt grhss)]
   where
     pp_name (FunRhs fun) = ppr fun	-- Not pprBndr; the AbsBinds will
@@ -645,7 +659,8 @@ pprMatch ctxt (Match pats maybe_ty grhss)
 
 
 pprGRHSs :: OutputableBndr id => HsMatchContext id -> GRHSs id -> SDoc
-pprGRHSs ctxt (GRHSs grhss binds ty)
+-- gaw 2004
+pprGRHSs ctxt (GRHSs grhss binds)
   = vcat (map (pprGRHS ctxt . unLoc) grhss)
     $$
     (if null binds then empty
diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs
index c136ac360f..82ab6e30dd 100644
--- a/ghc/compiler/hsSyn/HsPat.lhs
+++ b/ghc/compiler/hsSyn/HsPat.lhs
@@ -9,14 +9,11 @@ module HsPat (
 	
 	HsConDetails(..), hsConArgs,
 
-	mkPrefixConPat, mkCharLitPat, mkNilPat,
+	mkPrefixConPat, mkCharLitPat, mkNilPat, 
 
 	isWildPat, 
 	patsAreAllCons, isConPat, isSigPat,
-	patsAreAllLits,	isLitPat,
-	collectPatBinders, collectPatsBinders,
-	collectLocatedPatBinders, collectLocatedPatsBinders,
-	collectSigTysFromPat, collectSigTysFromPats
+	patsAreAllLits,	isLitPat
     ) where
 
 #include "HsVersions.h"
@@ -25,10 +22,12 @@ module HsPat (
 import {-# SOURCE #-} HsExpr		( HsExpr )
 
 -- friends:
+import HsBinds		( DictBinds, emptyLHsBinds, pprLHsBinds )
 import HsLit		( HsLit(HsCharPrim), HsOverLit )
 import HsTypes		( LHsType, SyntaxName, PostTcType )
 import BasicTypes	( Boxity, tupleParens )
 -- others:
+import PprCore		( {- instance OutputableBndr TyVar -} )
 import TysWiredIn	( nilDataCon, charDataCon, charTy )
 import Var		( TyVar )
 import DataCon		( DataCon )
@@ -48,6 +47,8 @@ data Pat id
   =	------------ Simple patterns ---------------
     WildPat	PostTcType		-- Wild card
   | VarPat	id			-- Variable
+  | VarPatOut	id (DictBinds id)	-- Used only for overloaded Ids; the 
+					-- bindings give its overloaded instances
   | LazyPat	(LPat id)		-- Lazy pattern
   | AsPat	(Located id) (LPat id)  -- As pattern
   | ParPat      (LPat id)		-- Parenthesised pattern
@@ -67,10 +68,11 @@ data Pat id
 		(HsConDetails id (LPat id))
 
   | ConPatOut	DataCon 
-		(HsConDetails id (LPat id))
-		Type    		-- The type of the pattern
 		[TyVar]			-- Existentially bound type variables
 		[id]			-- Ditto dictionaries
+		(DictBinds id)		-- Bindings involving those dictionaries
+		(HsConDetails id (LPat id))
+		Type    		-- The type of the pattern
 
 	------------ Literal and n+k patterns ---------------
   | LitPat	    HsLit		-- Used for *non-overloaded* literal patterns:
@@ -84,7 +86,6 @@ data Pat id
 		    			-- The literal is retained so that the desugarer can readily identify
 					-- equations with identical literal-patterns
 					-- Always HsInteger, HsRat or HsString.
-					-- Always HsInteger, HsRat or HsString.
 					-- *Unlike* NPatIn, for negative literals, the
 					-- 	literal is acutally negative!
 		    Type	 	-- Type of pattern, t
@@ -110,10 +111,8 @@ data Pat id
   | SigPatIn	    (LPat id)		-- Pattern with a type signature
 		    (LHsType id)
 
-  | SigPatOut	    (LPat id)		-- Pattern p
-		    Type		-- Type, t, of the whole pattern
-		    (HsExpr id)		-- Coercion function,
-					-- of type t -> typeof(p)
+  | SigPatOut	    (LPat id)		-- Pattern with a type signature
+		    Type
 
 	------------ Dictionary patterns (translation only) ---------------
   | DictPat	    -- Used when destructing Dictionaries with an explicit case
@@ -146,9 +145,8 @@ hsConArgs (InfixCon p1 p2) = [p1,p2]
 instance (OutputableBndr name) => Outputable (Pat name) where
     ppr = pprPat
 
-pprPat :: (OutputableBndr name) => Pat name -> SDoc
-
-pprPat (VarPat var)	  	-- Print with type info if -dppr-debug is on
+pprPatBndr :: OutputableBndr name => name -> SDoc
+pprPatBndr var		  	-- Print with type info if -dppr-debug is on
   = getPprStyle $ \ sty ->
     if debugStyle sty then
 	parens (pprBndr LambdaBind var)		-- Could pass the site to pprPat
@@ -156,6 +154,10 @@ pprPat (VarPat var)	  	-- Print with type info if -dppr-debug is on
     else
 	ppr var
 
+pprPat :: (OutputableBndr name) => Pat name -> SDoc
+
+pprPat (VarPat var)  	  = pprPatBndr var
+pprPat (VarPatOut var bs) = parens (pprPatBndr var <+> braces (ppr bs))
 pprPat (WildPat _)	  = char '_'
 pprPat (LazyPat pat)      = char '~' <> ppr pat
 pprPat (AsPat name pat)   = parens (hcat [ppr name, char '@', ppr pat])
@@ -165,35 +167,35 @@ pprPat (ListPat pats _)   = brackets (interpp'SP pats)
 pprPat (PArrPat pats _)   = pabrackets (interpp'SP pats)
 pprPat (TuplePat pats bx) = tupleParens bx (interpp'SP pats)
 
-pprPat (ConPatIn c details) 	   = pprConPat c details
-pprPat (ConPatOut c details _ _ _) = pprConPat c details
+pprPat (ConPatIn con details) = pprUserCon con details
+pprPat (ConPatOut con tvs dicts binds details _) 
+  = getPprStyle $ \ sty ->	-- Tiresome; in TcBinds.tcRhs we print out a 
+    if debugStyle sty then 	-- typechecked Pat in an error message, 
+				-- and we want to make sure it prints nicely
+	ppr con <+> sep [ hsep (map pprPatBndr tvs) <+> hsep (map pprPatBndr dicts),
+		   	  pprLHsBinds binds, pprConArgs details]
+    else pprUserCon con details
 
 pprPat (LitPat s)	      = ppr s
 pprPat (NPatIn l _)	      = ppr l
 pprPat (NPatOut l _ _)        = ppr l
 pprPat (NPlusKPatIn n k _)    = hcat [ppr n, char '+', ppr k]
 pprPat (NPlusKPatOut n k _ _) = hcat [ppr n, char '+', integer k]
+pprPat (TypePat ty)	      = ptext SLIT("{|") <> ppr ty <> ptext SLIT("|}")
+pprPat (SigPatIn pat ty)      = ppr pat <+> dcolon <+> ppr ty
+pprPat (SigPatOut pat ty)     = ppr pat <+> dcolon <+> ppr ty
+pprPat (DictPat ds ms)	      = parens (sep [ptext SLIT("{-dict-}"),
+					     brackets (interpp'SP ds),
+					     brackets (interpp'SP ms)])
 
-pprPat (TypePat ty) = ptext SLIT("{|") <> ppr ty <> ptext SLIT("|}")
-
-pprPat (SigPatIn pat ty)    = ppr pat <+> dcolon <+> ppr ty
-pprPat (SigPatOut pat ty _) = ppr pat <+> dcolon <+> ppr ty
+pprUserCon c (InfixCon p1 p2) = ppr p1 <+> ppr c <+> ppr p2
+pprUserCon c details          = ppr c <+> pprConArgs details
 
-pprPat (DictPat dicts methods)
- = parens (sep [ptext SLIT("{-dict-}"),
-		  brackets (interpp'SP dicts),
-		  brackets (interpp'SP methods)])
-
-
-
-pprConPat con (PrefixCon pats) 	   = ppr con <+> interppSP pats -- inner ParPats supply the necessary parens.
-pprConPat con (InfixCon pat1 pat2) = hsep [ppr pat1, ppr con, ppr pat2] -- ParPats put in parens
-	-- ToDo: use pprSym to print op (but this involves fiddling various
-	-- contexts & I'm lazy...); *PatIns are *rarely* printed anyway... (WDP)
-pprConPat con (RecCon rpats)
-  = ppr con <+> braces (hsep (punctuate comma (map (pp_rpat) rpats)))
-  where
-    pp_rpat (v, p) = hsep [ppr v, char '=', ppr p]
+pprConArgs (PrefixCon pats) = interppSP pats
+pprConArgs (InfixCon p1 p2) = interppSP [p1,p2]
+pprConArgs (RecCon rpats)   = braces (hsep (punctuate comma (map (pp_rpat) rpats)))
+			    where
+			      pp_rpat (v, p) = hsep [ppr v, char '=', ppr p]
 
 
 -- add parallel array brackets around a document
@@ -212,7 +214,7 @@ pabrackets p  = ptext SLIT("[:") <> p <> ptext SLIT(":]")
 \begin{code}
 mkPrefixConPat :: DataCon -> [OutPat id] -> Type -> OutPat id
 -- Make a vanilla Prefix constructor pattern
-mkPrefixConPat dc pats ty = noLoc $ ConPatOut dc (PrefixCon pats) ty [] []
+mkPrefixConPat dc pats ty = noLoc $ ConPatOut dc [] [] emptyLHsBinds (PrefixCon pats) ty
 
 mkNilPat :: Type -> OutPat id
 mkNilPat ty = mkPrefixConPat nilDataCon [] ty
@@ -258,18 +260,18 @@ isWildPat other	      = False
 patsAreAllCons :: [Pat id] -> Bool
 patsAreAllCons pat_list = all isConPat pat_list
 
-isConPat (AsPat _ pat)		= isConPat (unLoc pat)
-isConPat (ConPatIn _ _)		= True
-isConPat (ConPatOut _ _ _ _ _)	= True
-isConPat (ListPat _ _)		= True
-isConPat (PArrPat _ _)		= True
-isConPat (TuplePat _ _)		= True
-isConPat (DictPat ds ms)	= (length ds + length ms) > 1
-isConPat other			= False
+isConPat (AsPat _ pat)		 = isConPat (unLoc pat)
+isConPat (ConPatIn _ _)		 = True
+isConPat (ConPatOut _ _ _ _ _ _) = True
+isConPat (ListPat _ _)		 = True
+isConPat (PArrPat _ _)		 = True
+isConPat (TuplePat _ _)		 = True
+isConPat (DictPat ds ms)	 = (length ds + length ms) > 1
+isConPat other			 = False
 
-isSigPat (SigPatIn _ _)    = True
-isSigPat (SigPatOut _ _ _) = True
-isSigPat other		   = False
+isSigPat (SigPatIn _ _)  = True
+isSigPat (SigPatOut _ _) = True
+isSigPat other		 = False
 
 patsAreAllLits :: [Pat id] -> Bool
 patsAreAllLits pat_list = all isLitPat pat_list
@@ -283,80 +285,3 @@ isLitPat (NPlusKPatOut _ _ _ _) = True
 isLitPat other		        = False
 \end{code}
 
-%************************************************************************
-%*									*
-%* 		Gathering stuff out of patterns
-%*									*
-%************************************************************************
-
-This function @collectPatBinders@ works with the ``collectBinders''
-functions for @HsBinds@, etc.  The order in which the binders are
-collected is important; see @HsBinds.lhs@.
-
-It collects the bounds *value* variables in renamed patterns; type variables
-are *not* collected.
-
-\begin{code}
-collectPatBinders :: LPat a -> [a]
-collectPatBinders pat = map unLoc (collectLocatedPatBinders pat)
-
-collectLocatedPatBinders :: LPat a -> [Located a]
-collectLocatedPatBinders pat = collectl pat []
-
-collectPatsBinders :: [LPat a] -> [a]
-collectPatsBinders pats = map unLoc (collectLocatedPatsBinders pats)
-
-collectLocatedPatsBinders :: [LPat a] -> [Located a]
-collectLocatedPatsBinders pats = foldr collectl [] pats
-
-collectl (L l (VarPat var)) bndrs = L l var : bndrs
-collectl pat                bndrs = collect (unLoc pat) bndrs
-
-collect (WildPat _)	      	 bndrs = bndrs
-collect (LazyPat pat)     	 bndrs = collectl pat bndrs
-collect (AsPat a pat)     	 bndrs = a : collectl pat bndrs
-collect (ParPat  pat)     	 bndrs = collectl pat bndrs
-
-collect (ListPat pats _)    	 bndrs = foldr collectl bndrs pats
-collect (PArrPat pats _)    	 bndrs = foldr collectl bndrs pats
-collect (TuplePat pats _)  	 bndrs = foldr collectl bndrs pats
-
-collect (ConPatIn c ps)   	 bndrs = foldr collectl bndrs (hsConArgs ps)
-collect (ConPatOut c ps _ _ ds)	 bndrs = map noLoc ds
-					  ++ foldr collectl bndrs (hsConArgs ps)
-
-collect (LitPat _)	      	 bndrs = bndrs
-collect (NPatIn _ _)		 bndrs = bndrs
-collect (NPatOut _ _ _)		 bndrs = bndrs
-
-collect (NPlusKPatIn n _ _)      bndrs = n : bndrs
-collect (NPlusKPatOut n _ _ _)   bndrs = n : bndrs
-
-collect (SigPatIn pat _)	 bndrs = collectl pat bndrs
-collect (SigPatOut pat _ _)	 bndrs = collectl pat bndrs
-collect (TypePat ty)             bndrs = bndrs
-collect (DictPat ids1 ids2)      bndrs = map noLoc ids1 ++ map noLoc ids2
-					   ++ bndrs
-\end{code}
-
-\begin{code}
-collectSigTysFromPats :: [InPat name] -> [LHsType name]
-collectSigTysFromPats pats = foldr collect_lpat [] pats
-
-collectSigTysFromPat :: InPat name -> [LHsType name]
-collectSigTysFromPat pat = collect_lpat pat []
-
-collect_lpat pat acc = collect_pat (unLoc pat) acc
-
-collect_pat (SigPatIn pat ty)  acc = collect_lpat pat (ty:acc)
-collect_pat (TypePat ty)       acc = ty:acc
-
-collect_pat (LazyPat pat)      acc = collect_lpat pat acc
-collect_pat (AsPat a pat)      acc = collect_lpat pat acc
-collect_pat (ParPat  pat)      acc = collect_lpat pat acc
-collect_pat (ListPat pats _)   acc = foldr collect_lpat acc pats
-collect_pat (PArrPat pats _)   acc = foldr collect_lpat acc pats
-collect_pat (TuplePat pats _)  acc = foldr collect_lpat acc pats
-collect_pat (ConPatIn c ps)    acc = foldr collect_lpat acc (hsConArgs ps)
-collect_pat other	       acc = acc 	-- Literals, vars, wildcard
-\end{code}
diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs
index fdcc3e29d6..03d414a0e5 100644
--- a/ghc/compiler/hsSyn/HsTypes.lhs
+++ b/ghc/compiler/hsSyn/HsTypes.lhs
@@ -10,6 +10,9 @@ module HsTypes (
 	HsExplicitForAll(..),
 	HsContext, LHsContext,
 	HsPred(..), LHsPred,
+
+	LBangType, BangType, HsBang(..), 
+        getBangType, getBangStrictness, 
 	
 	mkExplicitHsForAllTy, mkImplicitHsForAllTy, 
 	hsTyVarName, hsTyVarNames, replaceTyVarName,
@@ -71,6 +74,35 @@ placeHolderName = mkInternalName unboundKey
 			noSrcLoc
 \end{code}
 
+%************************************************************************
+%*									*
+\subsection{Bang annotations}
+%*									*
+%************************************************************************
+
+\begin{code}
+type LBangType name = Located (BangType name)
+type BangType name  = HsType name	-- Bangs are in the HsType data type
+
+data HsBang = HsNoBang	-- Only used as a return value for getBangStrictness,
+			-- never appears on a HsBangTy
+	    | HsStrict	-- ! 
+	    | HsUnbox	-- {-# UNPACK #-} ! (GHC extension, meaning "unbox")
+
+instance Outputable HsBang where
+    ppr (HsNoBang) = empty
+    ppr (HsStrict) = char '!'
+    ppr (HsUnbox)  = ptext SLIT("!!")
+
+getBangType :: LHsType a -> LHsType a
+getBangType (L _ (HsBangTy _ ty)) = ty
+getBangType ty                    = ty
+
+getBangStrictness :: LHsType a -> HsBang
+getBangStrictness (L _ (HsBangTy s _)) = s
+getBangStrictness _                    = HsNoBang
+\end{code}
+
 
 %************************************************************************
 %*									*
@@ -103,6 +135,8 @@ data HsType name
 
   | HsTyVar		name		-- Type variable or type constructor
 
+  | HsBangTy	HsBang (LHsType name)	-- Bang-style type annotations 
+
   | HsAppTy		(LHsType name)
 			(LHsType name)
 
@@ -210,36 +244,15 @@ splitHsInstDeclTy
     -> ([LHsTyVarBndr name], HsContext name, name, [LHsType name])
 	-- Split up an instance decl type, returning the pieces
 
--- In interface files, the instance declaration head is created
--- by HsTypes.toHsType, which does not guarantee to produce a
--- HsForAllTy.  For example, if we had the weird decl
---	instance Foo T => Foo [T]
--- then we'd get the instance type
---	Foo T -> Foo [T]
--- So when colleting the instance context, to be on the safe side
--- we gather predicate arguments
--- 
--- For source code, the parser ensures the type will have the right shape.
--- (e.g. see ParseUtil.checkInstType)
-
 splitHsInstDeclTy inst_ty
   = case inst_ty of
-	HsForAllTy _ tvs cxt1 tau 	-- The type vars should have been
-					-- computed by now, even if they were implicit
-	      -> (tvs, unLoc cxt1 ++ cxt2, cls, tys)
-	      where
-		 (cxt2, cls, tys) = split_tau (unLoc tau)
-
-	other -> ([],  cxt2,  cls, tys)
-	      where
-		 (cxt2, cls, tys) = split_tau inst_ty
-
+	HsParTy (L _ ty)	      -> splitHsInstDeclTy ty
+	HsForAllTy _ tvs cxt (L _ ty) -> split_tau tvs (unLoc cxt) ty
+	other 			      -> split_tau []  []          other
+    -- The type vars should have been computed by now, even if they were implicit
   where
-    split_tau (HsFunTy (L loc (HsPredTy p)) ty) = (L loc p : ps, cls, tys)
-					where
-					  (ps, cls, tys) = split_tau (unLoc ty)
-    split_tau (HsPredTy (HsClassP cls tys)) = ([], cls, tys)
-    split_tau other = pprPanic "splitHsInstDeclTy" (ppr inst_ty)
+    split_tau tvs cxt (HsPredTy (HsClassP cls tys)) = (tvs, cxt, cls, tys)
+    split_tau tvs cxt (HsParTy (L _ ty))	    = split_tau tvs cxt ty
 \end{code}
 
 
@@ -320,6 +333,8 @@ ppr_mono_ty ctxt_prec (HsForAllTy exp tvs ctxt ty)
   = maybeParen ctxt_prec pREC_FUN $
     sep [pprHsForAll exp tvs ctxt, ppr_mono_lty pREC_TOP ty]
 
+-- gaw 2004
+ppr_mono_ty ctxt_prec (HsBangTy b ty)     = ppr b <> ppr ty
 ppr_mono_ty ctxt_prec (HsTyVar name)      = ppr name
 ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2)   = ppr_fun_ty ctxt_prec ty1 ty2
 ppr_mono_ty ctxt_prec (HsTupleTy con tys) = tupleParens con (interpp'SP tys)
diff --git a/ghc/compiler/hsSyn/HsUtils.lhs b/ghc/compiler/hsSyn/HsUtils.lhs
index b864e16248..582e0f01e3 100644
--- a/ghc/compiler/hsSyn/HsUtils.lhs
+++ b/ghc/compiler/hsSyn/HsUtils.lhs
@@ -52,10 +52,11 @@ just attach noSrcSpan to everything.
 mkHsPar :: LHsExpr id -> LHsExpr id
 mkHsPar e = L (getLoc e) (HsPar e)
 
-mkSimpleMatch :: [LPat id] -> LHsExpr id -> Type -> LMatch id
-mkSimpleMatch pats rhs rhs_ty
+-- gaw 2004
+mkSimpleMatch :: [LPat id] -> LHsExpr id -> LMatch id
+mkSimpleMatch pats rhs 
   = L loc $
-    Match pats Nothing (GRHSs (unguardedRHS rhs) [] rhs_ty)
+    Match pats Nothing (GRHSs (unguardedRHS rhs) [])
   where
     loc = case pats of
 		[]      -> getLoc rhs
@@ -74,13 +75,17 @@ mkHsTyApp :: LHsExpr name -> [Type] -> LHsExpr name
 mkHsTyApp expr []  = expr
 mkHsTyApp expr tys = L (getLoc expr) (TyApp expr tys)
 
+mkHsDictApp :: LHsExpr name -> [name] -> LHsExpr name
 mkHsDictApp expr []	 = expr
 mkHsDictApp expr dict_vars = L (getLoc expr) (DictApp expr dict_vars)
 
 mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
-mkHsLam pats body = mkHsPar (L (getLoc match) (HsLam match))
+mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
 	where
-	  match = mkSimpleMatch pats body placeHolderType
+	  matches = mkMatchGroup [mkSimpleMatch pats body]
+
+mkMatchGroup :: [LMatch id] -> MatchGroup id
+mkMatchGroup matches = MatchGroup matches placeHolderType
 
 mkHsTyLam []     expr = expr
 mkHsTyLam tyvars expr = L (getLoc expr) (TyLam tyvars expr)
@@ -88,10 +93,10 @@ mkHsTyLam tyvars expr = L (getLoc expr) (TyLam tyvars expr)
 mkHsDictLam []    expr = expr
 mkHsDictLam dicts expr = L (getLoc expr) (DictLam dicts expr)
 
-mkHsLet :: Bag (LHsBind name) -> LHsExpr name -> LHsExpr name
+mkHsLet :: LHsBinds name -> LHsExpr name -> LHsExpr name
 mkHsLet binds expr 
-  | isEmptyBag binds = expr
-  | otherwise        = L (getLoc expr) (HsLet [HsBindGroup binds [] Recursive] expr)
+  | isEmptyLHsBinds binds = expr
+  | otherwise             = L (getLoc expr) (HsLet [HsBindGroup binds [] Recursive] expr)
 
 mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
 -- Used for constructing dictinoary terms etc, so no locations 
@@ -103,11 +108,12 @@ mkHsConApp data_con tys args
 mkSimpleHsAlt :: LPat id -> LHsExpr id -> LMatch id
 -- A simple lambda with a single pattern, no binds, no guards; pre-typechecking
 mkSimpleHsAlt pat expr 
-  = mkSimpleMatch [pat] expr placeHolderType
+  = mkSimpleMatch [pat] expr
 
 glueBindsOnGRHSs :: HsBindGroup id -> GRHSs id -> GRHSs id
-glueBindsOnGRHSs binds1 (GRHSs grhss binds2 ty)
-  = GRHSs grhss (binds1 : binds2) ty
+-- gaw 2004
+glueBindsOnGRHSs binds1 (GRHSs grhss binds2)
+  = GRHSs grhss (binds1 : binds2)
 
 -- These are the bits of syntax that contain rebindable names
 -- See RnEnv.lookupSyntaxName
@@ -187,10 +193,10 @@ nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)
 
 nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
 
-nlHsLam	match		= noLoc (HsLam match)
+nlHsLam	match		= noLoc (HsLam (mkMatchGroup [match]))
 nlHsPar e		= noLoc (HsPar e)
 nlHsIf cond true false	= noLoc (HsIf cond true false)
-nlHsCase expr matches	= noLoc (HsCase expr matches)
+nlHsCase expr matches	= noLoc (HsCase expr (mkMatchGroup matches))
 nlTuple exprs box	= noLoc (ExplicitTuple exprs box)
 nlList exprs		= noLoc (ExplicitList placeHolderType exprs)
 
@@ -215,7 +221,7 @@ nlParStmt stuff		= noLoc (ParStmt stuff)
 
 \begin{code}
 mkVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
-mkVarBind loc var rhs = mk_easy_FunBind loc var [] emptyBag rhs
+mkVarBind loc var rhs = mk_easy_FunBind loc var [] emptyLHsBinds rhs
 
 mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
 		    -> LHsBinds RdrName -> LHsExpr RdrName
@@ -223,7 +229,7 @@ mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
 
 mk_easy_FunBind loc fun pats binds expr
   = L loc (FunBind (L loc fun) False{-not infix-} 
-	[mk_easy_Match pats binds expr])
+	  	   (mkMatchGroup [mk_easy_Match pats binds expr]))
 
 mk_easy_Match pats binds expr
   = mkMatch pats expr [HsBindGroup binds [] Recursive]
@@ -239,12 +245,13 @@ mk_FunBind	:: SrcSpan
 mk_FunBind loc fun [] = panic "TcGenDeriv:mk_FunBind"
 mk_FunBind loc fun pats_and_exprs
   = L loc (FunBind (L loc fun) False{-not infix-} 
-			[mkMatch p e [] | (p,e) <-pats_and_exprs])
+		   (mkMatchGroup [mkMatch p e [] | (p,e) <-pats_and_exprs]))
 
 mkMatch :: [LPat id] -> LHsExpr id -> [HsBindGroup id] -> LMatch id
 mkMatch pats expr binds
   = noLoc (Match (map paren pats) Nothing 
-		 (GRHSs (unguardedRHS expr) binds placeHolderType))
+-- gaw 2004
+		 (GRHSs (unguardedRHS expr) binds))
   where
     paren p = case p of
 		L _ (VarPat _) -> p
@@ -278,8 +285,8 @@ collectGroupBinders groups = foldr collect_group [] groups
 
 
 collectAcc :: HsBind name -> [Located name] -> [Located name]
-collectAcc (PatBind pat _) acc = collectLocatedPatBinders pat ++ acc
-collectAcc (FunBind f _ _) acc = f : acc
+collectAcc (PatBind pat _ _) acc = collectLocatedPatBinders pat ++ acc
+collectAcc (FunBind f _ _) acc   = f : acc
 collectAcc (VarBind f _) acc  = noLoc f : acc
 collectAcc (AbsBinds _ _ dbinds _ binds) acc
   = [noLoc dp | (_,dp,_) <- dbinds] ++ acc
@@ -312,15 +319,13 @@ collectSigTysFromHsBind :: LHsBind name -> [LHsType name]
 collectSigTysFromHsBind bind
   = go (unLoc bind)
   where
-    go (PatBind pat _)  = collectSigTysFromPat pat
-    go (FunBind f _ ms) = go_matches (map unLoc ms)
-
+    go (PatBind pat _ _) 
+	= collectSigTysFromPat pat
+    go (FunBind f _ (MatchGroup ms _))
+	= [sig | L _ (Match [] (Just sig) _) <- ms]
 	-- A binding like    x :: a = f y
 	-- is parsed as FunMonoBind, but for this purpose we 	
 	-- want to treat it as a pattern binding
-    go_matches []				 = []
-    go_matches (Match [] (Just sig) _ : matches) = sig : go_matches matches
-    go_matches (match		      : matches) = go_matches matches
 \end{code}
 
 %************************************************************************
@@ -344,3 +349,86 @@ collectStmtBinders (ResultStmt _)     = []
 collectStmtBinders (RecStmt ss _ _ _) = collectStmtsBinders ss
 collectStmtBinders other              = panic "collectStmtBinders"
 \end{code}
+
+
+%************************************************************************
+%*									*
+%* 	Gathering stuff out of patterns
+%*									*
+%************************************************************************
+
+This function @collectPatBinders@ works with the ``collectBinders''
+functions for @HsBinds@, etc.  The order in which the binders are
+collected is important; see @HsBinds.lhs@.
+
+It collects the bounds *value* variables in renamed patterns; type variables
+are *not* collected.
+
+\begin{code}
+collectPatBinders :: LPat a -> [a]
+collectPatBinders pat = map unLoc (collectLocatedPatBinders pat)
+
+collectLocatedPatBinders :: LPat a -> [Located a]
+collectLocatedPatBinders pat = collectl pat []
+
+collectPatsBinders :: [LPat a] -> [a]
+collectPatsBinders pats = map unLoc (collectLocatedPatsBinders pats)
+
+collectLocatedPatsBinders :: [LPat a] -> [Located a]
+collectLocatedPatsBinders pats = foldr collectl [] pats
+
+---------------------
+collectl (L l (VarPat var)) bndrs = L l var : bndrs
+collectl (L l (VarPatOut var bs)) bndrs = L l var : collectHsBindLocatedBinders bs 
+					  ++ bndrs
+collectl (L l pat) bndrs = collect pat bndrs
+
+---------------------
+collect (WildPat _)	      	   bndrs = bndrs
+collect (LazyPat pat)     	   bndrs = collectl pat bndrs
+collect (AsPat a pat)     	   bndrs = a : collectl pat bndrs
+collect (ParPat  pat)     	   bndrs = collectl pat bndrs
+
+collect (ListPat pats _)    	   bndrs = foldr collectl bndrs pats
+collect (PArrPat pats _)    	   bndrs = foldr collectl bndrs pats
+collect (TuplePat pats _)  	   bndrs = foldr collectl bndrs pats
+
+collect (ConPatIn c ps)   	   bndrs = foldr collectl bndrs (hsConArgs ps)
+collect (ConPatOut c _ ds bs ps _) bndrs = map noLoc ds
+					   ++ collectHsBindLocatedBinders bs
+					   ++ foldr collectl bndrs (hsConArgs ps)
+collect (LitPat _)	      	 bndrs = bndrs
+collect (NPatIn _ _)		 bndrs = bndrs
+collect (NPatOut _ _ _)		 bndrs = bndrs
+
+collect (NPlusKPatIn n _ _)      bndrs = n : bndrs
+collect (NPlusKPatOut n _ _ _)   bndrs = n : bndrs
+
+collect (SigPatIn pat _)	 bndrs = collectl pat bndrs
+collect (SigPatOut pat _)	 bndrs = collectl pat bndrs
+collect (TypePat ty)             bndrs = bndrs
+collect (DictPat ids1 ids2)      bndrs = map noLoc ids1 ++ map noLoc ids2
+					   ++ bndrs
+\end{code}
+
+\begin{code}
+collectSigTysFromPats :: [InPat name] -> [LHsType name]
+collectSigTysFromPats pats = foldr collect_lpat [] pats
+
+collectSigTysFromPat :: InPat name -> [LHsType name]
+collectSigTysFromPat pat = collect_lpat pat []
+
+collect_lpat pat acc = collect_pat (unLoc pat) acc
+
+collect_pat (SigPatIn pat ty)  acc = collect_lpat pat (ty:acc)
+collect_pat (TypePat ty)       acc = ty:acc
+
+collect_pat (LazyPat pat)      acc = collect_lpat pat acc
+collect_pat (AsPat a pat)      acc = collect_lpat pat acc
+collect_pat (ParPat  pat)      acc = collect_lpat pat acc
+collect_pat (ListPat pats _)   acc = foldr collect_lpat acc pats
+collect_pat (PArrPat pats _)   acc = foldr collect_lpat acc pats
+collect_pat (TuplePat pats _)  acc = foldr collect_lpat acc pats
+collect_pat (ConPatIn c ps)    acc = foldr collect_lpat acc (hsConArgs ps)
+collect_pat other	       acc = acc 	-- Literals, vars, wildcard
+\end{code}