From: simonpj <unknown>
Date: Thu, 5 Oct 2000 15:42:30 +0000 (+0000)
Subject: [project @ 2000-10-05 15:42:30 by simonpj]
X-Git-Tag: Approximately_9120_patches~3687
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=54c848ff4e46056908c53c2bc7db1d806551ba39;p=ghc-hetmet.git

[project @ 2000-10-05 15:42:30 by simonpj]
Parser changes to support type constructor operators; part of the generics stuff
---

diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs
index 2a733a7..5f929c6 100644
--- a/ghc/compiler/parser/ParseUtil.lhs
+++ b/ghc/compiler/parser/ParseUtil.lhs
@@ -7,8 +7,7 @@
 module ParseUtil (
 	  parseError		-- String -> Pa
 	, cbot			-- a
-	, splitForConApp        -- RdrNameHsType -> [RdrNameBangType]
-				--     -> P (RdrName, [RdrNameBangType])
+	, mkVanillaCon, mkRecCon,
 
 	, mkRecConstrOrUpdate	-- HsExp -> [HsFieldUpdate] -> P HsExp
 	, groupBindings
@@ -36,7 +35,7 @@ import RdrHsSyn		( mkNPlusKPatIn, unitTyCon_RDR,
 			  RdrBinding(..),
 			  RdrNameHsType, RdrNameBangType, RdrNameContext,
 			  RdrNameHsTyVar, RdrNamePat, RdrNameHsExpr, RdrNameGRHSs,
-			  RdrNameHsRecordBinds, RdrNameMonoBinds
+			  RdrNameHsRecordBinds, RdrNameMonoBinds, RdrNameConDetails
 			)
 import RdrName
 import CallConv
@@ -57,40 +56,37 @@ parseError s =
 cbot = panic "CCall:result_ty"
 
 -----------------------------------------------------------------------------
--- splitForConApp
+-- mkVanillaCon
 
 -- When parsing data declarations, we sometimes inadvertently parse
 -- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
 -- This function splits up the type application, adds any pending
 -- arguments, and converts the type constructor back into a data constructor.
 
-splitForConApp :: RdrNameHsType -> [RdrNameBangType]
-	-> P (RdrName, [RdrNameBangType])
+mkVanillaCon :: RdrNameHsType -> [RdrNameBangType] -> P (RdrName, RdrNameConDetails)
 
-splitForConApp  t ts = split t ts
+mkVanillaCon ty tys
+ = split ty tys
  where
-	split (HsAppTy t u) ts = split t (Unbanged u : ts)
-{-	split (HsOpTy t1 t ty2) ts = 
-		-- check that we've got a type constructor at the head
-	   if occNameSpace t_occ /= tcClsName
-		then parseError 
-			(showSDoc (text "not a constructor: (type pattern)`" <> 
-					ppr t <> char '\''))
-		else returnP (con, ts)
-	   where t_occ = rdrNameOcc t
-		 con   = setRdrNameOcc t (setOccNameSpace t_occ dataName)
--}
-	split (HsTyVar t)   ts  = 
-		-- check that we've got a type constructor at the head
-	   if occNameSpace t_occ /= tcClsName
-		then parseError 
-			(showSDoc (text "not a constructor: `" <> 
-					ppr t <> char '\''))
-		else returnP (con, ts)
-	   where t_occ = rdrNameOcc t
-		 con   = setRdrNameOcc t (setOccNameSpace t_occ dataName)
-
-	split _ _ = parseError "Illegal data/newtype declaration"
+   split (HsAppTy t u)  ts = split t (Unbanged u : ts)
+   split (HsTyVar tc)   ts = tyConToDataCon tc	`thenP` \ data_con ->
+			     returnP (data_con, VanillaCon ts)
+   split _		 _ = parseError "Illegal data/newtype declaration"
+
+mkRecCon :: RdrName -> [([RdrName],RdrNameBangType)] -> P (RdrName, RdrNameConDetails)
+mkRecCon con fields
+  = tyConToDataCon con	`thenP` \ data_con ->
+    returnP (data_con, RecCon fields)
+
+tyConToDataCon :: RdrName -> P RdrName
+tyConToDataCon tc
+  | occNameSpace tc_occ == tcClsName
+  = returnP (setRdrNameOcc tc (setOccNameSpace tc_occ dataName))
+  | otherwise
+  = parseError (showSDoc (text "not a constructor:" <+> quotes (ppr tc)))
+  where 
+    tc_occ   = rdrNameOcc tc
+
 
 ----------------------------------------------------------------------------
 -- Various Syntactic Checks
diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y
index 9f7ef43..7efc693 100644
--- a/ghc/compiler/parser/Parser.y
+++ b/ghc/compiler/parser/Parser.y
@@ -1,6 +1,6 @@
 {-
 -----------------------------------------------------------------------------
-$Id: Parser.y,v 1.37 2000/10/03 08:43:02 simonpj Exp $
+$Id: Parser.y,v 1.38 2000/10/05 15:42:30 simonpj Exp $
 
 Haskell grammar.
 
@@ -570,6 +570,11 @@ varids0	:: { [RdrName] }
 -----------------------------------------------------------------------------
 -- Datatype declarations
 
+newconstr :: { RdrNameConDecl }
+	: srcloc conid atype	{ mkConDecl $2 [] [] (VanillaCon [Unbanged $3]) $1 }
+	| srcloc conid '{' var '::' type '}'
+				{ mkConDecl $2 [] [] (RecCon [([$4], Unbanged $6)]) $1 }
+
 constrs :: { [RdrNameConDecl] }
 	: constrs '|' constr		{ $3 : $1 }
 	| constr			{ [$1] }
@@ -588,27 +593,14 @@ context :: { RdrNameContext }
 	: btype '=>'			{% checkContext $1 }
 
 constr_stuff :: { (RdrName, RdrNameConDetails) }
-	: scontype   		 	{ (fst $1, VanillaCon (snd $1)) }
+	: btype				{% mkVanillaCon $1 []		    }
+	| btype '!' atype satypes	{% mkVanillaCon $1 (Banged $3 : $4) }
+	| gtycon '{' fielddecls '}' 	{% mkRecCon $1 $3 }
 	| sbtype conop sbtype		{ ($2, InfixCon $1 $3) }
-	| con '{' fielddecls '}' 	{ ($1, RecCon (reverse $3)) }
-
-newconstr :: { RdrNameConDecl }
-	: srcloc conid atype	{ mkConDecl $2 [] [] (VanillaCon [Unbanged $3]) $1 }
-	| srcloc conid '{' var '::' type '}'
-				{ mkConDecl $2 [] [] (RecCon [([$4], Unbanged $6)]) $1 }
-
-scontype :: { (RdrName, [RdrNameBangType]) }
-	: btype				{% splitForConApp $1 [] }
-	| scontype1			{ $1 }
-
-scontype1 :: { (RdrName, [RdrNameBangType]) }
-	: btype '!' atype		{% splitForConApp $1 [Banged $3] }
-	| scontype1 satype		{ (fst $1, snd $1 ++ [$2] ) }
-        | '(' consym ')' 		{ ($2,[]) }
 
-satype :: { RdrNameBangType }
-	: atype				{ Unbanged $1 }
-	| '!' atype			{ Banged   $2 }
+satypes	:: { [RdrNameBangType] }
+	: atype satypes			{ Unbanged $1 : $2 }
+	| '!' atype satypes		{ Banged   $2 : $3 }
 
 sbtype :: { RdrNameBangType }
 	: btype				{ Unbanged $1 }
@@ -885,6 +877,7 @@ dbind	: ipvar '=' exp			{ ($1, $3) }
 
 gtycon 	:: { RdrName }
 	: qtycon			{ $1 }
+ 	| '(' qtyconop ')'		{ $2 }
 	| '(' ')'			{ unitTyCon_RDR }
 	| '(' '->' ')'			{ funTyCon_RDR }
 	| '[' ']'			{ listTyCon_RDR }
@@ -911,10 +904,6 @@ qvar 	:: { RdrName }
 ipvar	:: { RdrName }
 	: IPVARID		{ (mkSrcUnqual ipName (tailFS $1)) }
 
-con	:: { RdrName }
-	: conid			{ $1 }
-	| '(' consym ')'        { $2 }
-
 qcon	:: { RdrName }
 	: qconid		{ $1 }
 	| '(' qconsym ')'	{ $2 }
@@ -1078,6 +1067,10 @@ qtycon :: { RdrName }
 	: tycon			{ $1 }
 	| QCONID		{ mkSrcQual tcClsName $1 }
 
+qtyconop :: { RdrName }
+ 	  : tyconop		{ $1 }
+	  | QCONSYM		{ mkSrcQual tcClsName $1 }
+
 qtycls 	:: { RdrName }
 	: qtycon		{ $1 }