Cleanup (re type function parsing)

Mon Jul 31 17:20:56 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * Cleanup (re type function parsing)

2 files changed, 23 insertions, 17 deletions

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 7b9786fa03..158043bcb8 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -467,7 +467,7 @@ cl_decl :: { LTyClDecl RdrName }
 	: 'class' tycl_hdr fds where
 		{% do { let { (binds, sigs, ats)           = 
 			        cvBindsAndSigs (unLoc $4)
-		            ; (ctxt, tc, tvs, Just tparms) = unLoc $2}
+		            ; (ctxt, tc, tvs, tparms) = unLoc $2}
                       ; checkTyVars tparms False  -- only type vars allowed
 		      ; return $ L (comb4 $1 $2 $3 $4) 
 				   (mkClassDecl (ctxt, tc, tvs) 
@@ -505,19 +505,25 @@ ty_decl :: { LTyClDecl RdrName }
 
         -- data type or newtype declaration
 	| data_or_newtype tycl_hdr constrs deriving
-		{ L (comb4 $1 $2 $3 $4)	-- We need the location on tycl_hdr 
-					-- in case constrs and deriving are
-					-- both empty
-		    (mkTyData (unLoc $1) (unLoc $2) Nothing 
-		       (reverse (unLoc $3)) (unLoc $4)) }
+		{% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}
+                      ; tpats <- checkTyVars tparms True -- 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, tpats) 
+			     Nothing (reverse (unLoc $3)) (unLoc $4)) } }
 
         -- GADT declaration
         | data_or_newtype tycl_hdr opt_kind_sig 
 		 'where' gadt_constrlist
 		 deriving
-		{ L (comb4 $1 $2 $4 $5)
-		    (mkTyData (unLoc $1) (unLoc $2) $3
-		       (reverse (unLoc $5)) (unLoc $6)) }
+		{% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}
+                      ; tpats <- checkTyVars tparms True -- can have type pats
+		      ; return $
+			  L (comb4 $1 $2 $4 $5)
+			    (mkTyData (unLoc $1) (ctxt, tc, tvs, tpats) $3
+			     (reverse (unLoc $5)) (unLoc $6)) } }
 
 opt_iso :: { Bool }
 	:       { False }
@@ -540,7 +546,7 @@ opt_kind_sig :: { Maybe Kind }
 	: 				{ Nothing }
 	| '::' kind			{ Just (unLoc $2) }
 
--- tycl_hdr parses the header of a type decl,
+-- tycl_hdr parses the header of a class or data type decl,
 -- which takes the form
 --	T a b
 -- 	Eq a => T a
@@ -550,7 +556,7 @@ opt_kind_sig :: { Maybe Kind }
 tycl_hdr :: { Located (LHsContext RdrName, 
 		       Located RdrName, 
 		       [LHsTyVarBndr RdrName],
-		       Maybe [LHsType RdrName]) }
+		       [LHsType RdrName]) }
 	: context '=>' type		{% checkTyClHdr $1         $3 >>= return.LL }
 	| type				{% checkTyClHdr (noLoc []) $1 >>= return.L1 }
 
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index b0cf2cf8cc..1867ce6755 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -35,7 +35,7 @@ module RdrHsSyn (
 	checkPrecP, 	      -- Int -> P Int
 	checkContext,	      -- HsType -> P HsContext
 	checkPred,	      -- HsType -> P HsPred
-	checkTyClHdr,         -- LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName])
+	checkTyClHdr,         -- LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName])
 	checkTyVars,          -- [LHsType RdrName] -> Bool -> P ()
 	checkSynHdr,	      -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName], Maybe [LHsType RdrName])
 	checkTopTyClD,	      -- LTyClDecl RdrName -> P (HsDecl RdrName)
@@ -401,7 +401,8 @@ checkTyVars tparms nonVarsOk =
 
 -- Check whether the type arguments in a type synonym head are simply
 -- variables.  If not, we have a type equation of a type function and return
--- all patterns.
+-- all patterns.  If yes, we return 'Nothing' as the third component to
+-- indicate a vanilla type synonym.
 --
 checkSynHdr :: LHsType RdrName 
 	    -> Bool                             -- non-variables admitted?
@@ -409,7 +410,7 @@ checkSynHdr :: LHsType RdrName
 	          [LHsTyVarBndr RdrName],	-- parameters
 		  Maybe [LHsType RdrName])	-- type patterns
 checkSynHdr ty nonVarsOk = 
-  do { (_, tc, tvs, Just tparms) <- checkTyClHdr (noLoc []) ty
+  do { (_, tc, tvs, tparms) <- checkTyClHdr (noLoc []) ty
      ; typats <- checkTyVars tparms nonVarsOk
      ; return (tc, tvs, typats) }
 
@@ -420,8 +421,7 @@ 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
-	Maybe [LHsType RdrName])     -- parameters of head symbol; wrapped into
-				     -- 'Maybe' for 'mkTyData'
+	[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
@@ -437,7 +437,7 @@ checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
 checkTyClHdr (L l cxt) ty
   = do (tc, tvs, parms) <- gol ty []
        mapM_ chk_pred cxt
-       return (L l cxt, tc, tvs, Just parms)
+       return (L l cxt, tc, tvs, parms)
   where
     gol (L l ty) acc = go l ty acc