From ef70af356e3229cc5c64359bf7866e5fdf44bb09 Mon Sep 17 00:00:00 2001
From: David Waern <david.waern@gmail.com>
Date: Fri, 17 Apr 2009 14:58:55 +0000
Subject: [PATCH] Simplify the type grammar

Simon P-J suggested the following simplifications in #3097:

* Allow nested foralls in `ctype` just like in `ctypedoc`.
* Use `gentype` rather than `type` in the LHS of type declarations.
* Inline `type` in `ctype`.
* Rename `gentype` to `type`.

This patch does this. Also, the equivalent thing is done for documented types.
---
 compiler/parser/Parser.y.pp |   34 ++++++++++++++++++----------------
 1 file changed, 18 insertions(+), 16 deletions(-)

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index f0fc523..6493b06 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -774,7 +774,7 @@ tycl_hdr :: { Located (LHsContext RdrName,
 		       [LHsTyVarBndr RdrName],
 		       [LHsType RdrName]) }
 	: context '=>' type		{% checkTyClHdr $1         $3 >>= return.LL }
-	| type				{% checkTyClHdr (noLoc []) $1 >>= return.L1 }
+	| type                          {% checkTyClHdr (noLoc []) $1 >>= return.L1 }
 
 -----------------------------------------------------------------------------
 -- Stand-alone deriving
@@ -997,8 +997,8 @@ sig_vars :: { Located [Located RdrName] }
 -- Types
 
 infixtype :: { LHsType RdrName }
-	: btype qtyconop gentype         { LL $ HsOpTy $1 $2 $3 }
-        | btype tyvarop  gentype  	 { LL $ HsOpTy $1 $2 $3 }
+	: btype qtyconop type         { LL $ HsOpTy $1 $2 $3 }
+        | btype tyvarop  type  	 { LL $ HsOpTy $1 $2 $3 }
 
 strict_mark :: { Located HsBang }
 	: '!'				{ L1 HsStrict }
@@ -1018,9 +1018,10 @@ strict_mark :: { Located HsBang }
 -- A ctype is a for-all type
 ctype	:: { LHsType RdrName }
 	: 'forall' tv_bndrs '.' ctype	{ LL $ mkExplicitHsForAllTy $2 (noLoc []) $4 }
-	| context '=>' type		{ LL $ mkImplicitHsForAllTy   $1 $3 }
+	| context '=>' ctype		{ LL $ mkImplicitHsForAllTy   $1 $3 }
 	-- A type of form (context => type) is an *implicit* HsForAllTy
-	| type				{ $1 }
+	| ipvar '::' type		{ LL (HsPredTy (HsIParam (unLoc $1) $3)) }
+	| type  			{ $1 }
 
 type :: { LHsType RdrName }
 	: ipvar '::' gentype		{ LL (HsPredTy (HsIParam (unLoc $1) $3)) }
@@ -1041,7 +1042,8 @@ ctypedoc :: { LHsType RdrName }
 	: 'forall' tv_bndrs '.' ctypedoc	{ LL $ mkExplicitHsForAllTy $2 (noLoc []) $4 }
 	| context '=>' ctypedoc		{ LL $ mkImplicitHsForAllTy   $1 $3 }
 	-- A type of form (context => type) is an *implicit* HsForAllTy
-	| typedoc				{ $1 }
+	| ipvar '::' type		{ LL (HsPredTy (HsIParam (unLoc $1) $3)) }
+	| typedoc			{ $1 }
 
 typedoc :: { LHsType RdrName }
 	: ipvar '::' gentype		{ LL (HsPredTy (HsIParam (unLoc $1) $3)) }
@@ -1054,7 +1056,7 @@ typedoc :: { LHsType RdrName }
 --	(Eq a, Ord a)
 -- looks so much like a tuple type.  We can't tell until we find the =>
 
--- We have the t1 ~ t2 form both in 'context' and in gentype, 
+-- We have the t1 ~ t2 form both in 'context' and in type, 
 -- to permit an individual equational constraint without parenthesis.
 -- Thus for some reason we allow    f :: a~b => blah
 -- but not 	                    f :: ?x::Int => blah
@@ -1063,20 +1065,20 @@ context :: { LHsContext RdrName }
 					     (LL $ HsPredTy (HsEqualP $1 $3)) }
 	| btype 			{% checkContext $1 }
 
-gentype :: { LHsType RdrName }
+type :: { LHsType RdrName }
         : btype                         { $1 }
-        | btype qtyconop gentype        { LL $ HsOpTy $1 $2 $3 }
-        | btype tyvarop  gentype  	{ LL $ HsOpTy $1 $2 $3 }
+        | btype qtyconop type        { LL $ HsOpTy $1 $2 $3 }
+        | btype tyvarop  type     	{ LL $ HsOpTy $1 $2 $3 }
  	| btype '->'     ctype		{ LL $ HsFunTy $1 $3 }
         | btype '~'      btype  	{ LL $ HsPredTy (HsEqualP $1 $3) }
 
-gentypedoc :: { LHsType RdrName }
+typedoc :: { LHsType RdrName }
         : btype                          { $1 }
         | btype docprev                  { LL $ HsDocTy $1 $2 }
-        | btype qtyconop gentype         { LL $ HsOpTy $1 $2 $3 }
-        | btype qtyconop gentype docprev { LL $ HsDocTy (L (comb3 $1 $2 $3) (HsOpTy $1 $2 $3)) $4 }
-        | btype tyvarop  gentype         { LL $ HsOpTy $1 $2 $3 }
-        | btype tyvarop  gentype docprev { LL $ HsDocTy (L (comb3 $1 $2 $3) (HsOpTy $1 $2 $3)) $4 }
+        | btype qtyconop type            { LL $ HsOpTy $1 $2 $3 }
+        | btype qtyconop type docprev    { LL $ HsDocTy (L (comb3 $1 $2 $3) (HsOpTy $1 $2 $3)) $4 }
+        | btype tyvarop  type            { LL $ HsOpTy $1 $2 $3 }
+        | btype tyvarop  type docprev    { LL $ HsDocTy (L (comb3 $1 $2 $3) (HsOpTy $1 $2 $3)) $4 }
         | btype '->'     ctypedoc        { LL $ HsFunTy $1 $3 }
         | btype docprev '->' ctypedoc    { LL $ HsFunTy (L (comb2 $1 $2) (HsDocTy $1 $2)) $4 }
         | btype '~'      btype           { LL $ HsPredTy (HsEqualP $1 $3) }
@@ -1410,7 +1412,7 @@ aexp1	:: { LHsExpr RdrName }
 -- so it's not enabled yet.
 -- But this case *is* used for the left hand side of a generic definition,
 -- which is parsed as an expression before being munged into a pattern
- 	| qcname '{|' gentype '|}'      { LL $ HsApp (sL (getLoc $1) (HsVar (unLoc $1)))
+ 	| qcname '{|' type '|}'         { LL $ HsApp (sL (getLoc $1) (HsVar (unLoc $1)))
 						     (sL (getLoc $3) (HsType $3)) }
 
 aexp2	:: { LHsExpr RdrName }
-- 
1.7.10.4