[project @ 2000-10-03 08:43:00 by simonpj]

--------------------------------------
	Adding generics		SLPJ Oct 2000
	--------------------------------------

This big commit adds Hinze/PJ-style generic class definitions, based
on work by Andrei Serjantov.  For example:

  class Bin a where
    toBin   :: a -> [Int]
    fromBin :: [Int] -> (a, [Int])

    toBin {| Unit |}    Unit	  = []
    toBin {| a :+: b |} (Inl x)   = 0 : toBin x
    toBin {| a :+: b |} (Inr y)   = 1 : toBin y
    toBin {| a :*: b |} (x :*: y) = toBin x ++ toBin y


    fromBin {| Unit |}    bs      = (Unit, bs)
    fromBin {| a :+: b |} (0:bs)  = (Inl x, bs')    where (x,bs') = fromBin bs
    fromBin {| a :+: b |} (1:bs)  = (Inr y, bs')    where (y,bs') = fromBin bs
    fromBin {| a :*: b |} bs  	  = (x :*: y, bs'') where (x,bs' ) = fromBin bs
							  (y,bs'') = fromBin bs'

Now we can say simply

  instance Bin a => Bin [a]

and the compiler will derive the appropriate code automatically.

		(About 9k lines of diffs.  Ha!)


Generic related things
~~~~~~~~~~~~~~~~~~~~~~

* basicTypes/BasicTypes: The EP type (embedding-projection pairs)

* types/TyCon:
	An extra field in an algebraic tycon (genInfo)

* types/Class, and hsSyn/HsBinds:
	Each class op (or ClassOpSig) carries information about whether
	it  	a) has no default method
		b) has a polymorphic default method
		c) has a generic default method
	There's a new data type for this: Class.DefMeth

* types/Generics:
	A new module containing good chunk of the generic-related code
	It has a .hi-boot file (alas).

* typecheck/TcInstDcls, typecheck/TcClassDcl:
	Most of the rest of the generics-related code

* hsSyn/HsTypes:
	New infix type form to allow types of the form
		data a :+: b = Inl a | Inr b

* parser/Parser.y, Lex.lhs, rename/ParseIface.y:
	Deal with the new syntax

* prelude/TysPrim, TysWiredIn:
	Need to generate generic stuff for the wired-in TyCons

* rename/RnSource RnBinds:
	A rather gruesome hack to deal with scoping of type variables
	from a generic patterns.  Details commented in the ClassDecl
	case of RnSource.rnDecl.

	Of course, there are many minor renamer consequences of the
	other changes above.

* lib/std/PrelBase.lhs
	Data type declarations for Unit, :+:, :*:


Slightly unrelated housekeeping
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* hsSyn/HsDecls:
	ClassDecls now carry the Names for their implied declarations
	(superclass selectors, tycon, etc) in a list, rather than
	laid out one by one.  This simplifies code between the parser
	and the type checker.

* prelude/PrelNames, TysWiredIn:
	All the RdrNames are now together in PrelNames.

* utils/ListSetOps:
	Add finite mappings based on equality and association lists (Assoc a b)
	Move stuff from List.lhs that is related

1 files changed, 52 insertions, 30 deletions

diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y
index 122ab9ad19..9f7ef43463 100644
--- a/ghc/compiler/parser/Parser.y
+++ b/ghc/compiler/parser/Parser.y
@@ -1,6 +1,6 @@
 {-
 -----------------------------------------------------------------------------
-$Id: Parser.y,v 1.36 2000/09/22 15:56:13 simonpj Exp $
+$Id: Parser.y,v 1.37 2000/10/03 08:43:02 simonpj Exp $
 
 Haskell grammar.
 
@@ -14,6 +14,7 @@ module Parser ( parse ) where
 import HsSyn
 import HsPragmas
 import HsTypes		( mkHsTupCon )
+import HsPat            ( InPat(..) )
 
 import RdrHsSyn
 import Lex
@@ -30,6 +31,7 @@ import Panic
 
 import GlaExts
 import FastString	( tailFS )
+import Outputable
 
 #include "HsVersions.h"
 }
@@ -158,6 +160,8 @@ Conflicts: 14 shift/reduce
 
  '{'		{ ITocurly } 			-- special symbols
  '}'		{ ITccurly }
+ '{|'           { ITocurlybar }
+ '|}'           { ITccurlybar }
  vccurly	{ ITvccurly } -- virtual close curly (from layout)
  '['		{ ITobrack }
  ']'		{ ITcbrack }
@@ -328,13 +332,13 @@ topdecl :: { RdrBinding }
 	| srcloc 'data' ctype '=' constrs deriving
 		{% checkDataHeader $3 `thenP` \(cs,c,ts) ->
 		   returnP (RdrHsDecl (TyClD
-		      (TyData DataType cs c ts (reverse $5) (length $5) $6
+		      (mkTyData DataType cs c ts (reverse $5) (length $5) $6
 			NoDataPragmas $1))) }
 
 	| srcloc 'newtype' ctype '=' newconstr deriving
 		{% checkDataHeader $3 `thenP` \(cs,c,ts) ->
 		   returnP (RdrHsDecl (TyClD
-		      (TyData NewType cs c ts [$5] 1 $6
+		      (mkTyData NewType cs c ts [$5] 1 $6
 			NoDataPragmas $1))) }
 
 	| srcloc 'class' ctype fds where
@@ -486,7 +490,7 @@ sigtypes :: { [RdrNameHsType] }
 	| sigtypes ',' sigtype		{ $3 : $1 }
 
 sigtype :: { RdrNameHsType }
-	: ctype				{ mkHsForAllTy Nothing [] $1 }
+	: ctype				{ (mkHsForAllTy Nothing [] $1) }
 
 sig_vars :: { [RdrName] }
 	 : sig_vars ',' var		{ $3 : $1 }
@@ -499,16 +503,21 @@ sig_vars :: { [RdrName] }
 ctype	:: { RdrNameHsType }
 	: 'forall' tyvars '.' ctype	{ mkHsForAllTy (Just $2) [] $4 }
 	| context type			{ mkHsForAllTy Nothing   $1 $2 }
-		-- A type of form (context => type) is an *implicit* HsForAllTy
+	-- A type of form (context => type) is an *implicit* HsForAllTy
 	| type				{ $1 }
 
 type :: { RdrNameHsType }
-	: btype '->' type		{ HsFunTy $1 $3 }
+	: gentype '->' type		{ HsFunTy $1 $3 }
 	| ipvar '::' type		{ mkHsIParamTy $1 $3 }
-	| btype				{ $1 }
+	| gentype			{ $1 }
+
+gentype :: { RdrNameHsType }
+        : btype                         { $1 }
+-- Generics
+        | atype tyconop atype           { HsOpTy $1 $2 $3 }
 
 btype :: { RdrNameHsType }
-	: btype atype			{ HsAppTy $1 $2 }
+	: btype atype			{ (HsAppTy $1 $2) }
 	| atype				{ $1 }
 
 atype :: { RdrNameHsType }
@@ -517,7 +526,9 @@ atype :: { RdrNameHsType }
 	| '(' type ',' types ')'	{ HsTupleTy (mkHsTupCon tcName Boxed  ($2:$4)) ($2 : reverse $4) }
 	| '(#' types '#)'		{ HsTupleTy (mkHsTupCon tcName Unboxed     $2) (reverse $2)	 }
 	| '[' type ']'			{ HsListTy $2 }
-	| '(' ctype ')'			{ $2 }
+	| '(' ctype ')'		        { $2 }
+-- Generics
+        | INTEGER                       { HsNumTy $1 }
 
 -- An inst_type is what occurs in the head of an instance decl
 --	e.g.  (Foo a, Gaz b) => Wibble a b
@@ -648,15 +659,16 @@ dclasses :: { [RdrName] }
 -}
 
 valdef :: { RdrBinding }
-	: infixexp srcloc opt_sig rhs		{% checkValDef $1 $3 $4 $2 }
-	| infixexp srcloc '::' sigtype		{% checkValSig $1 $4 $2 }
+	: infixexp srcloc opt_sig rhs		{% (checkValDef $1 $3 $4 $2) }
+	| infixexp srcloc '::' sigtype		{% (checkValSig $1 $4 $2) }
 	| var ',' sig_vars srcloc '::' sigtype	{ foldr1 RdrAndBindings 
 							 [ RdrSig (Sig n $6 $4) | n <- $1:$3 ]
-						}
+                                                }
+
 
 rhs	:: { RdrNameGRHSs }
-	: '=' srcloc exp wherebinds	{ GRHSs (unguardedRHS $3 $2) 
-								$4 Nothing}
+	: '=' srcloc exp wherebinds	{ (GRHSs (unguardedRHS $3 $2) 
+								$4 Nothing)}
 	| gdrhs	wherebinds		{ GRHSs (reverse $1) $2 Nothing }
 
 gdrhs :: { [RdrNameGRHS] }
@@ -670,13 +682,14 @@ gdrh :: { RdrNameGRHS }
 -- Expressions
 
 exp   :: { RdrNameHsExpr }
-	: infixexp '::' sigtype		{ ExprWithTySig $1 $3 }
+	: infixexp '::' sigtype		{ (ExprWithTySig $1 $3) }
 	| infixexp 'with' dbinding	{ HsWith $1 $3 }
 	| infixexp			{ $1 }
 
 infixexp :: { RdrNameHsExpr }
 	: exp10				{ $1 }
-	| infixexp qop exp10		{ OpApp $1 $2 (panic "fixity") $3 }
+	| infixexp qop exp10		{ (OpApp $1 (HsVar $2) 
+						(panic "fixity") $3 )}
 
 exp10 :: { RdrNameHsExpr }
 	: '\\' aexp aexps opt_asig '->' srcloc exp	
@@ -706,24 +719,29 @@ ccallid :: { FAST_STRING }
 	|  CONID				{ $1 }
 
 fexp 	:: { RdrNameHsExpr }
-	: fexp aexp				{ HsApp $1 $2 }
+	: fexp aexp				{ (HsApp $1 $2) }
   	| aexp					{ $1 }
 
 aexps0 	:: { [RdrNameHsExpr] }
-	: aexps					{ reverse $1 }
+	: aexps					{ (reverse $1) }
 
 aexps 	:: { [RdrNameHsExpr] }
 	: aexps aexp				{ $2 : $1 }
   	| {- empty -}				{ [] }
 
 aexp	:: { RdrNameHsExpr }
-  	: aexp '{' fbinds '}' 		{% mkRecConstrOrUpdate $1 (reverse $3) }
-  	| aexp1				{ $1 }
+        : var_or_con '{|' gentype '|}'          { (HsApp $1 (HsType $3)) }
+  	| aexp '{' fbinds '}' 			{% (mkRecConstrOrUpdate $1 
+							(reverse $3)) }
+  	| aexp1					{ $1 }
+
+var_or_con :: { RdrNameHsExpr }
+        : qvar                          { HsVar $1 }
+        | gcon                          { HsVar $1 }
 
 aexp1	:: { RdrNameHsExpr }
-	: qvar				{ HsVar $1 }
-	| ipvar				{ HsIPVar $1 }
-	| gcon				{ HsVar $1 }
+	: ipvar				{ HsIPVar $1 }
+	| var_or_con			{ $1 }
 	| literal			{ HsLit $1 }
 	| INTEGER			{ HsOverLit (mkHsIntegralLit $1) }
 	| RATIONAL			{ HsOverLit (mkHsFractionalLit $1) }
@@ -731,8 +749,8 @@ aexp1	:: { RdrNameHsExpr }
 	| '(' exp ',' texps ')'		{ ExplicitTuple ($2 : reverse $4) Boxed}
 	| '(#' texps '#)'		{ ExplicitTuple (reverse $2)      Unboxed }
 	| '[' list ']'                  { $2 }
-	| '(' infixexp qop ')'		{ SectionL $2 $3  }
-	| '(' qopm infixexp ')'		{ SectionR $2 $3 }
+	| '(' infixexp qop ')'		{ (SectionL $2 (HsVar $3))  }
+	| '(' qopm infixexp ')'		{ (SectionR $2 $3) }
 	| qvar '@' aexp			{ EAsPat $1 $3 }
 	| '_'				{ EWildPat }
 	| '~' aexp1			{ ELazyPat $2 }
@@ -741,6 +759,7 @@ texps :: { [RdrNameHsExpr] }
 	: texps ',' exp			{ $3 : $1 }
 	| exp				{ [$1] }
 
+
 -----------------------------------------------------------------------------
 -- List expressions
 
@@ -792,9 +811,9 @@ alts1 	:: { [RdrNameMatch] }
 
 alt 	:: { RdrNameMatch }
 	: infixexp opt_sig ralt wherebinds
-					{% checkPattern $1 `thenP` \p ->
+					{% (checkPattern $1 `thenP` \p ->
 				   	   returnP (Match [] [p] $2
-					             (GRHSs $3 $4 Nothing)) }
+					             (GRHSs $3 $4 Nothing))  )}
 
 ralt :: { [RdrNameGRHS] }
 	: '->' srcloc exp		{ [GRHS [ExprStmt $3 $2] $2] }
@@ -927,9 +946,9 @@ op	:: { RdrName }   -- used in infix decls
 	: varop			{ $1 }
 	| conop 		{ $1 }
 
-qop	:: { RdrNameHsExpr }   -- used in sections
-	: qvarop		{ HsVar $1 }
-	| qconop		{ HsVar $1 }
+qop	:: { RdrName {-HsExpr-} }   -- used in sections
+	: qvarop		{ $1 }
+	| qconop		{ $1 }
 
 qopm	:: { RdrNameHsExpr }   -- used in sections
 	: qvaropm		{ HsVar $1 }
@@ -1052,6 +1071,9 @@ modid 	:: { ModuleName }
 tycon 	:: { RdrName }
 	: CONID			{ mkSrcUnqual tcClsName $1 }
 
+tyconop	:: { RdrName }
+	: CONSYM		{ mkSrcUnqual tcClsName $1 }
+
 qtycon :: { RdrName }
 	: tycon			{ $1 }
 	| QCONID		{ mkSrcQual tcClsName $1 }