X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fparser%2FParser.y.pp;h=dc86c0040e74249e42162b21aa4c744ab655e61b;hb=3734da50be1d8e1ddad5b5fe5c46fcfb3192d1da;hp=7b9786fa03f84e3f61cf49065a2b6484d297751e;hpb=72264dbcb05c7045dff28aa88b55634fa6c1ddf0;p=ghc-hetmet.git

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 7b9786f..dc86c00 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -444,7 +444,7 @@ topdecls :: { OrdList (LHsDecl RdrName) }
 
 topdecl :: { OrdList (LHsDecl RdrName) }
   	: cl_decl			{ unitOL (L1 (TyClD (unLoc $1))) }
-  	| ty_decl			{% checkTopTyClD $1 >>= return.unitOL.L1 }
+  	| ty_decl			{ unitOL (L1 (TyClD (unLoc $1))) }
 	| 'instance' inst_type where
 		{ let (binds, sigs, ats) = cvBindsAndSigs (unLoc $3)
 		  in unitOL (L (comb3 $1 $2 $3) 
@@ -467,8 +467,9 @@ 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
+		      ; checkKindSigs ats
 		      ; return $ L (comb4 $1 $2 $3 $4) 
 				   (mkClassDecl (ctxt, tc, tvs) 
 					        (unLoc $3) sigs binds ats) } }
@@ -478,7 +479,7 @@ cl_decl :: { LTyClDecl RdrName }
 ty_decl :: { LTyClDecl RdrName }
         -- type function signature and equations (w/ type synonyms as special
         -- case); we need to handle all this in one rule to avoid a large
-        -- number of shift/reduce conflicts (due to the generality of `type')
+        -- number of shift/reduce conflicts
         : 'type' opt_iso type kind_or_ctype
 	        --
 		-- Note the use of type for the head; this allows
@@ -497,36 +498,53 @@ ty_decl :: { LTyClDecl RdrName }
 		          ; return (L (comb3 $1 $3 kind) 
 				      (TyFunction tc tvs $2 (unLoc kind)))
 		          } 
-		     Right ty  -> 
+		     Right ty | not $2 -> 
 		       do { (tc, tvs, typats) <- checkSynHdr $3 True
 		          ; return (L (comb2 $1 ty) 
 				      (TySynonym tc tvs typats ty)) }
+		     Right ty | otherwise -> 
+		       parseError (comb2 $1 ty) 
+		         "iso tag is only allowed in kind signatures"
                 }
 
+        -- kind signature of indexed type
+        | data_or_newtype tycl_hdr '::' kind
+		{% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}
+                      ; checkTyVars tparms False  -- no type pattern
+		      ; return $
+			  L (comb3 $1 $2 $4)
+			    (mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing) 
+			     (Just (unLoc $4)) [] Nothing) } }
+
         -- 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 }
 	| 'iso'	{ True  }
 
-kind_or_ctype :: { Either (Located (Maybe Kind)) (LHsType RdrName) }
-	: 		{ Left  (noLoc Nothing)           }
-        | '::' kind	{ Left  (LL    (Just (unLoc $2))) }
-	| '=' ctype	{ Right (LL    (unLoc $2))        }
+kind_or_ctype :: { Either (Located Kind) (LHsType RdrName) }
+        : '::' kind     { Left  (LL (unLoc $2)) }
+	| '=' ctype	{ Right (LL (unLoc $2)) }
 		-- 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)
@@ -540,7 +558,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 +568,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 }