From 6e0f552430600d95768c1668b6d458c71a52f2d4 Mon Sep 17 00:00:00 2001
From: "simonpj@microsoft.com" <unknown>
Date: Thu, 28 May 2009 07:53:06 +0000
Subject: [PATCH] Fix Trac #3013: multiple constructors in a GADT decl

Makes GADT syntax consistent by allowing multiple constructors
to be given a single signature
   data T wehre
       A, B :: T
       C :: Int -> t
---
 compiler/parser/Parser.y.pp       |   16 ++++++++++------
 compiler/parser/RdrHsSyn.lhs      |   18 +++++++++++++-----
 docs/users_guide/glasgow_exts.xml |   10 ++++++++++
 3 files changed, 33 insertions(+), 11 deletions(-)

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index f9976b4..7465adb 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -1150,9 +1150,9 @@ gadt_constrlist :: { Located [LConDecl RdrName] }
 	|     vocurly    gadt_constrs close	{ $2 }
 
 gadt_constrs :: { Located [LConDecl RdrName] }
-        : gadt_constrs ';' gadt_constr  { LL ($3 : unLoc $1) }
+        : gadt_constrs ';' gadt_constr  { sL (comb2 $1 (head $3)) ($3 ++ unLoc $1) }
         | gadt_constrs ';' 		{ $1 }
-        | gadt_constr                   { L1 [$1] } 
+        | gadt_constr                   { sL (getLoc (head $1)) $1 } 
 
 -- We allow the following forms:
 --	C :: Eq a => a -> T a
@@ -1160,15 +1160,15 @@ gadt_constrs :: { Located [LConDecl RdrName] }
 --	D { x,y :: a } :: T a
 --	forall a. Eq a => D { x,y :: a } :: T a
 
-gadt_constr :: { LConDecl RdrName }
-        : con '::' sigtype
-              { LL (mkGadtDecl $1 $3) } 
+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) }
+		  [LL (ConDecl con Implicit [] (noLoc []) details (ResTyGADT $3) Nothing)] }
 {-
 	| forall context '=>' constr_stuff_record '::' sigtype
 		{ let (con,details) = unLoc $4 in 
@@ -1728,6 +1728,10 @@ con	:: { Located RdrName }
 	| '(' consym ')'	{ LL (unLoc $2) }
 	| sysdcon		{ L1 $ nameRdrName (dataConName (unLoc $1)) }
 
+con_list :: { Located [Located RdrName] }
+con_list : con                  { L1 [$1] }
+         | con ',' con_list     { LL ($1 : unLoc $3) }
+
 sysdcon	:: { Located DataCon }	-- Wired in data constructors
 	: '(' ')'		{ LL unitDataCon }
 	| '(' commas ')'	{ LL $ tupleCon Boxed $2 }
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 187d64d..3ca1b29 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -28,7 +28,7 @@ module RdrHsSyn (
 			      -- -> (FastString, RdrName, RdrNameHsType)
 			      -- -> P RdrNameHsDecl
 	mkExtName,           -- RdrName -> CLabelString
-	mkGadtDecl,          -- Located RdrName -> LHsType RdrName -> ConDecl RdrName
+	mkGadtDecl,          -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName
 			      
 	-- Bunch of functions in the parser monad for 
 	-- checking and constructing values
@@ -813,11 +813,19 @@ checkValSig (L l (HsVar v)) ty
 checkValSig (L l _)         _
   = parseError l "Invalid type signature"
 
-mkGadtDecl :: Located RdrName
+mkGadtDecl :: [Located RdrName]
            -> LHsType RdrName -- assuming HsType
-           -> ConDecl RdrName
-mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = mk_gadt_con name qvars cxt ty
-mkGadtDecl name ty				  = mk_gadt_con name [] (noLoc []) ty
+           -> [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]
diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml
index 3120601..d23da18 100644
--- a/docs/users_guide/glasgow_exts.xml
+++ b/docs/users_guide/glasgow_exts.xml
@@ -2353,6 +2353,16 @@ otherwise is a <emphasis>generalised</emphasis> data type (<xref linkend="gadt"/
 </para></listitem>
 
 <listitem><para>
+As with other type signatures, you can give a single signature for several data constructors.
+In this example we give a single signature for <literal>T1</literal> and <literal>T2</literal>:
+<programlisting>
+  data T a where
+    T1,T2 :: a -> T a
+    T3 :: T a
+</programlisting>
+</para></listitem>
+
+<listitem><para>
 The type signature of
 each constructor is independent, and is implicitly universally quantified as usual. 
 Different constructors may have different universally-quantified type variables
-- 
1.7.10.4