From c0778bd3da61e80948e5813255ee82cdfebe0fdf Mon Sep 17 00:00:00 2001
From: David Waern <david.waern@gmail.com>
Date: Tue, 31 Mar 2009 21:23:06 +0000
Subject: [PATCH] Allow Haddock comments in type synonyms

We now use `ctypedoc` instead of `ctype` for type synonyms. `ctypedoc` was
previously only used for top-level type signatures. This change means that type
synonyms now can contain comments, just like top-level type signatures.

Note:

* I've modified `ctypedoc` so it allows implicit parameters and equational
constraints, just like ctype.

* Since `ctypedoc` allows nested foralls, we now allow that in type synonyms.

* I have inlined some productions into gentypedoc so that there is now a
non-doc version of every production with a 'doc' suffix. (Stylistic change
only, which should make the code easier to follow).

* It would have been nice to simplify the grammar by unifying `ctype` and
ctypedoc` into one production, allowing comments on types everywhere (and
rejecting them after parsing, where necessary).  This is however not possible
since it leads to ambiguity. The reason is the support for comments on record
fields:

> data R = R { field :: Int -- ^ comment on the field }

If we allow comments on types here, it's not clear if the comment applies
to 'field' or to 'Int'. So we must use `ctype` to describe the type.
---
 compiler/parser/Parser.y.pp |   44 +++++++++++++++++++++----------------------
 1 file changed, 22 insertions(+), 22 deletions(-)

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 5fbbcad..8806a3d 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -589,7 +589,7 @@ cl_decl :: { LTyClDecl RdrName }
 --
 ty_decl :: { LTyClDecl RdrName }
            -- ordinary type synonyms
-        : 'type' type '=' ctype
+        : 'type' type '=' ctypedoc
 		-- Note ctype, not sigtype, on the right of '='
 		-- We allow an explicit for-all but we don't insert one
 		-- in 	type Foo a = (b,b)
@@ -1000,23 +1000,6 @@ infixtype :: { LHsType RdrName }
 	: btype qtyconop gentype         { LL $ HsOpTy $1 $2 $3 }
         | btype tyvarop  gentype  	 { LL $ HsOpTy $1 $2 $3 }
 
-infixtypedoc :: { LHsType RdrName }
-        : infixtype                      { $1 }
-	| infixtype docprev              { LL $ HsDocTy $1 $2 }
-
-gentypedoc :: { LHsType RdrName }
-        : btype                          { $1 }
-        | btypedoc                       { $1 }
-        | infixtypedoc                   { $1 }
-        | btype '->' ctypedoc            { LL $ HsFunTy $1 $3 }
-        | btypedoc '->' ctypedoc         { LL $ HsFunTy $1 $3 }
-
-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
-	| gentypedoc			 { $1 }
-	
 strict_mark :: { Located HsBang }
 	: '!'				{ L1 HsStrict }
 	| '{-# UNPACK' '#-}' '!'	{ LL HsUnbox }
@@ -1028,6 +1011,12 @@ ctype	:: { LHsType RdrName }
 	-- A type of form (context => type) is an *implicit* HsForAllTy
 	| type				{ $1 }
 
+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 }
+
 -- We parse a context as a btype so that we don't get reduce/reduce
 -- errors in ctype.  The basic problem is that
 --	(Eq a, Ord a)
@@ -1044,6 +1033,10 @@ type :: { LHsType RdrName }
 	: ipvar '::' gentype		{ LL (HsPredTy (HsIParam (unLoc $1) $3)) }
 	| gentype			{ $1 }
 
+typedoc :: { LHsType RdrName }
+	: ipvar '::' gentype		{ LL (HsPredTy (HsIParam (unLoc $1) $3)) }
+	| gentypedoc			{ $1 }
+
 gentype :: { LHsType RdrName }
         : btype                         { $1 }
         | btype qtyconop gentype        { LL $ HsOpTy $1 $2 $3 }
@@ -1051,14 +1044,21 @@ gentype :: { LHsType RdrName }
  	| btype '->'     ctype		{ LL $ HsFunTy $1 $3 }
         | btype '~'      btype  	{ LL $ HsPredTy (HsEqualP $1 $3) }
 
+gentypedoc :: { 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 '->'     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) }
+
 btype :: { LHsType RdrName }
 	: btype atype			{ LL $ HsAppTy $1 $2 }
 	| atype				{ $1 }
 
-btypedoc :: { LHsType RdrName }
-	: btype atype docprev		{ LL $ HsDocTy (L (comb2 $1 $2) (HsAppTy $1 $2)) $3 }
-        | atype docprev                 { LL $ HsDocTy $1 $2 }
-
 atype :: { LHsType RdrName }
 	: gtycon			{ L1 (HsTyVar (unLoc $1)) }
 	| tyvar				{ L1 (HsTyVar (unLoc $1)) }
-- 
1.7.10.4