New syntax for GADT-style record declarations, and associated refactoring

The main purpose of this patch is to fix Trac #3306, by fleshing out the
syntax for GADT-style record declraations so that you have a context in 
the type.  The new form is
   data T a where
     MkT :: forall a. Eq a => { x,y :: !a } -> T a
See discussion on the Trac ticket.

The old form is still allowed, but give a deprecation warning.

When we remove the old form we'll also get rid of the one reduce/reduce
error in the grammar. Hurrah!

While I was at it, I failed as usual to resist the temptation to do lots of
refactoring.  The parsing of data/type declarations is now much simpler and
more uniform.  Less code, less chance of errors, and more functionality.
Took longer than I planned, though.

ConDecl has record syntax, but it was not being used consistently, so I
pushed that through the compiler.

4 files changed, 294 insertions, 364 deletions

diff --git a/compiler/parser/HaddockUtils.hs b/compiler/parser/HaddockUtils.hs
index 70a5da25fe..ea73911c99 100644
--- a/compiler/parser/HaddockUtils.hs
+++ b/compiler/parser/HaddockUtils.hs
@@ -151,17 +151,16 @@ parseKey key toParse0 =
 -- -----------------------------------------------------------------------------
 -- Adding documentation to record fields (used in parsing).
 
-type Field a = ([Located a], LBangType a, Maybe (LHsDoc a))
+addFieldDoc :: ConDeclField a -> Maybe (LHsDoc a) -> ConDeclField a
+addFieldDoc fld doc = fld { cd_fld_doc = cd_fld_doc fld `mplus` doc }
 
-addFieldDoc :: Field a -> Maybe (LHsDoc a) -> Field a
-addFieldDoc (a, b, c) doc = (a, b, c `mplus` doc)
-
-addFieldDocs :: [Field a] -> Maybe (LHsDoc a) -> [Field a]
+addFieldDocs :: [ConDeclField a] -> Maybe (LHsDoc a) -> [ConDeclField a]
 addFieldDocs [] _ = []
 addFieldDocs (x:xs) doc = addFieldDoc x doc : xs
 
 addConDoc :: LConDecl a -> Maybe (LHsDoc a) -> LConDecl a
-addConDoc (L p c) doc = L p ( c { con_doc = con_doc c `mplus` doc } )
+addConDoc decl    Nothing = decl
+addConDoc (L p c) doc     = L p ( c { con_doc = con_doc c `mplus` doc } )
 
 addConDocs :: [LConDecl a] -> Maybe (LHsDoc a) -> [LConDecl a]
 addConDocs [] _ = []
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index ef48bb457a..cbc3bcbf61 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -46,6 +46,7 @@ import SrcLoc		( Located(..), unLoc, getLoc, noLoc, combineSrcSpans,
 import Module
 import StaticFlags	( opt_SccProfilingOn, opt_Hpc )
 import Type		( Kind, mkArrowKind, liftedTypeKind, unliftedTypeKind )
+import Class		( FunDep )
 import BasicTypes	( Boxity(..), Fixity(..), FixityDirection(..), IPName(..),
 			  Activation(..), RuleMatchInfo(..), defaultInlineSpec )
 import DynFlags
@@ -576,15 +577,7 @@ topdecl :: { OrdList (LHsDecl RdrName) }
 -- Type classes
 --
 cl_decl :: { LTyClDecl RdrName }
-	: 'class' tycl_hdr fds where_cls
-		{% do { let { (binds, sigs, ats, docs)           = 
-			        cvBindsAndSigs (unLoc $4)
-		            ; (ctxt, tc, tvs, tparms) = unLoc $2}
-                      ; checkTyVars tparms      -- only type vars allowed
-		      ; checkKindSigs ats
-		      ; return $ L (comb4 $1 $2 $3 $4) 
-				   (mkClassDecl (ctxt, tc, tvs) 
-					        (unLoc $3) sigs binds ats docs) } }
+	: 'class' tycl_hdr fds where_cls	{% mkClassDecl (comb4 $1 $2 $3 $4) $2 $3 $4 }
 
 -- Type declarations (toplevel)
 --
@@ -598,87 +591,53 @@ ty_decl :: { LTyClDecl RdrName }
 	        --
 		-- Note the use of type for the head; this allows
 		-- infix type constructors to be declared 
- 		{% do { (tc, tvs, _) <- checkSynHdr $2 False
-		      ; return (L (comb2 $1 $4) 
-				  (TySynonym tc tvs Nothing $4))
-                      } }
+ 		{% mkTySynonym (comb2 $1 $4) False $2 $4 }
 
            -- type family declarations
         | 'type' 'family' type opt_kind_sig 
 		-- Note the use of type for the head; this allows
 		-- infix type constructors to be declared
-		--
- 		{% do { (tc, tvs, _) <- checkSynHdr $3 False
-		      ; return (L (comb3 $1 $3 $4) 
-				  (TyFamily TypeFamily tc tvs (unLoc $4)))
-		      } }
+ 		{% mkTyFamily (comb3 $1 $3 $4) TypeFamily $3 (unLoc $4) }
 
            -- type instance declarations
         | 'type' 'instance' type '=' ctype
 		-- Note the use of type for the head; this allows
 		-- infix type constructors and type patterns
-		--
- 		{% do { (tc, tvs, typats) <- checkSynHdr $3 True
-		      ; return (L (comb2 $1 $5) 
-				  (TySynonym tc tvs (Just typats) $5)) 
-                      } }
+ 		{% mkTySynonym (comb2 $1 $5) True $3 $5 }
 
           -- ordinary data type or newtype declaration
 	| data_or_newtype tycl_hdr constrs deriving
-		{% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}
-                      ; checkTyVars tparms    -- no type pattern
-		      ; return $!
-			  sL (comb4 $1 $2 $3 $4)
+		{% mkTyData (comb4 $1 $2 $3 $4) (unLoc $1) False $2 
+                            Nothing (reverse (unLoc $3)) (unLoc $4) }
 			           -- We need the location on tycl_hdr in case 
 				   -- constrs and deriving are both empty
-			    (mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing) 
-			       Nothing (reverse (unLoc $3)) (unLoc $4)) } }
 
           -- ordinary GADT declaration
         | data_or_newtype tycl_hdr opt_kind_sig 
 		 'where' gadt_constrlist
 		 deriving
-		{% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}
-                      ; checkTyVars tparms    -- can have type pats
-		      ; return $!
-			  sL (comb4 $1 $2 $4 $5)
-			    (mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing) 
-			      (unLoc $3) (reverse (unLoc $5)) (unLoc $6)) } }
+		{% mkTyData (comb4 $1 $2 $4 $5) (unLoc $1) False $2 
+                            (unLoc $3) (reverse (unLoc $5)) (unLoc $6) }
+			           -- We need the location on tycl_hdr in case 
+				   -- constrs and deriving are both empty
 
           -- data/newtype family
-        | 'data' 'family' tycl_hdr opt_kind_sig
-		{% do { let {(ctxt, tc, tvs, tparms) = unLoc $3}
-                      ; checkTyVars tparms            -- no type pattern
-		      ; unless (null (unLoc ctxt)) $  -- and no context
-			  parseError (getLoc ctxt) 
-			    "A family declaration cannot have a context"
-		      ; return $
-			  L (comb3 $1 $2 $4)
-			    (TyFamily DataFamily tc tvs (unLoc $4)) } }
+        | 'data' 'family' type opt_kind_sig
+		{% mkTyFamily (comb3 $1 $2 $4) DataFamily $3 (unLoc $4) }
 
           -- data/newtype instance declaration
 	| data_or_newtype 'instance' tycl_hdr constrs deriving
-		{% do { let {(ctxt, tc, tvs, tparms) = unLoc $3}
-                                             -- can have type pats
-		      ; return $
-			  L (comb4 $1 $3 $4 $5)
-			           -- We need the location on tycl_hdr in case 
-				   -- constrs and deriving are both empty
-			    (mkTyData (unLoc $1) (ctxt, tc, tvs, Just tparms) 
-			      Nothing (reverse (unLoc $4)) (unLoc $5)) } }
+		{% mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) True $3
+			    Nothing (reverse (unLoc $4)) (unLoc $5) }
 
           -- GADT instance declaration
         | data_or_newtype 'instance' tycl_hdr opt_kind_sig 
 		 'where' gadt_constrlist
 		 deriving
-		{% do { let {(ctxt, tc, tvs, tparms) = unLoc $3}
-                                             -- can have type pats
-		      ; return $
-			  L (comb4 $1 $3 $6 $7)
-			    (mkTyData (unLoc $1) (ctxt, tc, tvs, Just tparms) 
-			       (unLoc $4) (reverse (unLoc $6)) (unLoc $7)) } }
-
--- Associate type family declarations
+		{% mkTyData (comb4 $1 $3 $6 $7) (unLoc $1) True $3
+			    (unLoc $4) (reverse (unLoc $6)) (unLoc $7) }
+
+-- Associated type family declarations
 --
 -- * They have a different syntax than on the toplevel (no family special
 --   identifier).
@@ -692,68 +651,38 @@ at_decl_cls :: { LTyClDecl RdrName }
         : 'type' type opt_kind_sig
 		-- Note the use of type for the head; this allows
 		-- infix type constructors to be declared
-		--
- 		{% do { (tc, tvs, _) <- checkSynHdr $2 False
-		      ; return (L (comb3 $1 $2 $3) 
-				  (TyFamily TypeFamily tc tvs (unLoc $3)))
-		      } }
+ 		{% mkTyFamily (comb3 $1 $2 $3) TypeFamily $2 (unLoc $3) }
 
            -- default type instance
         | 'type' type '=' ctype
 		-- Note the use of type for the head; this allows
 		-- infix type constructors and type patterns
-		--
- 		{% do { (tc, tvs, typats) <- checkSynHdr $2 True
-		      ; return (L (comb2 $1 $4) 
-				  (TySynonym tc tvs (Just typats) $4)) 
-                      } }
+ 		{% mkTySynonym (comb2 $1 $4) True $2 $4 }
 
           -- data/newtype family declaration
-        | 'data' tycl_hdr opt_kind_sig
-		{% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}
-                      ; checkTyVars tparms            -- no type pattern
-		      ; unless (null (unLoc ctxt)) $  -- and no context
-			  parseError (getLoc ctxt) 
-			    "A family declaration cannot have a context"
-		      ; return $
-			  L (comb3 $1 $2 $3)
-			    (TyFamily DataFamily tc tvs (unLoc $3)) 
-                      } }
-
--- Associate type instances
+        | 'data' type opt_kind_sig
+		{% mkTyFamily (comb3 $1 $2 $3) DataFamily $2 (unLoc $3) }
+
+-- Associated type instances
 --
 at_decl_inst :: { LTyClDecl RdrName }
            -- type instance declarations
         : 'type' type '=' ctype
 		-- Note the use of type for the head; this allows
 		-- infix type constructors and type patterns
-		--
- 		{% do { (tc, tvs, typats) <- checkSynHdr $2 True
-		      ; return (L (comb2 $1 $4) 
-				  (TySynonym tc tvs (Just typats) $4)) 
-                      } }
+ 		{% mkTySynonym (comb2 $1 $4) True $2 $4 }
 
         -- data/newtype instance declaration
 	| data_or_newtype tycl_hdr constrs deriving
-		{% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}
-                                             -- can have type pats
-		      ; return $
-			  L (comb4 $1 $2 $3 $4)
-			           -- We need the location on tycl_hdr in case 
-				   -- constrs and deriving are both empty
-			    (mkTyData (unLoc $1) (ctxt, tc, tvs, Just tparms) 
-			      Nothing (reverse (unLoc $3)) (unLoc $4)) } }
+		{% mkTyData (comb4 $1 $2 $3 $4) (unLoc $1) True $2 
+                            Nothing (reverse (unLoc $3)) (unLoc $4) }
 
         -- GADT instance declaration
         | data_or_newtype tycl_hdr opt_kind_sig 
 		 'where' gadt_constrlist
 		 deriving
-		{% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}
-                                             -- can have type pats
-		      ; return $
-			  L (comb4 $1 $2 $5 $6)
-			    (mkTyData (unLoc $1) (ctxt, tc, tvs, Just tparms) 
-			     (unLoc $3) (reverse (unLoc $5)) (unLoc $6)) } }
+		{% mkTyData (comb4 $1 $2 $5 $6) (unLoc $1) True $2 
+		   	    (unLoc $3) (reverse (unLoc $5)) (unLoc $6) }
 
 data_or_newtype :: { Located NewOrData }
 	: 'data'	{ L1 DataType }
@@ -770,12 +699,9 @@ opt_kind_sig :: { Located (Maybe Kind) }
 --	(Eq a, Ord b) => T a b
 --      T Int [a]			-- for associated types
 -- Rather a lot of inlining here, else we get reduce/reduce errors
-tycl_hdr :: { Located (LHsContext RdrName, 
-		       Located RdrName, 
-		       [LHsTyVarBndr RdrName],
-		       [LHsType RdrName]) }
-	: context '=>' type		{% checkTyClHdr $1         $3 >>= return.LL }
-	| type                          {% checkTyClHdr (noLoc []) $1 >>= return.L1 }
+tycl_hdr :: { Located (LHsContext RdrName, LHsType RdrName) }
+	: context '=>' type		{ LL ($1, $3) }
+	| type                          { L1 (noLoc [], $1) }
 
 -----------------------------------------------------------------------------
 -- Stand-alone deriving
@@ -979,15 +905,12 @@ opt_asig :: { Maybe (LHsType RdrName) }
 	: {- empty -}			{ Nothing }
 	| '::' atype			{ Just $2 }
 
-sigtypes1 :: { [LHsType RdrName] }
-	: sigtype			{ [ $1 ] }
-	| sigtype ',' sigtypes1		{ $1 : $3 }
-
-sigtype :: { LHsType RdrName }
+sigtype :: { LHsType RdrName }		-- Always a HsForAllTy,
+                                        -- to tell the renamer where to generalise
 	: ctype				{ L1 (mkImplicitHsForAllTy (noLoc []) $1) }
 	-- Wrap an Implicit forall if there isn't one there already
 
-sigtypedoc :: { LHsType RdrName }
+sigtypedoc :: { LHsType RdrName }       -- Always a HsForAllTy
 	: ctypedoc			{ L1 (mkImplicitHsForAllTy (noLoc []) $1) }
 	-- Wrap an Implicit forall if there isn't one there already
 
@@ -995,6 +918,10 @@ sig_vars :: { Located [Located RdrName] }
 	 : sig_vars ',' var		{ LL ($3 : unLoc $1) }
 	 | var				{ L1 [$1] }
 
+sigtypes1 :: { [LHsType RdrName] }	-- Always HsForAllTys
+	: sigtype			{ [ $1 ] }
+	| sigtype ',' sigtypes1		{ $1 : $3 }
+
 -----------------------------------------------------------------------------
 -- Types
 
@@ -1073,7 +1000,8 @@ btype :: { LHsType RdrName }
 atype :: { LHsType RdrName }
 	: gtycon			{ L1 (HsTyVar (unLoc $1)) }
 	| tyvar				{ L1 (HsTyVar (unLoc $1)) }
-	| strict_mark atype		{ LL (HsBangTy (unLoc $1) $2) }
+	| strict_mark atype		{ LL (HsBangTy (unLoc $1) $2) }  -- Constructor sigs only
+	| '{' fielddecls '}'		{ LL $ HsRecTy $2 }              -- Constructor sigs only
 	| '(' ctype ',' comma_types1 ')'  { LL $ HsTupleTy Boxed  ($2:$4) }
 	| '(#' comma_types1 '#)'	{ LL $ HsTupleTy Unboxed $2     }
 	| '[' ctype ']'			{ LL $ HsListTy  $2 }
@@ -1115,15 +1043,15 @@ tv_bndr :: { LHsTyVarBndr RdrName }
 	| '(' tyvar '::' kind ')'	{ LL (KindedTyVar (unLoc $2) 
 							  (unLoc $4)) }
 
-fds :: { Located [Located ([RdrName], [RdrName])] }
+fds :: { Located [Located (FunDep RdrName)] }
 	: {- empty -}			{ noLoc [] }
 	| '|' fds1			{ LL (reverse (unLoc $2)) }
 
-fds1 :: { Located [Located ([RdrName], [RdrName])] }
+fds1 :: { Located [Located (FunDep RdrName)] }
 	: fds1 ',' fd			{ LL ($3 : unLoc $1) }
 	| fd				{ L1 [$1] }
 
-fd :: { Located ([RdrName], [RdrName]) }
+fd :: { Located (FunDep RdrName) }
 	: varids0 '->' varids0		{ L (comb3 $1 $2 $3)
 					   (reverse (unLoc $1), reverse (unLoc $3)) }
 
@@ -1165,21 +1093,11 @@ gadt_constrs :: { Located [LConDecl RdrName] }
 gadt_constr :: { [LConDecl RdrName] }
         : con_list '::' sigtype
                 { map (sL (comb2 $1 $3)) (mkGadtDecl (unLoc $1) $3) } 
-        -- Syntax: Maybe merge the record stuff with the single-case above?
-        --         (to kill the mostly harmless reduce/reduce error)
-        -- XXX revisit audreyt
-	| constr_stuff_record '::' sigtype
-		{ let (con,details) = unLoc $1 in 
-		  [LL (ConDecl con Implicit [] (noLoc []) details (ResTyGADT $3) Nothing)] }
-{-
-	| forall context '=>' constr_stuff_record '::' sigtype
-		{ let (con,details) = unLoc $4 in 
-		  LL (ConDecl con Implicit (unLoc $1) $2 details (ResTyGADT $6) Nothing ) }
-	| forall constr_stuff_record '::' sigtype
-		{ let (con,details) = unLoc $2 in 
-		  LL (ConDecl con Implicit (unLoc $1) (noLoc []) details (ResTyGADT $4) Nothing) }
--}
 
+		-- Deprecated syntax for GADT record declarations
+	| oqtycon '{' fielddecls '}' '::' sigtype
+		{% do { cd <- mkDeprecatedGadtRecordDecl (comb2 $1 $6) $1 $3 $6
+                      ; return [cd] } }
 
 constrs :: { Located [LConDecl RdrName] }
         : {- empty; a GHC extension -}  { noLoc [] }
@@ -1192,10 +1110,12 @@ constrs1 :: { Located [LConDecl RdrName] }
 constr :: { LConDecl RdrName }
 	: maybe_docnext forall context '=>' constr_stuff maybe_docprev	
 		{ let (con,details) = unLoc $5 in 
-		  L (comb4 $2 $3 $4 $5) (ConDecl con Explicit (unLoc $2) $3 details ResTyH98 ($1 `mplus` $6)) }
+		  addConDoc (L (comb4 $2 $3 $4 $5) (mkSimpleConDecl con (unLoc $2) $3 details))
+                            ($1 `mplus` $6) }
 	| maybe_docnext forall constr_stuff maybe_docprev
 		{ let (con,details) = unLoc $3 in 
-		  L (comb2 $2 $3) (ConDecl con Explicit (unLoc $2) (noLoc []) details ResTyH98 ($1 `mplus` $4)) }
+		  addConDoc (L (comb2 $2 $3) (mkSimpleConDecl con (unLoc $2) (noLoc []) details))
+                            ($1 `mplus` $4) }
 
 forall :: { Located [LHsTyVarBndr RdrName] }
 	: 'forall' tv_bndrs '.'		{ LL $2 }
@@ -1209,21 +1129,22 @@ constr_stuff :: { Located (Located RdrName, HsConDeclDetails RdrName) }
 --	C t1 t2 %: D Int
 -- in which case C really would be a type constructor.  We can't resolve this
 -- ambiguity till we come across the constructor oprerator :% (or not, more usually)
-	: btype				{% mkPrefixCon $1 [] >>= return.LL }
-	| oqtycon '{' '}' 		{% mkRecCon $1 [] >>= return.LL }
-	| oqtycon '{' fielddecls '}' 	{% mkRecCon $1 $3 >>= return.LL }
-	| btype conop btype		{ LL ($2, InfixCon $1 $3) }
-
-constr_stuff_record :: { Located (Located RdrName, HsConDeclDetails RdrName) }
-	: oqtycon '{' '}' 		{% mkRecCon $1 [] >>= return.sL (comb2 $1 $>) }
-	| oqtycon '{' fielddecls '}' 	{% mkRecCon $1 $3 >>= return.sL (comb2 $1 $>) }
-
-fielddecls :: { [([Located RdrName], LBangType RdrName, Maybe (LHsDoc RdrName))] }
-	: fielddecl maybe_docnext ',' maybe_docprev fielddecls { addFieldDoc (unLoc $1) $4 : addFieldDocs $5 $2 }
-	| fielddecl			                       { [unLoc $1] }
-
-fielddecl :: { Located ([Located RdrName], LBangType RdrName, Maybe (LHsDoc RdrName)) }
-	: maybe_docnext sig_vars '::' ctype maybe_docprev      { L (comb3 $2 $3 $4) (reverse (unLoc $2), $4, $1 `mplus` $5) }
+	: btype				{% splitCon $1 >>= return.LL }
+	| btype conop btype		{  LL ($2, InfixCon $1 $3) }
+
+fielddecls :: { [ConDeclField RdrName] }
+        : {- empty -}     { [] }
+        | fielddecls1     { $1 }
+
+fielddecls1 :: { [ConDeclField RdrName] }
+	: fielddecl maybe_docnext ',' maybe_docprev fielddecls1
+                      { [ addFieldDoc f $4 | f <- $1 ] ++ addFieldDocs $5 $2 }
+                             -- This adds the doc $4 to each field separately
+	| fielddecl   { $1 }
+
+fielddecl :: { [ConDeclField RdrName] }    -- A list because of   f,g :: Int
+	: maybe_docnext sig_vars '::' ctype maybe_docprev      { [ ConDeclField fld $4 ($1 `mplus` $5) 
+                                                                 | fld <- reverse (unLoc $2) ] }
 
 -- We allow the odd-looking 'inst_type' in a deriving clause, so that
 -- we can do deriving( forall a. C [a] ) in a newtype (GHC extension).
diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y
index bf959468fe..0f2bb97a1c 100644
--- a/compiler/parser/ParserCore.y
+++ b/compiler/parser/ParserCore.y
@@ -124,18 +124,18 @@ tdefs	:: { [TyClDecl RdrName] }
 
 tdef	:: { TyClDecl RdrName }
 	: '%data' q_tc_name tv_bndrs '=' '{' cons '}' ';'
-                { mkTyData DataType ( noLoc []
-				    , noLoc (ifaceExtRdrName $2)
-				    , map toHsTvBndr $3
-				    , Nothing
-				    ) Nothing $6 Nothing }
+	{ TyData { tcdND = DataType, tcdCtxt = noLoc [] 
+	         , tcdLName = noLoc (ifaceExtRdrName $2)
+	         , tcdTyVars = map toHsTvBndr $3
+	         , tcdTyPats = Nothing, tcdKindSig = Nothing
+	         , tcdCons = $6, tcdDerivs = Nothing } }
 	| '%newtype' q_tc_name tv_bndrs trep ';'
 		{ let tc_rdr = ifaceExtRdrName $2 in
-                  mkTyData NewType ( noLoc []
-				   , noLoc tc_rdr
-				   , map toHsTvBndr $3
-				   , Nothing
-				   ) Nothing ($4 (rdrNameOcc tc_rdr)) Nothing }
+		    TyData { tcdND = NewType, tcdCtxt = noLoc []
+			     , tcdLName = noLoc tc_rdr
+			     , tcdTyVars = map toHsTvBndr $3
+			     , tcdTyPats = Nothing, tcdKindSig = Nothing
+			     , tcdCons = $4 (rdrNameOcc tc_rdr), tcdDerivs = Nothing } }
 
 -- For a newtype we have to invent a fake data constructor name
 -- It doesn't matter what it is, because it won't be used
@@ -143,8 +143,8 @@ trep    :: { OccName -> [LConDecl RdrName] }
         : {- empty -}   { (\ tc_occ -> []) }
         | '=' ty        { (\ tc_occ -> let { dc_name  = mkRdrUnqual (setOccNameSpace dataName tc_occ) ;
 			                     con_info = PrefixCon [toHsType $2] }
-			                in [noLoc $ ConDecl (noLoc dc_name) Explicit []
-					   (noLoc []) con_info ResTyH98 Nothing]) }
+			                in [noLoc $ mkSimpleConDecl (noLoc dc_name) []
+					               (noLoc []) con_info]) }
 
 cons	:: { [LConDecl RdrName] }
 	: {- empty -}	{ [] } -- 20060420 Empty data types allowed. jds
@@ -153,15 +153,8 @@ cons	:: { [LConDecl RdrName] }
 
 con	:: { LConDecl RdrName }
 	: d_pat_occ attv_bndrs hs_atys 
-		{ noLoc $ ConDecl (noLoc (mkRdrUnqual $1)) Explicit $2 (noLoc []) (PrefixCon $3) ResTyH98 Nothing }
-        | d_pat_occ '::' ty
-                -- XXX - audreyt - $3 needs to be split into argument and return types!
-                -- also not sure whether the [] below (quantified vars) appears.
-                -- also the "PrefixCon []" is wrong.
-                -- also we want to munge $3 somehow.
-                -- extractWhatEver to unpack ty into the parts to ConDecl
-                -- XXX - define it somewhere in RdrHsSyn
-		{ noLoc $ ConDecl (noLoc (mkRdrUnqual $1)) Explicit [] (noLoc []) (PrefixCon []) (undefined $3) Nothing }
+		{ noLoc $ mkSimpleConDecl (noLoc (mkRdrUnqual $1)) $2 (noLoc []) (PrefixCon $3) }
+-- ToDo: parse record-style declarations
 
 attv_bndrs :: { [LHsTyVarBndr RdrName] }
 	: {- empty -} 	         { [] }
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index bd8299b9bb..779b67b80c 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -8,10 +8,11 @@ module RdrHsSyn (
 	extractHsTyRdrTyVars, 
 	extractHsRhoRdrTyVars, extractGenericPatTyVars,
  
-	mkHsOpApp, mkClassDecl,
+	mkHsOpApp, 
 	mkHsIntegral, mkHsFractional, mkHsIsString,
 	mkHsDo, mkHsSplice,
-        mkTyData, mkPrefixCon, mkRecCon, mkInlineSpec,	
+        mkClassDecl, mkTyData, mkTyFamily, mkTySynonym,
+        splitCon, mkInlineSpec,	
 	mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
 
 	cvBindGroup,
@@ -29,16 +30,15 @@ module RdrHsSyn (
 			      -- -> P RdrNameHsDecl
 	mkExtName,           -- RdrName -> CLabelString
 	mkGadtDecl,          -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName
+	mkSimpleConDecl, 
+	mkDeprecatedGadtRecordDecl,
 			      
 	-- Bunch of functions in the parser monad for 
 	-- checking and constructing values
 	checkPrecP, 	      -- Int -> P Int
 	checkContext,	      -- HsType -> P HsContext
 	checkPred,	      -- HsType -> P HsPred
-	checkTyClHdr,         -- LHsContext RdrName -> LHsType RdrName
-                              -- -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName])
 	checkTyVars,          -- [LHsType RdrName] -> P ()
-	checkSynHdr,	      -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName])
 	checkKindSigs,	      -- [LTyClDecl RdrName] -> P ()
 	checkInstType,	      -- HsType -> P HsType
         checkDerivDecl,       -- LDerivDecl RdrName -> P (LDerivDecl RdrName)
@@ -76,7 +76,6 @@ import Outputable
 import FastString
 
 import List		( isSuffixOf, nubBy )
-import Monad		( unless )
 
 #include "HsVersions.h"
 \end{code}
@@ -95,6 +94,9 @@ It's used when making the for-alls explicit.
 extractHsTyRdrTyVars :: LHsType RdrName -> [Located RdrName]
 extractHsTyRdrTyVars ty = nubBy eqLocated (extract_lty ty [])
 
+extractHsTysRdrTyVars :: [LHsType RdrName] -> [Located RdrName]
+extractHsTysRdrTyVars ty = nubBy eqLocated (extract_ltys ty [])
+
 extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrName]
 -- This one takes the context and tau-part of a 
 -- sigma type and returns their free type variables
@@ -105,19 +107,23 @@ extract_lctxt :: Located [LHsPred RdrName] -> [Located RdrName] -> [Located RdrN
 extract_lctxt ctxt acc = foldr (extract_pred . unLoc) acc (unLoc ctxt)
 
 extract_pred :: HsPred RdrName -> [Located RdrName] -> [Located RdrName]
-extract_pred (HsClassP _   tys) acc = foldr extract_lty acc tys
+extract_pred (HsClassP _   tys) acc = extract_ltys tys acc
 extract_pred (HsEqualP ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
 extract_pred (HsIParam _   ty ) acc = extract_lty ty acc
 
+extract_ltys :: [LHsType RdrName] -> [Located RdrName] -> [Located RdrName]
+extract_ltys tys acc = foldr extract_lty acc tys
+
 extract_lty :: LHsType RdrName -> [Located RdrName] -> [Located RdrName]
 extract_lty (L loc ty) acc 
   = case ty of
       HsTyVar tv 	        -> extract_tv loc tv acc
       HsBangTy _ ty            	-> extract_lty ty acc
+      HsRecTy flds            	-> foldr (extract_lty . cd_fld_type) acc flds
       HsAppTy ty1 ty2          	-> extract_lty ty1 (extract_lty ty2 acc)
       HsListTy ty              	-> extract_lty ty acc
       HsPArrTy ty              	-> extract_lty ty acc
-      HsTupleTy _ tys          	-> foldr extract_lty acc tys
+      HsTupleTy _ tys          	-> extract_ltys tys acc
       HsFunTy ty1 ty2          	-> extract_lty ty1 (extract_lty ty2 acc)
       HsPredTy p		-> extract_pred p acc
       HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
@@ -167,35 +173,57 @@ Similarly for mkConDecl, mkClassOpSig and default-method names.
 	*** See "THE NAMING STORY" in HsDecls ****
   
 \begin{code}
-mkClassDecl :: (LHsContext name, Located name, [LHsTyVarBndr name])
-            -> [Located (FunDep name)]
-            -> [LSig name]
-            -> LHsBinds name
-            -> [LTyClDecl name]
-            -> [LDocDecl name]
-            -> TyClDecl name
-mkClassDecl (cxt, cname, tyvars) fds sigs mbinds ats docs
-  = ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars,
-		tcdFDs = fds,  
-		tcdSigs = sigs,
-		tcdMeths = mbinds,
-		tcdATs   = ats,
-		tcdDocs  = docs
-		}
-
-mkTyData :: NewOrData
-         -> (LHsContext name,
-             Located name,
-             [LHsTyVarBndr name],
-             Maybe [LHsType name])
+mkClassDecl :: SrcSpan
+            -> Located (LHsContext RdrName, LHsType RdrName) 
+            -> Located [Located (FunDep RdrName)]
+            -> Located (OrdList (LHsDecl RdrName))
+	    -> P (LTyClDecl RdrName)
+
+mkClassDecl loc (L _ (cxt, tycl_hdr)) fds where_cls
+  = do { let (binds, sigs, ats, docs) = cvBindsAndSigs (unLoc where_cls)
+       ; (cls, tparams) <- checkTyClHdr tycl_hdr
+       ; tyvars <- checkTyVars tparams      -- Only type vars allowed
+       ; checkKindSigs ats
+       ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars,
+		             	    tcdFDs = unLoc fds, tcdSigs = sigs, tcdMeths = binds,
+			     	    tcdATs   = ats, tcdDocs  = docs })) }
+
+mkTyData :: SrcSpan
+         -> NewOrData
+	 -> Bool		-- True <=> data family instance
+         -> Located (LHsContext RdrName, LHsType RdrName)
          -> Maybe Kind
-         -> [LConDecl name]
-         -> Maybe [LHsType name]
-         -> TyClDecl name
-mkTyData new_or_data (context, tname, tyvars, typats) ksig data_cons maybe_deriv
-  = TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname,
-	     tcdTyVars = tyvars, tcdTyPats = typats, tcdCons = data_cons, 
-	     tcdKindSig = ksig, tcdDerivs = maybe_deriv }
+         -> [LConDecl RdrName]
+         -> Maybe [LHsType RdrName]
+         -> P (LTyClDecl RdrName)
+mkTyData loc new_or_data is_family (L _ (cxt, tycl_hdr)) ksig data_cons maybe_deriv
+  = do { (tc, tparams) <- checkTyClHdr tycl_hdr
+
+       ; (tyvars, typats) <- checkTParams is_family tparams
+       ; return (L loc (TyData { tcdND = new_or_data, tcdCtxt = cxt, tcdLName = tc,
+	                  	 tcdTyVars = tyvars, tcdTyPats = typats, 
+                                 tcdCons = data_cons, 
+	                  	 tcdKindSig = ksig, tcdDerivs = maybe_deriv })) }
+
+mkTySynonym :: SrcSpan 
+            -> Bool	        -- True <=> type family instances
+            -> LHsType RdrName  -- LHS
+            -> LHsType RdrName	-- RHS
+            -> P (LTyClDecl RdrName)
+mkTySynonym loc is_family lhs rhs
+  = do { (tc, tparams) <- checkTyClHdr lhs
+       ; (tyvars, typats) <- checkTParams is_family tparams
+       ; return (L loc (TySynonym tc tyvars typats rhs)) }
+
+mkTyFamily :: SrcSpan
+           -> FamilyFlavour
+	   -> LHsType RdrName   -- LHS
+	   -> Maybe Kind        -- Optional kind signature
+           -> P (LTyClDecl RdrName)
+mkTyFamily loc flavour lhs ksig
+  = do { (tc, tparams) <- checkTyClHdr lhs
+       ; tyvars <- checkTyVars tparams
+       ; return (L loc (TyFamily flavour tc tyvars ksig)) }
 \end{code}
 
 %************************************************************************
@@ -376,29 +404,88 @@ add_sig _ (ValBindsOut {})     = panic "RdrHsSyn:add_sig"
 
 \begin{code}
 -----------------------------------------------------------------------------
--- mkPrefixCon
+-- splitCon
 
 -- When parsing data declarations, we sometimes inadvertently parse
 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
 -- This function splits up the type application, adds any pending
 -- arguments, and converts the type constructor back into a data constructor.
 
-mkPrefixCon :: LHsType RdrName -> [LBangType RdrName]
-	    -> P (Located RdrName, HsConDeclDetails RdrName)
-mkPrefixCon ty tys
- = split ty tys
+splitCon :: LHsType RdrName
+      -> P (Located RdrName, HsConDeclDetails RdrName)
+-- This gets given a "type" that should look like
+--      C Int Bool
+-- or   C { x::Int, y::Bool }
+-- and returns the pieces
+splitCon ty
+ = split ty []
  where
    split (L _ (HsAppTy t u)) ts = split t (u : ts)
    split (L l (HsTyVar tc))  ts = do data_con <- tyConToDataCon l tc
-				     return (data_con, PrefixCon ts)
-   split (L l _) _ 		= parseError l "parse error in data/newtype declaration"
+ 				     return (data_con, mk_rest ts)
+   split (L l _) _ 	        = parseError l "parse error in data/newtype declaration"
+
+   mk_rest [L _ (HsRecTy flds)] = RecCon flds
+   mk_rest ts                   = PrefixCon ts
+
+mkDeprecatedGadtRecordDecl :: SrcSpan 
+		     	   -> Located RdrName
+		     	   -> [ConDeclField RdrName]
+			   -> LHsType RdrName
+		     	   ->  P (LConDecl  RdrName)
+-- This one uses the deprecated syntax
+--    C { x,y ::Int } :: T a b
+-- We give it a RecCon details right away
+mkDeprecatedGadtRecordDecl loc (L con_loc con) flds res_ty
+  = do { data_con <- tyConToDataCon con_loc con
+       ; return (L loc (ConDecl { con_old_rec  = True
+                                , con_name     = data_con
+	    	 		, con_explicit = Implicit
+	    	 		, con_qvars    = []
+	    	 		, con_cxt      = noLoc []
+	    	 		, con_details  = RecCon flds
+	    	 		, con_res      = ResTyGADT res_ty
+            	 		, con_doc      = Nothing })) }
+
+mkSimpleConDecl :: Located RdrName -> [LHsTyVarBndr RdrName]
+		-> LHsContext RdrName -> HsConDeclDetails RdrName
+		-> ConDecl RdrName
+
+mkSimpleConDecl name qvars cxt details
+  = ConDecl { con_old_rec  = False
+            , con_name     = name
+	    , con_explicit = Explicit
+	    , con_qvars    = qvars
+	    , con_cxt      = cxt
+	    , con_details  = details
+	    , con_res      = ResTyH98
+            , con_doc      = Nothing }
 
-mkRecCon :: Located RdrName -> 
-            [([Located RdrName], LBangType RdrName, Maybe (LHsDoc RdrName))] ->
-            P (Located RdrName, HsConDeclDetails RdrName)
-mkRecCon (L loc con) fields
-  = do data_con <- tyConToDataCon loc con
-       return (data_con, RecCon [ ConDeclField l t d | (ls, t, d) <- fields, l <- ls ])
+mkGadtDecl :: [Located RdrName]
+           -> LHsType RdrName     -- Always a HsForAllTy
+           -> [ConDecl RdrName]
+-- We allow C,D :: ty
+-- and expand it as if it had been 
+--    C :: ty; D :: ty
+-- (Just like type signatures in general.)
+mkGadtDecl names (L _ (HsForAllTy imp qvars cxt tau))
+  = [mk_gadt_con name | name <- names]
+  where
+    (details, res_ty)		-- See Note [Sorting out the result type]
+      = case tau of
+    	  L _ (HsFunTy (L _ (HsRecTy flds)) res_ty) -> (RecCon flds,  res_ty)
+	  _other                                    -> (PrefixCon [], tau)
+
+    mk_gadt_con name
+       = ConDecl { con_old_rec  = False
+                 , con_name     = name
+	    	 , con_explicit = imp
+	    	 , con_qvars    = qvars
+	    	 , con_cxt      = cxt
+	    	 , con_details  = details
+	    	 , con_res      = ResTyGADT res_ty
+            	 , con_doc      = Nothing }
+mkGadtDecl _ other_ty = pprPanic "mkGadtDecl" (ppr other_ty)
 
 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
 tyConToDataCon loc tc
@@ -411,7 +498,26 @@ tyConToDataCon loc tc
     extra | tc == forall_tv_RDR
 	  = text "Perhaps you intended to use -XExistentialQuantification"
 	  | otherwise = empty
+\end{code}
+
+Note [Sorting out the result type]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In a GADT declaration which is not a record, we put the whole constr
+type into the ResTyGADT for now; the renamer will unravel it once it
+has sorted out operator fixities. Consider for example
+     C :: a :*: b -> a :*: b -> a :+: b
+Initially this type will parse as
+      a :*: (b -> (a :*: (b -> (a :+: b))))
+
+so it's hard to split up the arguments until we've done the precedence
+resolution (in the renamer) On the other hand, for a record
+	{ x,y :: Int } -> a :*: b
+there is no doubt.  AND we need to sort records out so that
+we can bring x,y into scope.  So:
+   * For PrefixCon we keep all the args in the ResTyGADT
+   * For RecCon we do not
 
+\begin{code}
 ----------------------------------------------------------------------------
 -- Various Syntactic Checks
 
@@ -436,128 +542,69 @@ checkDictTy (L spn ty) = check ty []
   check (HsParTy t)   args = check (unLoc t) args
   check _ _ = parseError spn "Malformed instance header"
 
+checkTParams :: Bool	  -- Type/data family
+	     -> [LHsType RdrName]
+	     -> P ([LHsTyVarBndr RdrName], Maybe [LHsType RdrName])
+-- checkTParams checks the type parameters of a data/newtype declaration
+-- There are two cases:
+--
+--  a) Vanilla data/newtype decl. In that case 
+--        - the type parameters should all be type variables
+--        - they may have a kind annotation
+--
+--  b) Family data/newtype decl.  In that case
+--        - The type parameters may be arbitrary types
+--        - We find the type-varaible binders by find the 
+--          free type vars of those types
+--        - We make them all kind-sig-free binders (UserTyVar)
+--          If there are kind sigs in the type parameters, they
+--          will fix the binder's kind when we kind-check the 
+--          type parameters
+checkTParams is_family tparams
+  | not is_family        -- Vanilla case (a)
+  = do { tyvars <- checkTyVars tparams
+       ; return (tyvars, Nothing) }
+  | otherwise		 -- Family case (b)
+  = do { let tyvars = [L l (UserTyVar tv) 
+                      | L l tv <- extractHsTysRdrTyVars tparams]
+       ; return (tyvars, Just tparams) }
+
+checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
 -- Check whether the given list of type parameters are all type variables
 -- (possibly with a kind signature).  If the second argument is `False',
 -- only type variables are allowed and we raise an error on encountering a
 -- non-variable; otherwise, we allow non-variable arguments and return the
 -- entire list of parameters.
---
-checkTyVars :: [LHsType RdrName] -> P ()
-checkTyVars tparms = mapM_ chk tparms
+checkTyVars tparms = mapM chk tparms
   where
 	-- Check that the name space is correct!
-    chk (L _ (HsKindSig (L _ (HsTyVar tv)) _))
-	| isRdrTyVar tv    = return ()
-    chk (L _ (HsTyVar tv))
-        | isRdrTyVar tv    = return ()
+    chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
+	| isRdrTyVar tv    = return (L l (KindedTyVar tv k))
+    chk (L l (HsTyVar tv))
+        | isRdrTyVar tv    = return (L l (UserTyVar tv))
     chk (L l _)            =
 	  parseError l "Type found where type variable expected"
 
--- Check whether the type arguments in a type synonym head are simply
--- variables.  If not, we have a type family instance and return all patterns.
--- If yes, we return 'Nothing' as the third component to indicate a vanilla
--- type synonym. 
---
-checkSynHdr :: LHsType RdrName 
-	    -> Bool                             -- is type instance?
-	    -> P (Located RdrName,		-- head symbol
-	          [LHsTyVarBndr RdrName],	-- parameters
-		  [LHsType RdrName])	        -- type patterns
-checkSynHdr ty isTyInst = 
-  do { (_, tc, tvs, tparms) <- checkTyClHdr (noLoc []) ty
-     ; unless isTyInst $ checkTyVars tparms
-     ; return (tc, tvs, tparms) }
-
-
+checkTyClHdr :: LHsType RdrName
+             -> P (Located RdrName,	     -- the head symbol (type or class name)
+	           [LHsType RdrName])        -- parameters of head symbol
 -- Well-formedness check and decomposition of type and class heads.
---
-checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
-  -> P (LHsContext RdrName,	     -- the type context
-        Located RdrName,	     -- the head symbol (type or class name)
-	[LHsTyVarBndr RdrName],	     -- free variables of the non-context part
-	[LHsType RdrName])           -- parameters of head symbol
--- The header of a type or class decl should look like
---	(C a, D b) => T a b
--- or	T a b
--- or	a + b
--- etc
--- With associated types, we can also have non-variable parameters; ie,
---      T Int [a]
--- or   Int :++: [a]
--- The unaltered parameter list is returned in the fourth component of the
--- result.  Eg, for
---      T Int [a]
--- we return
---      ('()', 'T', ['a'], ['Int', '[a]'])
-checkTyClHdr (L l cxt) ty
-  = do (tc, tvs, parms) <- gol ty []
-       mapM_ chk_pred cxt
-       return (L l cxt, tc, tvs, parms)
+-- Decomposes   T ty1 .. tyn   into    (T, [ty1, ..., tyn])
+-- 		Int :*: Bool   into    (:*:, [Int, Bool])
+-- returning the pieces
+checkTyClHdr ty
+  = goL ty []
   where
-    gol (L l ty) acc = go l ty acc
+    goL (L l ty) acc = go l ty acc
 
     go l (HsTyVar tc) acc 
-	| isRdrTc tc 		= do tvs <- extractTyVars acc
-				     return (L l tc, tvs, acc)
+	| isRdrTc tc 	     = return (L l tc, acc)
+				     
     go _ (HsOpTy t1 ltc@(L _ tc) t2) acc
-	| isRdrTc tc		= do tvs <- extractTyVars (t1:t2:acc)
-				     return (ltc, tvs, t1:t2:acc)
-    go _ (HsParTy ty)    acc    = gol ty acc
-    go _ (HsAppTy t1 t2) acc    = gol t1 (t2:acc)
-    go l _               _      =
-      parseError l "Malformed head of type or class declaration"
-
-	-- The predicates in a type or class decl must be class predicates or 
-	-- equational constraints.  They need not all have variable-only
-	-- arguments, even in Haskell 98.  
-	-- E.g. class (Monad m, Monad (t m)) => MonadT t m
-    chk_pred (L _ (HsClassP _ _)) = return ()
-    chk_pred (L _ (HsEqualP _ _)) = return ()
-    chk_pred (L l _)
-       = parseError l "Malformed context in type or class declaration"
-
--- Extract the type variables of a list of type parameters.
---
--- * Type arguments can be complex type terms (needed for associated type
---   declarations).
---
-extractTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
-extractTyVars tvs = collects tvs []
-  where
-        -- Collect all variables (2nd arg serves as an accumulator)
-    collect :: LHsType RdrName -> [LHsTyVarBndr RdrName]
-                               -> P [LHsTyVarBndr RdrName]
-    collect (L l (HsForAllTy _ _ _ _)) =
-      const $ parseError l "Forall type not allowed as type parameter"
-    collect (L l (HsTyVar tv))
-      | isRdrTyVar tv                  = return . (L l (UserTyVar tv) :)
-      | otherwise                      = return
-    collect (L l (HsBangTy _ _      )) =
-      const $ parseError l "Bang-style type annotations not allowed as type parameter"
-    collect (L _ (HsAppTy t1 t2     )) = collect t2 >=> collect t1
-    collect (L _ (HsFunTy t1 t2     )) = collect t2 >=> collect t1
-    collect (L _ (HsListTy t        )) = collect t
-    collect (L _ (HsPArrTy t        )) = collect t
-    collect (L _ (HsTupleTy _ ts    )) = collects ts
-    collect (L _ (HsOpTy t1 _ t2    )) = collect t2 >=> collect t1
-    collect (L _ (HsParTy t         )) = collect t
-    collect (L _ (HsNumTy _         )) = return
-    collect (L l (HsPredTy _        )) = 
-      const $ parseError l "Predicate not allowed as type parameter"
-    collect (L l (HsKindSig (L _ ty) k))
-	| HsTyVar tv <- ty, isRdrTyVar tv
-	= return . (L l (KindedTyVar tv k) :)
-	| otherwise
-	= const $ parseError l "Kind signature only allowed for type variables"
-    collect (L l (HsSpliceTy _      )) = 
-      const $ parseError l "Splice not allowed as type parameter"
-    collect (L _ (HsDocTy t _       )) = collect t
-
-        -- Collect all variables of a list of types
-    collects []     = return
-    collects (t:ts) = collects ts >=> collect t
-
-    (f >=> g) x = f x >>= g
+	| isRdrTc tc	     = return (ltc, t1:t2:acc)
+    go _ (HsParTy ty)    acc = goL ty acc
+    go _ (HsAppTy t1 t2) acc = goL t1 (t2:acc)
+    go l _               _   = parseError l "Malformed head of type or class declaration"
 
 -- Check that associated type declarations of a class are all kind signatures.
 --
@@ -812,41 +859,10 @@ checkValSig (L l (HsVar v)) ty
   = return (TypeSig (L l v) ty)
 checkValSig (L l _)         _
   = parseError l "Invalid type signature"
-
-mkGadtDecl :: [Located RdrName]
-           -> LHsType RdrName -- assuming HsType
-           -> [ConDecl RdrName]
--- We allow C,D :: ty
--- and expand it as if it had been 
---    C :: ty; D :: ty
--- (Just like type signatures in general.)
-mkGadtDecl names ty
-  = [mk_gadt_con name qvars cxt tau | name <- names]
-  where
-    (qvars,cxt,tau) = case ty of
-    		        L _ (HsForAllTy _ qvars cxt tau) -> (qvars, cxt,      tau)
-			_ 	     	                 -> ([],    noLoc [], ty)
-
-mk_gadt_con :: Located RdrName
-            -> [LHsTyVarBndr RdrName]
-            -> LHsContext RdrName
-            -> LHsType RdrName
-            -> ConDecl RdrName
-mk_gadt_con name qvars cxt ty
-  = ConDecl { con_name     = name
-	    , con_explicit = Implicit
-	    , con_qvars    = qvars
-	    , con_cxt      = cxt
-	    , con_details  = PrefixCon []
-	    , con_res      = ResTyGADT ty
-            , con_doc      = Nothing }
-  -- NB: we put the whole constr type into the ResTyGADT for now; 
-  -- the renamer will unravel it once it has sorted out
-  -- operator fixities
-
--- A variable binding is parsed as a FunBind.
+\end{code}
 
 
+\begin{code}
 	-- The parser left-associates, so there should 
 	-- not be any OpApps inside the e's
 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
@@ -861,6 +877,7 @@ splitBang _ = Nothing
 
 isFunLhs :: LHsExpr RdrName 
 	 -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
+-- A variable binding is parsed as a FunBind.
 -- Just (fun, is_infix, arg_pats) if e is a function LHS
 --
 -- The whole LHS is parsed as a single expression.