X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2Fparser%2FParser.y.pp;h=3fb6cb1eceacf1b18bddbebbd1ffe3b53a267c8f;hb=bb106f283663e9c16a4c72ec9ca57109ae57a0ed;hp=0a8b0b6eec3ffebb34283575fd592a83c7d8b013;hpb=ac9c1e5de9629103a125e0515dcee2466ff898a7;p=ghc-hetmet.git

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 0a8b0b6..3fb6cb1 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -39,6 +39,7 @@ import OrdList
 
 import FastString
 import Maybes		( orElse )
+import Monad            ( when )
 import Outputable
 import GLAEXTS
 }
@@ -376,12 +377,20 @@ export 	:: { LIE RdrName }
 	|  'module' modid		{ LL (IEModuleContents (unLoc $2)) }
 
 qcnames :: { [RdrName] }
-	:  qcnames ',' qcname			{ unLoc $3 : $1 }
-	|  qcname				{ [unLoc $1]  }
+	:  qcnames ',' qcname_ext	{ unLoc $3 : $1 }
+	|  qcname_ext			{ [unLoc $1]  }
 
+qcname_ext :: { Located RdrName }	-- Variable or data constructor
+					-- or tagged type constructor
+	:  qcname			{ $1 }
+	|  'type' qcon			{ sL (comb2 $1 $2) 
+					     (setRdrNameSpace (unLoc $2) 
+							      tcClsName)  }
+
+-- Cannot pull into qcname_ext, as qcname is also used in expression.
 qcname 	:: { Located RdrName }	-- Variable or data constructor
-	:  qvar					{ $1 }
-	|  qcon					{ $1 }
+	:  qvar				{ $1 }
+	|  qcon				{ $1 }
 
 -----------------------------------------------------------------------------
 -- Import Declarations
@@ -475,7 +484,7 @@ cl_decl :: { LTyClDecl RdrName }
 				   (mkClassDecl (ctxt, tc, tvs) 
 					        (unLoc $3) sigs binds ats) } }
 
--- Type declarations
+-- Type declarations (toplevel)
 --
 ty_decl :: { LTyClDecl RdrName }
            -- ordinary type synonyms
@@ -512,7 +521,7 @@ ty_decl :: { LTyClDecl RdrName }
 				  (TySynonym tc tvs (Just typats) $5)) 
                       } }
 
-        -- ordinary data type or newtype declaration
+          -- ordinary data type or newtype declaration
 	| data_or_newtype tycl_hdr constrs deriving
 		{% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}
                       ; checkTyVars tparms    -- no type pattern
@@ -523,7 +532,7 @@ ty_decl :: { LTyClDecl RdrName }
 			    (mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing) 
 			       Nothing (reverse (unLoc $3)) (unLoc $4)) } }
 
-        -- ordinary GADT declaration
+          -- ordinary GADT declaration
         | data_or_newtype tycl_hdr opt_kind_sig 
 		 'where' gadt_constrlist
 		 deriving
@@ -534,7 +543,7 @@ ty_decl :: { LTyClDecl RdrName }
 			    (mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing) $3
 			      (reverse (unLoc $5)) (unLoc $6)) } }
 
-        -- data/newtype family
+          -- data/newtype family
         | data_or_newtype 'family' tycl_hdr '::' kind
 		{% do { let {(ctxt, tc, tvs, tparms) = unLoc $3}
                       ; checkTyVars tparms    -- no type pattern
@@ -543,7 +552,7 @@ ty_decl :: { LTyClDecl RdrName }
 			    (mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing) 
 			      (Just (unLoc $5)) [] Nothing) } }
 
-        -- data/newtype instance declaration
+          -- data/newtype instance declaration
 	| data_or_newtype 'instance' tycl_hdr constrs deriving
 		{% do { let {(ctxt, tc, tvs, tparms) = unLoc $3}
                                              -- can have type pats
@@ -554,7 +563,7 @@ ty_decl :: { LTyClDecl RdrName }
 			    (mkTyData (unLoc $1) (ctxt, tc, tvs, Just tparms) 
 			      Nothing (reverse (unLoc $4)) (unLoc $5)) } }
 
-        -- GADT instance declaration
+          -- GADT instance declaration
         | data_or_newtype 'instance' tycl_hdr opt_kind_sig 
 		 'where' gadt_constrlist
 		 deriving
@@ -565,6 +574,62 @@ ty_decl :: { LTyClDecl RdrName }
 			    (mkTyData (unLoc $1) (ctxt, tc, tvs, Just tparms) 
 			       $4 (reverse (unLoc $6)) (unLoc $7)) } }
 
+-- Associate type declarations
+--
+at_decl :: { LTyClDecl RdrName }
+           -- type family declarations
+        : 'type' opt_iso type '::' kind
+		-- Note the use of type for the head; this allows
+		-- infix type constructors to be declared
+		--
+ 		{% do { (tc, tvs, _) <- checkSynHdr $3 False
+		      ; return (L (comb3 $1 $3 $5) 
+				  (TyFunction tc tvs $2 (unLoc $5)))
+		      } }
+
+           -- type instance declarations
+        | 'type' opt_iso type '=' ctype
+		-- Note the use of type for the head; this allows
+		-- infix type constructors and type patterns
+		--
+ 		{% do { when $2 $ 
+			  parseError (comb2 $1 $>) "Misplaced iso keyword"
+		      ; (tc, tvs, typats) <- checkSynHdr $3 True
+		      ; return (L (comb2 $1 $5) 
+				  (TySynonym tc tvs (Just typats) $5)) 
+                      } }
+
+          -- data/newtype family
+        | data_or_newtype tycl_hdr '::' kind
+		{% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}
+                      ; checkTyVars tparms    -- no type pattern
+		      ; return $
+			  L (comb3 $1 $2 $4)
+			    (mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing) 
+			      (Just (unLoc $4)) [] Nothing) } }
+
+        -- data/newtype instance declaration
+	| data_or_newtype tycl_hdr constrs deriving
+		{% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}
+                                             -- 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, Just tparms) 
+			      Nothing (reverse (unLoc $3)) (unLoc $4)) } }
+
+        -- GADT instance declaration
+        | data_or_newtype tycl_hdr opt_kind_sig 
+		 'where' gadt_constrlist
+		 deriving
+		{% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}
+                                             -- can have type pats
+		      ; return $
+			  L (comb4 $1 $2 $5 $6)
+			    (mkTyData (unLoc $1) (ctxt, tc, tvs, Just tparms) 
+			     $3 (reverse (unLoc $5)) (unLoc $6)) } }
+
 opt_iso :: { Bool }
 	:       { False }
 	| 'iso'	{ True  }
@@ -597,7 +662,7 @@ tycl_hdr :: { Located (LHsContext RdrName,
 -- Type declaration or value declaration
 --
 tydecl  :: { Located (OrdList (LHsDecl RdrName)) }
-tydecl  : ty_decl		        { LL (unitOL (L1 (TyClD (unLoc $1)))) }
+tydecl  : at_decl		        { LL (unitOL (L1 (TyClD (unLoc $1)))) }
 	| decl                          { $1 }
 
 tydecls	:: { Located (OrdList (LHsDecl RdrName)) }	-- Reversed