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.

3 files changed, 76 insertions, 45 deletions

diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index 31a0bca2c8..9bae01e84d 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -115,31 +115,37 @@ cvtTop (TH.SigD nm typ)
 	; returnL $ Hs.SigD (TypeSig nm' ty') }
 
 cvtTop (TySynD tc tvs rhs)
-  = do	{ (_, tc', tvs', _) <- cvt_tycl_hdr [] tc tvs
+  = do	{ (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
 	; rhs' <- cvtType rhs
 	; returnL $ TyClD (TySynonym tc' tvs' Nothing rhs') }
 
 cvtTop (DataD ctxt tc tvs constrs derivs)
-  = do	{ stuff <- cvt_tycl_hdr ctxt tc tvs
+  = do	{ (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
 	; cons' <- mapM cvtConstr constrs
 	; derivs' <- cvtDerivs derivs
-	; returnL $ TyClD (mkTyData DataType stuff Nothing cons' derivs') }
+	; returnL $ TyClD (TyData { tcdND = DataType, tcdLName = tc', tcdCtxt = ctxt'
+                                  , tcdTyVars = tvs', tcdTyPats = Nothing, tcdKindSig = Nothing
+                                  , tcdCons = cons', tcdDerivs = derivs' }) }
 
 cvtTop (NewtypeD ctxt tc tvs constr derivs)
-  = do	{ stuff <- cvt_tycl_hdr ctxt tc tvs
+  = do	{ (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
 	; con' <- cvtConstr constr
 	; derivs' <- cvtDerivs derivs
-	; returnL $ TyClD (mkTyData NewType stuff Nothing [con'] derivs') }
+	; returnL $ TyClD (TyData { tcdND = NewType, tcdLName = tc', tcdCtxt = ctxt'
+	  	    	  	  , tcdTyVars = tvs', tcdTyPats = Nothing, tcdKindSig = Nothing
+                                  , tcdCons = [con'], tcdDerivs = derivs'}) }
 
 cvtTop (ClassD ctxt cl tvs fds decs)
-  = do	{ (cxt', tc', tvs', _) <- cvt_tycl_hdr ctxt cl tvs
+  = do	{ (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs
 	; fds'  <- mapM cvt_fundep fds
         ; let (ats, bind_sig_decs) = partition isFamilyD decs
 	; (binds', sigs') <- cvtBindsAndSigs bind_sig_decs
         ; ats' <- mapM cvtTop ats
         ; let ats'' = map unTyClD ats'
 	; returnL $ 
-            TyClD $ mkClassDecl (cxt', tc', tvs') fds' sigs' binds' ats'' []
+            TyClD $ ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'
+	    	              , tcdFDs = fds', tcdSigs = sigs', tcdMeths = binds'
+			      , tcdATs = ats'', tcdDocs = [] }
 						        -- no docs in TH ^^
 	}
   where
@@ -174,7 +180,7 @@ cvtTop (PragmaD prag)
        }
 
 cvtTop (FamilyD flav tc tvs kind)
-  = do { (_, tc', tvs', _) <- cvt_tycl_hdr [] tc tvs
+  = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
        ; let kind' = fmap cvtKind kind
        ; returnL $ TyClD (TyFamily (cvtFamFlavour flav) tc' tvs' kind')
        }
@@ -183,17 +189,21 @@ cvtTop (FamilyD flav tc tvs kind)
     cvtFamFlavour DataFam = DataFamily
 
 cvtTop (DataInstD ctxt tc tys constrs derivs)
-  = do { stuff <- cvt_tyinst_hdr ctxt tc tys
+  = do { (ctxt', tc', tvs', typats') <- cvt_tyinst_hdr ctxt tc tys
        ; cons' <- mapM cvtConstr constrs
        ; derivs' <- cvtDerivs derivs
-       ; returnL $ TyClD (mkTyData DataType stuff Nothing cons' derivs') 
+       ; returnL $ TyClD (TyData { tcdND = DataType, tcdLName = tc', tcdCtxt = ctxt'
+                                  , tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing
+                                  , tcdCons = cons', tcdDerivs = derivs' })
        }
 
 cvtTop (NewtypeInstD ctxt tc tys constr derivs)
-  = do { stuff <- cvt_tyinst_hdr ctxt tc tys
+  = do { (ctxt', tc', tvs', typats') <- cvt_tyinst_hdr ctxt tc tys
        ; con' <- cvtConstr constr
        ; derivs' <- cvtDerivs derivs
-       ; returnL $ TyClD (mkTyData NewType stuff Nothing [con'] derivs') 
+       ; returnL $ TyClD (TyData { tcdND = NewType, tcdLName = tc', tcdCtxt = ctxt'
+                                  , tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing
+                                  , tcdCons = [con'], tcdDerivs = derivs' })
        }
 
 cvtTop (TySynInstD tc tys rhs)
@@ -210,13 +220,12 @@ unTyClD _               = panic "Convert.unTyClD: internal error"
 cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]
              -> CvtM ( LHsContext RdrName
                      , Located RdrName
-                     , [LHsTyVarBndr RdrName]
-                     , Maybe [LHsType RdrName])
+                     , [LHsTyVarBndr RdrName])
 cvt_tycl_hdr cxt tc tvs
   = do { cxt' <- cvtContext cxt
        ; tc'  <- tconNameL tc
        ; tvs' <- cvtTvs tvs
-       ; return (cxt', tc', tvs', Nothing) 
+       ; return (cxt', tc', tvs') 
        }
 
 cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type]
@@ -259,20 +268,20 @@ cvtConstr (NormalC c strtys)
   = do	{ c'   <- cNameL c 
 	; cxt' <- returnL []
 	; tys' <- mapM cvt_arg strtys
-	; returnL $ ConDecl c' Explicit noExistentials cxt' (PrefixCon tys') ResTyH98 Nothing }
+	; returnL $ mkSimpleConDecl c' noExistentials cxt' (PrefixCon tys') }
 
 cvtConstr (RecC c varstrtys)
   = do 	{ c'    <- cNameL c 
 	; cxt'  <- returnL []
 	; args' <- mapM cvt_id_arg varstrtys
-	; returnL $ ConDecl c' Explicit noExistentials cxt' (RecCon args') ResTyH98 Nothing }
+	; returnL $ mkSimpleConDecl c' noExistentials cxt' (RecCon args') }
 
 cvtConstr (InfixC st1 c st2)
   = do 	{ c' <- cNameL c 
 	; cxt' <- returnL []
 	; st1' <- cvt_arg st1
 	; st2' <- cvt_arg st2
-	; returnL $ ConDecl c' Explicit noExistentials cxt' (InfixCon st1' st2') ResTyH98 Nothing }
+	; returnL $ mkSimpleConDecl c' noExistentials cxt' (InfixCon st1' st2') }
 
 cvtConstr (ForallC tvs ctxt (ForallC tvs' ctxt' con'))
   = cvtConstr (ForallC (tvs ++ tvs') (ctxt ++ ctxt') con')
@@ -282,8 +291,8 @@ cvtConstr (ForallC tvs ctxt con)
 	; tvs'  <- cvtTvs tvs
 	; ctxt' <- cvtContext ctxt
 	; case con' of
-	    ConDecl l _ [] (L _ []) x ResTyH98 _
-	      -> returnL $ ConDecl l Explicit tvs' ctxt' x ResTyH98 Nothing
+	    ConDecl { con_qvars = [], con_cxt = L _ [] }
+	      -> returnL $ con' { con_qvars = tvs', con_cxt = ctxt' }
 	    _ -> panic "ForallC: Can't happen" }
 
 cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName)
diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index 83bd6d59cf..c770386411 100644
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -41,7 +41,7 @@ module HsDecls (
   ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),
   CImportSpec(..), FoType(..),
   -- ** Data-constructor declarations
-  ConDecl(..), LConDecl, ResType(..), ConDeclField(..),
+  ConDecl(..), LConDecl, ResType(..), 
   HsConDeclDetails, hsConDeclArgTys, hsConDeclsNames,
   -- ** Document comments
   DocDecl(..), LDocDecl, docDeclDoc,
@@ -704,9 +704,8 @@ data ConDecl name
         -- ^ Type variables.  Depending on 'con_res' this describes the
 	-- follewing entities
         --
-        --  - ResTyH98: the constructor's existential type variables
-        --
-        --  - ResTyGADT: all the constructor's quantified type variables
+        --  - ResTyH98:  the constructor's *existential* type variables
+        --  - ResTyGADT: *all* the constructor's quantified type variables
 
     , con_cxt       :: LHsContext name
         -- ^ The context.  This /does not/ include the \"stupid theta\" which
@@ -720,6 +719,12 @@ data ConDecl name
 
     , con_doc       :: Maybe (LHsDoc name)
         -- ^ A possible Haddock comment.
+
+    , con_old_rec :: Bool   
+        -- ^ TEMPORARY field; True <=> user has employed now-deprecated syntax for
+	--   	       	               GADT-style record decl   C { blah } :: T a b
+	-- Remove this when we no longer parse this stuff, and hence do not
+	-- need to report decprecated use
     }
 
 type HsConDeclDetails name = HsConDetails (LBangType name) [ConDeclField name]
@@ -729,15 +734,15 @@ hsConDeclArgTys (PrefixCon tys)    = tys
 hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2]
 hsConDeclArgTys (RecCon flds)      = map cd_fld_type flds
 
-data ConDeclField name	-- Record fields have Haddoc docs on them
-  = ConDeclField { cd_fld_name :: Located name,
-		   cd_fld_type :: LBangType name, 
-		   cd_fld_doc  :: Maybe (LHsDoc name) }
-
 data ResType name
    = ResTyH98		-- Constructor was declared using Haskell 98 syntax
    | ResTyGADT (LHsType name)	-- Constructor was declared using GADT-style syntax,
 				--	and here is its result type
+
+instance OutputableBndr name => Outputable (ResType name) where
+	 -- Debugging only
+   ppr ResTyH98 = ptext (sLit "ResTyH98")
+   ppr (ResTyGADT ty) = ptext (sLit "ResTyGADT") <+> pprParendHsType (unLoc ty)
 \end{code}
 
 \begin{code}
@@ -764,33 +769,31 @@ instance (OutputableBndr name) => Outputable (ConDecl name) where
     ppr = pprConDecl
 
 pprConDecl :: OutputableBndr name => ConDecl name -> SDoc
-pprConDecl (ConDecl con expl tvs cxt details ResTyH98 doc)
+pprConDecl (ConDecl { con_name =con, con_explicit = expl, con_qvars = tvs
+                    , con_cxt = cxt, con_details = details
+                    , con_res = ResTyH98, con_doc = doc })
   = sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details con details]
   where
     ppr_details con (InfixCon t1 t2) = hsep [ppr t1, pprHsInfix con, ppr t2]
     ppr_details con (PrefixCon tys)  = hsep (pprHsVar con : map ppr tys)
-    ppr_details con (RecCon fields)  = ppr con <+> ppr_fields fields
+    ppr_details con (RecCon fields)  = ppr con <+> pprConDeclFields fields
 
-pprConDecl (ConDecl con expl tvs cxt (PrefixCon arg_tys) (ResTyGADT res_ty) _)
+pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs
+                    , con_cxt = cxt, con_details = PrefixCon arg_tys
+                    , con_res = ResTyGADT res_ty })
   = ppr con <+> dcolon <+> 
     sep [pprHsForAll expl tvs cxt, ppr (foldr mk_fun_ty res_ty arg_tys)]
   where
     mk_fun_ty a b = noLoc (HsFunTy a b)
 
-pprConDecl (ConDecl con expl tvs cxt (RecCon fields) (ResTyGADT res_ty) _)
-  = sep [pprHsForAll expl tvs cxt, ppr con <+> ppr_fields fields <+> dcolon <+> ppr res_ty]
+pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs
+                    , con_cxt = cxt, con_details = RecCon fields, con_res = ResTyGADT res_ty })
+  = sep [ppr con <+> dcolon <+> pprHsForAll expl tvs cxt, 
+         pprConDeclFields fields <+> arrow <+> ppr res_ty]
 
-pprConDecl (ConDecl con _expl _tvs _cxt (InfixCon _ _) (ResTyGADT _res_ty) _)
+pprConDecl (ConDecl {con_name = con, con_details = InfixCon {}, con_res = ResTyGADT {} })
   = pprPanic "pprConDecl" (ppr con)
 	-- In GADT syntax we don't allow infix constructors
-
-
-ppr_fields :: OutputableBndr name => [ConDeclField name] -> SDoc
-ppr_fields fields = braces (sep (punctuate comma (map ppr_fld fields)))
-  where
-    ppr_fld (ConDeclField { cd_fld_name = n, cd_fld_type = ty, 
-			    cd_fld_doc = doc })
-  	= ppr n <+> dcolon <+> ppr ty <+> ppr_mbDoc doc
 \end{code}
 
 %************************************************************************
diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs
index 7d91a4233a..d5b674be34 100644
--- a/compiler/hsSyn/HsTypes.lhs
+++ b/compiler/hsSyn/HsTypes.lhs
@@ -15,6 +15,8 @@ module HsTypes (
 
 	LBangType, BangType, HsBang(..), 
         getBangType, getBangStrictness, 
+
+	ConDeclField(..), pprConDeclFields,
 	
 	mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs,
 	hsTyVarName, hsTyVarNames, replaceTyVarName,
@@ -118,8 +120,6 @@ data HsType name
 
   | HsTyVar		name		-- Type variable or type constructor
 
-  | HsBangTy	HsBang (LHsType name)	-- Bang-style type annotations 
-
   | HsAppTy		(LHsType name)
 			(LHsType name)
 
@@ -159,8 +159,19 @@ data HsType name
 
   | HsDocTy             (LHsType name) (LHsDoc name) -- A documented type
 
+  | HsBangTy	HsBang (LHsType name)	-- Bang-style type annotations 
+  | HsRecTy [ConDeclField name]	        -- Only in data type declarations
+
 data HsExplicitForAll = Explicit | Implicit
 
+
+
+data ConDeclField name	-- Record fields have Haddoc docs on them
+  = ConDeclField { cd_fld_name :: Located name,
+		   cd_fld_type :: LBangType name, 
+		   cd_fld_doc  :: Maybe (LHsDoc name) }
+
+
 -----------------------
 -- Combine adjacent for-alls. 
 -- The following awkward situation can happen otherwise:
@@ -310,6 +321,13 @@ pprHsContext cxt = ppr_hs_context cxt <+> ptext (sLit "=>")
 ppr_hs_context :: (OutputableBndr name) => HsContext name -> SDoc
 ppr_hs_context []  = empty
 ppr_hs_context cxt = parens (interpp'SP cxt)
+
+pprConDeclFields :: OutputableBndr name => [ConDeclField name] -> SDoc
+pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields)))
+  where
+    ppr_fld (ConDeclField { cd_fld_name = n, cd_fld_type = ty, 
+			    cd_fld_doc = doc })
+  	= ppr n <+> dcolon <+> ppr ty <+> ppr_mbDoc doc
 \end{code}
 
 \begin{code}
@@ -352,6 +370,7 @@ ppr_mono_ty ctxt_prec (HsForAllTy exp tvs ctxt ty)
     sep [pprHsForAll exp tvs ctxt, ppr_mono_lty pREC_TOP ty]
 
 ppr_mono_ty _         (HsBangTy b ty)     = ppr b <> ppr ty
+ppr_mono_ty _         (HsRecTy flds)      = pprConDeclFields flds
 ppr_mono_ty _         (HsTyVar name)      = ppr name
 ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2)   = ppr_fun_ty ctxt_prec ty1 ty2
 ppr_mono_ty _         (HsTupleTy con tys) = tupleParens con (interpp'SP tys)