[project @ 2002-05-27 15:28:07 by simonpj]

Allow infix type constructors

This commit adds infix type constructors (but not yet class constructors).
The documentation describes what should be the case.  Lots of tiresome
changes, but nothing exciting.

Allows infix type constructors everwhere a type can occur, and in a data
or type synonym decl.  E.g.

	data a :*: b = ....


You can give fixity decls for type constructors, but the fixity decl
applies both to the tycon and the corresponding data con.

1 files changed, 88 insertions, 69 deletions

diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y
index 7b26472070..6c0fccb0f5 100644
--- a/ghc/compiler/parser/Parser.y
+++ b/ghc/compiler/parser/Parser.y
@@ -1,6 +1,6 @@
 {-								-*-haskell-*-
 -----------------------------------------------------------------------------
-$Id: Parser.y,v 1.97 2002/05/10 13:34:18 simonpj Exp $
+$Id: Parser.y,v 1.98 2002/05/27 15:28:08 simonpj Exp $
 
 Haskell grammar.
 
@@ -48,24 +48,16 @@ import Outputable
 -----------------------------------------------------------------------------
 Conflicts: 21 shift/reduce, -=chak[4Feb2]
 
-9 for abiguity in 'if x then y else z + 1'
+11 for abiguity in 'if x then y else z + 1'		[State 128]
 	(shift parses as 'if x then y else (z + 1)', as per longest-parse rule)
 	8 because op might be: - ! * . `x` VARSYM CONSYM QVARSYM QCONSYM
-1 for ambiguity in 'if x then y else z :: T'
-	(shift parses as 'if x then y else (z :: T)', as per longest-parse rule)
-1 for ambiguity in 'if x then y else z with ?x=3'
-	(shift parses as 'if x then y else (z with ?x=3)'
 
-3 for ambiguity in 'case x of y :: a -> b'
-	(don't know whether to reduce 'a' as a btype or shift the '->'.
-	 conclusion:  bogus expression anyway, doesn't matter)
-
-1 for ambiguity in '{-# RULES "name" [ ... #-}
+1 for ambiguity in '{-# RULES "name" [ ... #-}		[State 210]
 	we don't know whether the '[' starts the activation or not: it
   	might be the start of the declaration with the activation being
 	empty.  --SDM 1/4/2002
 
-1 for ambiguity in '{-# RULES "name" forall = ... #-}' 
+1 for ambiguity in '{-# RULES "name" forall = ... #-}' 	[State 412]
 	since 'forall' is a valid variable name, we don't know whether
 	to treat a forall on the input as the beginning of a quantifier
 	or the beginning of the rule itself.  Resolving to shift means
@@ -73,13 +65,28 @@ Conflicts: 21 shift/reduce, -=chak[4Feb2]
 	This saves explicitly defining a grammar for the rule lhs that
 	doesn't include 'forall'.
 
-1 for ambiguity in 'let ?x ...'
+1 for ambiguity in 'let ?x ...'				[State 278]
 	the parser can't tell whether the ?x is the lhs of a normal binding or
 	an implicit binding.  Fortunately resolving as shift gives it the only
 	sensible meaning, namely the lhs of an implicit binding.
 
-6 for conflicts between `fdecl' and `fdeclDEPRECATED', which are resolved
-  correctly, and moreover, should go away when `fdeclDEPRECATED' is removed.
+
+8 for ambiguity in 'e :: a `b` c'.  Does this mean 	[States 238,267]
+	(e::a) `b` c, or 
+	(e :: (a `b` c))
+
+6 for conflicts between `fdecl' and `fdeclDEPRECATED', 	[States 402,403]
+  which are resolved correctly, and moreover, 
+  should go away when `fdeclDEPRECATED' is removed.
+
+1 for ambiguity in 'if x then y else z :: T'
+	(shift parses as 'if x then y else (z :: T)', as per longest-parse rule)
+1 for ambiguity in 'if x then y else z with ?x=3'
+	(shift parses as 'if x then y else (z with ?x=3)'
+3 for ambiguity in 'case x of y :: a -> b'
+	(don't know whether to reduce 'a' as a btype or shift the '->'.
+	 conclusion:  bogus expression anyway, doesn't matter)
+
 
 -----------------------------------------------------------------------------
 -}
@@ -407,12 +414,13 @@ topdecls :: { [RdrBinding] }
 	| topdecl			{ [$1] }
 
 topdecl :: { RdrBinding }
- 	: srcloc 'type' tycon tv_bndrs '=' ctype	
+ 	: srcloc 'type' syn_hdr '=' ctype	
 		-- Note ctype, not sigtype.
 		-- We allow an explicit for-all but we don't insert one
 		-- in 	type Foo a = (b,b)
 		-- Instead we just say b is out of scope
- 		{ RdrHsDecl (TyClD (TySynonym $3 $4 $6 $1)) }
+ 		{ let (tc,tvs) = $3
+		  in RdrHsDecl (TyClD (TySynonym tc tvs $5 $1)) }
 
 
 	| srcloc 'data' tycl_hdr constrs deriving
@@ -442,6 +450,11 @@ topdecl :: { RdrBinding }
 	| '{-# RULES' rules '#-}'		 	{ $2 }
       	| decl						{ $1 }
 
+syn_hdr :: { (RdrName, [RdrNameHsTyVar]) }	-- We don't retain the syntax of an infix
+						-- type synonym declaration. Oh well.
+	: tycon tv_bndrs		{ ($1, $2) }
+	| tv_bndr tyconop tv_bndr 	{ ($2, [$1,$3]) }
+
 -- tycl_hdr parses the header of a type or class decl,
 -- which takes the form
 --	T a b
@@ -449,6 +462,12 @@ topdecl :: { RdrBinding }
 --	(Eq a, Ord b) => T a b
 -- Rather a lot of inlining here, else we get reduce/reduce errors
 tycl_hdr :: { (RdrNameContext, RdrName, [RdrNameHsTyVar]) }
+	: context '=>' type		{% checkTyClHdr $3	`thenP` \ (tc,tvs) ->
+					   returnP ($1, tc, tvs) }
+	| type				{% checkTyClHdr $1	`thenP` \ (tc,tvs) ->
+					   returnP ([], tc, tvs) }
+
+{-
 	: '(' comma_types1 ')' '=>' gtycon tv_bndrs
 		{% mapP checkPred $2	`thenP` \ cxt ->
 		  returnP (cxt, $5, $6) }
@@ -477,6 +496,15 @@ tycl_hdr :: { (RdrNameContext, RdrName, [RdrNameHsTyVar]) }
 		-- an error in the renamer if some non-H98 form is used and
 		-- -fglasgow-exts is not given.)  -=chak 
 
+atypes0	:: { [RdrNameHsType] }
+	: atypes1			{ $1 }
+	| {- empty -}			{ [] }
+
+atypes1	:: { [RdrNameHsType] }
+	: atype				{ [$1] }
+	| atype atypes1			{ $1 : $2 }
+-}
+
 decls 	:: { [RdrBinding] }
 	: decls ';' decl		{ $3 : $1 }
 	| decls ';'			{ $1 }
@@ -760,14 +788,13 @@ context :: { RdrNameContext }
 	: btype 			{% checkContext $1 }
 
 type :: { RdrNameHsType }
-	: gentype '->' type		{ HsFunTy $1 $3 }
-	| ipvar '::' type		{ mkHsIParamTy $1 $3 }
+	: ipvar '::' gentype		{ mkHsIParamTy $1 $3 }
 	| gentype			{ $1 }
 
 gentype :: { RdrNameHsType }
         : btype                         { $1 }
--- Generics
-        | atype tyconop atype           { HsOpTy $1 $2 $3 }
+        | btype qtyconop gentype        { HsOpTy $1 (HsTyOp $2) $3 }
+	| btype '->' gentype		{ HsOpTy $1 HsArrow $3 }
 
 btype :: { RdrNameHsType }
 	: btype atype			{ HsAppTy $1 $2 }
@@ -800,14 +827,6 @@ comma_types1	:: { [RdrNameHsType] }
 	: type				{ [$1] }
 	| type  ',' comma_types1	{ $1 : $3 }
 
-atypes0	:: { [RdrNameHsType] }
-	: atypes1			{ $1 }
-	| {- empty -}			{ [] }
-
-atypes1	:: { [RdrNameHsType] }
-	: atype				{ [$1] }
-	| atype atypes1			{ $1 : $2 }
-
 tv_bndrs :: { [RdrNameHsTyVar] }
 	 : tv_bndr tv_bndrs		{ $1 : $2 }
 	 | {- empty -}			{ [] }
@@ -1009,11 +1028,7 @@ aexp1	:: { RdrNameHsExpr }
         : aexp1 '{' fbinds '}' 			{% (mkRecConstrOrUpdate $1 
 							(reverse $3)) }
   	| aexp2					{ $1 }
-
--- Here was the syntax for type applications that I was planning
--- but there are difficulties (e.g. what order for type args)
--- so it's not enabled yet.
--- 	| var_or_con '{|' gentype '|}'          { (HsApp $1 (HsType $3)) }
+ 	| var_or_con '{|' gentype '|}'          { HsApp $1 (HsType $3) }
 
 
 var_or_con :: { RdrNameHsExpr }
@@ -1273,6 +1288,26 @@ qconop :: { RdrName }
 	| '`' qconid '`'	{ $2 }
 
 -----------------------------------------------------------------------------
+-- Type constructors
+
+tycon 	:: { RdrName }	-- Unqualified
+	: CONID			{ mkUnqual tcClsName $1 }
+
+tyconop	:: { RdrName }	-- Unqualified
+	: CONSYM		{ mkUnqual tcClsName $1 }
+	| '`' tyvar '`'		{ $2 }
+	| '`' tycon '`'		{ $2 }
+
+qtycon :: { RdrName }	-- Qualified or unqualified
+	: QCONID		{ mkQual tcClsName $1 }
+	| tycon			{ $1 }
+
+qtyconop :: { RdrName }	-- Qualified or unqualified
+	  : QCONSYM		{ mkQual tcClsName $1 }
+	  | '`' QCONID '`'	{ mkQual tcClsName $2 }
+	  | tyconop		{ $1 }
+
+-----------------------------------------------------------------------------
 -- Any operator
 
 op	:: { RdrName }   -- used in infix decls
@@ -1327,27 +1362,7 @@ special_id
 	| 'ccall'               { FSLIT("ccall") }
 
 -----------------------------------------------------------------------------
--- ConIds
-
-qconid :: { RdrName }	-- Qualified or unqualifiedb
-	: conid			{ $1 }
-	| QCONID		{ mkQual dataName $1 }
-
-conid 	:: { RdrName }
-	: CONID			{ mkUnqual dataName $1 }
-
------------------------------------------------------------------------------
--- ConSyms
-
-qconsym :: { RdrName }	-- Qualified or unqualifiedb
-	: consym		{ $1 }
-	| QCONSYM		{ mkQual dataName $1 }
-
-consym :: { RdrName }
-	: CONSYM		{ mkUnqual dataName $1 }
-
------------------------------------------------------------------------------
--- VarSyms
+-- Variables 
 
 qvarsym :: { RdrName }
 	: varsym		{ $1 }
@@ -1376,6 +1391,24 @@ special_sym : '!'	{ FSLIT("!") }
  	    | '*' 	{ FSLIT("*") }
 
 -----------------------------------------------------------------------------
+-- Data constructors
+
+qconid :: { RdrName }	-- Qualified or unqualifiedb
+	: conid			{ $1 }
+	| QCONID		{ mkQual dataName $1 }
+
+conid 	:: { RdrName }
+	: CONID			{ mkUnqual dataName $1 }
+
+qconsym :: { RdrName }	-- Qualified or unqualified
+	: consym		{ $1 }
+	| QCONSYM		{ mkQual dataName $1 }
+
+consym :: { RdrName }
+	: CONSYM		{ mkUnqual dataName $1 }
+
+
+-----------------------------------------------------------------------------
 -- Literals
 
 literal :: { HsLit }
@@ -1411,20 +1444,6 @@ modid 	:: { ModuleName }
 					'.':unpackFS (snd $1)))
 				}
 
-tycon 	:: { RdrName }
-	: CONID			{ mkUnqual tcClsName $1 }
-
-tyconop	:: { RdrName }
-	: CONSYM		{ mkUnqual tcClsName $1 }
-
-qtycon :: { RdrName }	-- Qualified or unqualified
-	: QCONID		{ mkQual tcClsName $1 }
-	| tycon			{ $1 }
-
-qtyconop :: { RdrName }	-- Qualified or unqualified
-	  : QCONSYM		{ mkQual tcClsName $1 }
-	  | tyconop		{ $1 }
-
 commas :: { Int }
 	: commas ','			{ $1 + 1 }
 	| ','				{ 2 }