[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

4 files changed, 144 insertions, 56 deletions

diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs
index 88667c4330..d182ce1cc6 100644
--- a/ghc/compiler/parser/Lex.lhs
+++ b/ghc/compiler/parser/Lex.lhs
@@ -184,6 +184,8 @@ data Token
 
   | ITocurly  			-- special symbols
   | ITccurly
+  | ITocurlybar                 -- {|, for type applications
+  | ITccurlybar                 -- |}, for type applications
   | ITvccurly
   | ITobrack
   | ITcbrack
@@ -381,7 +383,7 @@ lexer cont buf s@(PState{
   where
 	line = srcLocLine loc
 
-	tab y bol atbol buf = --trace ("tab: " ++ show (I# y) ++ " : " ++ show (currentChar buf)) $
+	tab y bol atbol buf = -- trace ("tab: " ++ show (I# y) ++ " : " ++ show (currentChar buf)) $
 	  case currentChar# buf of
 
 	    '\NUL'# ->
@@ -407,8 +409,7 @@ lexer cont buf s@(PState{
 		-- and throw out any unrecognised pragmas as comments.  Any
 		-- pragmas we know about are dealt with later (after any layout
 		-- processing if necessary).
-
-	    '{'# | lookAhead# buf 1# `eqChar#` '-'# ->
+            '{'# | lookAhead# buf 1# `eqChar#` '-'# ->
 		if lookAhead# buf 2# `eqChar#` '#'# then
 		  if lookAhead# buf 3# `eqChar#` '#'# then is_a_token else
 		  case expandWhile# is_space (setCurrentPos# buf 3#) of { buf1->
@@ -472,8 +473,7 @@ nested_comment cont buf = loop buf
    loop buf = 
      case currentChar# buf of
 	'\NUL'# | bufferExhausted (stepOn buf) -> 
-		lexError "unterminated `{-'" buf
-
+		lexError "unterminated `{-'" buf -- -}
 	'-'# | lookAhead# buf 1# `eqChar#` '}'# ->
 		cont (stepOnBy# buf 2#)
 
@@ -526,7 +526,7 @@ lexBOL cont buf s@(PState{
 
 lexToken :: (Token -> P a) -> Int# -> P a
 lexToken cont glaexts buf =
- --trace "lexToken" $
+ -- trace "lexToken" $
   case currentChar# buf of
 
     -- special symbols ----------------------------------------------------
@@ -540,12 +540,16 @@ lexToken cont glaexts buf =
     ']'# -> cont ITcbrack    (incLexeme buf)
     ','# -> cont ITcomma     (incLexeme buf)
     ';'# -> cont ITsemi      (incLexeme buf)
-
     '}'# -> \ s@PState{context = ctx} ->
 	    case ctx of	
 		(_:ctx') -> cont ITccurly (incLexeme buf) s{context=ctx'}
 		_  	 -> lexError "too many '}'s" buf s
+    '|'# -> case lookAhead# buf 1# of
+	         '}'#  | flag glaexts -> cont ITccurlybar 
+                                              (setCurrentPos# buf 2#)
+                 _                    -> lex_sym cont (incLexeme buf)
 
+                
     '#'# -> case lookAhead# buf 1# of
 		')'#  | flag glaexts -> cont ITcubxparen (setCurrentPos# buf 2#)
 		'-'# -> case lookAhead# buf 2# of
@@ -559,16 +563,18 @@ lexToken cont glaexts buf =
 	   	-> cont ITbackquote (incLexeme buf)
 
     '{'# ->	-- look for "{-##" special iface pragma
-	case lookAhead# buf 1# of
+            case lookAhead# buf 1# of
+           '|'# | flag glaexts 
+                -> cont ITocurlybar (setCurrentPos# buf 2#)
 	   '-'# -> case lookAhead# buf 2# of
 		    '#'# -> case lookAhead# buf 3# of
-				'#'# ->  
+				'#'# -> 
 				   let (lexeme, buf') 
 					  = doDiscard False (stepOnBy# (stepOverLexeme buf) 4#) in
-				   cont (ITpragma lexeme) buf'
+                                            cont (ITpragma lexeme) buf'
 				_ -> lex_prag cont (setCurrentPos# buf 3#)
-	   	    _    -> cont ITocurly (incLexeme buf)
-	   _ -> (layoutOff `thenP_` cont ITocurly)  (incLexeme buf)
+	   	    _    -> cont ITocurly (incLexeme buf) 
+	   _ -> (layoutOff `thenP_` cont ITocurly)  (incLexeme buf) 
 
     -- strings/characters -------------------------------------------------
     '\"'#{-"-} -> lex_string cont glaexts [] (incLexeme buf)
@@ -908,6 +914,7 @@ lex_id cont glaexts buf =
  }}}
 
 lex_sym cont buf =
+ -- trace "lex_sym" $
  case expandWhile# is_symbol buf of
    buf' -> case lookupUFM haskellKeySymsFM lexeme of {
 	 	Just kwd_token -> --trace ("keysym: "++unpackFS lexeme) $
@@ -919,6 +926,7 @@ lex_sym cont buf =
 
 
 lex_con cont glaexts buf = 
+ -- trace ("con: "{-++unpackFS lexeme-}) $
  case expandWhile# is_ident buf          of { buf1 ->
  case slurp_trailing_hashes buf1 glaexts of { buf' ->
 
@@ -927,13 +935,13 @@ lex_con cont glaexts buf =
      _    -> just_a_conid
  
    where
-    just_a_conid = --trace ("con: "++unpackFS lexeme) $
-		   cont (ITconid lexeme) buf'
+    just_a_conid = cont (ITconid lexeme) buf'
     lexeme = lexemeToFastString buf'
     munch = lex_qid cont glaexts lexeme (incLexeme buf') just_a_conid
  }}
 
 lex_qid cont glaexts mod buf just_a_conid =
+ -- trace ("quid: "{-++unpackFS lexeme-}) $
  case currentChar# buf of
   '['# -> 	-- Special case for []
     case lookAhead# buf 1# of
@@ -961,6 +969,7 @@ lex_id3 cont glaexts mod buf just_a_conid
      let 
 	start_new_lexeme = stepOverLexeme buf
      in
+     -- trace ("lex_id31 "{-++unpackFS lexeme-}) $
      case expandWhile# is_symbol start_new_lexeme of { buf' ->
      let
        lexeme  = lexemeToFastString buf'
@@ -975,6 +984,7 @@ lex_id3 cont glaexts mod buf just_a_conid
      let 
 	start_new_lexeme = stepOverLexeme buf
      in
+     -- trace ("lex_id32 "{-++unpackFS lexeme-}) $
      case expandWhile# is_ident start_new_lexeme of { buf1 ->
      if emptyLexeme buf1 
     	    then just_a_conid
@@ -1007,8 +1017,10 @@ mk_var_token pk_str
   | otherwise		= ITvarsym pk_str
   where
       (C# f) = _HEAD_ pk_str
+      -- tl     = _TAIL_ pk_str
 
 mk_qvar_token m token =
+-- trace ("mk_qvar ") $ 
  case mk_var_token token of
    ITconid n  -> ITqconid  (m,n)
    ITvarid n  -> ITqvarid  (m,n)
diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs
index 49c0376a7f..2a733a7d06 100644
--- a/ghc/compiler/parser/ParseUtil.lhs
+++ b/ghc/compiler/parser/ParseUtil.lhs
@@ -70,7 +70,16 @@ splitForConApp :: RdrNameHsType -> [RdrNameBangType]
 splitForConApp  t ts = split t ts
  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
@@ -136,8 +145,12 @@ checkDictTy (HsTyVar t) args@(_:_) | not (isRdrTyVar t)
 checkDictTy (HsAppTy l r) args = checkDictTy l (r:args)
 checkDictTy _ _ = parseError "Illegal class assertion"
 
+-- Put more comments!
+-- Checks that the lhs of a datatype declaration
+-- is of the form Context => T a b ... z
 checkDataHeader :: RdrNameHsType 
 	-> P (RdrNameContext, RdrName, [RdrNameHsTyVar])
+
 checkDataHeader (HsForAllTy Nothing cs t) =
    checkSimple t []	     `thenP` \(c,ts) ->
    returnP (cs,c,map UserTyVar ts)
@@ -145,17 +158,23 @@ checkDataHeader t =
    checkSimple t []	     `thenP` \(c,ts) ->
    returnP ([],c,map UserTyVar ts)
 
+-- Checks the type part of the lhs of a datatype declaration
 checkSimple :: RdrNameHsType -> [RdrName] -> P ((RdrName,[RdrName]))
 checkSimple (HsAppTy l (HsTyVar a)) xs | isRdrTyVar a 
    = checkSimple l (a:xs)
-checkSimple (HsTyVar t) xs | not (isRdrTyVar t) = returnP (t,xs)
-checkSimple t _ = trace (showSDoc (ppr t)) $ parseError "Illegal data/newtype declaration"
+checkSimple (HsTyVar tycon) xs | not (isRdrTyVar tycon) = returnP (tycon,xs)
+
+checkSimple (HsOpTy (HsTyVar t1) tycon (HsTyVar t2)) [] 
+  | not (isRdrTyVar tycon) && isRdrTyVar t1 && isRdrTyVar t2
+  = returnP (tycon,[t1,t2])
+
+checkSimple t _ = parseError "Illegal left hand side in data/newtype declaration"
 
 ---------------------------------------------------------------------------
 -- Checking Patterns.
 
 -- We parse patterns as expressions and check for valid patterns below,
--- nverting the expression into a pattern at the same time.
+-- converting the expression into a pattern at the same time.
 
 checkPattern :: RdrNameHsExpr -> P RdrNamePat
 checkPattern e = checkPat e []
@@ -204,6 +223,8 @@ checkPat e [] = case e of
 
 	RecordCon c fs     -> mapP checkPatField fs `thenP` \fs ->
 			      returnP (RecPatIn c fs)
+-- Generics 
+	HsType ty          -> returnP (TypePatIn ty) 
 	_ -> patFail
 
 checkPat _ _ = patFail
@@ -249,6 +270,7 @@ checkValSig other     ty loc = parseError "Type signature given for an expressio
 -- A variable binding is parsed as an RdrNameFunMonoBind.
 -- See comments with HsBinds.MonoBinds
 
+isFunLhs :: RdrNameHsExpr -> [RdrNameHsExpr] -> Maybe (RdrName, Bool, [RdrNameHsExpr])
 isFunLhs (OpApp l (HsVar op) fix r) es  | not (isRdrDataCon op)
 			  	= Just (op, True, (l:r:es))
 isFunLhs (HsVar f) es | not (isRdrDataCon f)
@@ -282,6 +304,7 @@ mkRecConstrOrUpdate _ _
 -- it's external name will be "++". Too bad; it's important because we don't
 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
 -- (This is why we use occNameUserString.)
+
 mkExtName :: Maybe ExtName -> RdrName -> ExtName
 mkExtName Nothing rdrNm = ExtName (_PK_ (occNameUserString (rdrNameOcc rdrNm)))
 				  Nothing
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 }
diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs
index 75fa2934ef..5af43d63d3 100644
--- a/ghc/compiler/parser/RdrHsSyn.lhs
+++ b/ghc/compiler/parser/RdrHsSyn.lhs
@@ -53,7 +53,7 @@ module RdrHsSyn (
 	extractHsTyRdrTyVars, extractHsTysRdrTyVars,
 	extractPatsTyVars, 
 	extractRuleBndrsTyVars,
-	extractHsCtxtRdrTyVars,
+	extractHsCtxtRdrTyVars, extractGenericPatTyVars,
  
 	mkHsOpApp, mkClassDecl, mkClassOpSig, mkConDecl,
 	mkHsNegApp, mkHsIntegralLit, mkHsFractionalLit, mkNPlusKPatIn,
@@ -67,7 +67,8 @@ module RdrHsSyn (
 	cvBinds,
 	cvMonoBindsAndSigs,
 	cvTopDecls,
-	cvValSig, cvClassOpSig, cvInstDeclSig
+	cvValSig, cvClassOpSig, cvInstDeclSig,
+        mkTyData
     ) where
 
 #include "HsVersions.h"
@@ -76,8 +77,8 @@ import HsSyn		-- Lots of it
 import CmdLineOpts	( opt_NoImplicitPrelude )
 import HsPat		( collectSigTysFromPats )
 import OccName		( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc,
-                          mkSuperDictSelOcc, mkDefaultMethodOcc,
-			  varName, dataName, tcName
+                          mkSuperDictSelOcc, mkDefaultMethodOcc, mkGenOcc1,
+			  mkGenOcc2, varName, dataName, tcName
                       	)
 import PrelNames	( pRELUDE_Name, mkTupNameStr )
 import RdrName		( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc,
@@ -86,6 +87,8 @@ import RdrName		( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc,
 import HsPragmas	
 import List		( nub )
 import BasicTypes	( Boxity(..), RecFlag(..) )
+import Class            ( DefMeth (..) )
+import Outputable
 \end{code}
 
  
@@ -183,6 +186,10 @@ extract_ty (HsUsgTy usg ty)           acc = extract_ty ty acc
 extract_ty (HsUsgForAllTy uv ty)      acc = extract_ty ty acc
 extract_ty (HsTyVar tv)               acc = tv : acc
 extract_ty (HsForAllTy Nothing ctxt ty) acc = extract_ctxt ctxt (extract_ty ty acc)
+-- Generics
+extract_ty (HsOpTy ty1 nam ty2)         acc = extract_ty ty1 (extract_ty ty2 acc)
+extract_ty (HsNumTy num)              acc = acc
+-- Generics
 extract_ty (HsForAllTy (Just tvs) ctxt ty) 
                                 acc = acc ++
                                       (filter (`notElem` locals) $
@@ -196,6 +203,19 @@ extractPatsTyVars = filter isRdrTyVar .
 		    nub . 
 		    extract_tys .
 		    collectSigTysFromPats
+
+extractGenericPatTyVars :: RdrNameMonoBinds -> [RdrName]
+-- Get the type variables out of the type patterns in a bunch of
+-- possibly-generic bindings in a class declaration
+extractGenericPatTyVars binds
+  = filter isRdrTyVar (nub (get binds []))
+  where
+    get (AndMonoBinds b1 b2)   acc = get b1 (get b2 acc)
+    get (FunMonoBind _ _ ms _) acc = foldr get_m acc ms
+    get other		       acc = acc
+
+    get_m (Match _ (TypePatIn ty : _) _ _) acc = extract_ty ty acc
+    get_m other				   acc = acc
 \end{code}
 
 
@@ -215,7 +235,7 @@ Similarly for mkConDecl, mkClassOpSig and default-method names.
   
 \begin{code}
 mkClassDecl cxt cname tyvars fds sigs mbinds prags loc
-  = ClassDecl cxt cname tyvars fds sigs mbinds prags tname dname dwname sc_sel_names loc
+  = ClassDecl cxt cname tyvars fds sigs mbinds prags new_names loc
   where
     cls_occ  = rdrNameOcc cname
     data_occ = mkClassDataConOcc cls_occ
@@ -231,11 +251,22 @@ mkClassDecl cxt cname tyvars fds sigs mbinds prags loc
       --      D_sc1, D_sc2
       -- (We used to call them D_C, but now we can have two different
       --  superclasses both called C!)
-
-mkClassOpSig has_default_method op ty loc
-  = ClassOpSig op (Just (dm_rn, has_default_method)) ty loc
+    new_names = toClassDeclNameList (tname, dname, dwname, sc_sel_names)
+
+-- mkTyData :: ??
+mkTyData new_or_data context tname list_var list_con i maybe pragmas src =
+    let t_occ  = rdrNameOcc tname
+        name1 = mkRdrUnqual (mkGenOcc1 t_occ) 
+	name2 = mkRdrUnqual (mkGenOcc2 t_occ) 
+    in TyData new_or_data context 
+         tname list_var list_con i maybe pragmas src name1 name2
+
+mkClassOpSig (DefMeth x) op ty loc
+  = ClassOpSig op (Just (DefMeth dm_rn)) ty loc
   where
     dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op))
+mkClassOpSig x op ty loc =
+    ClassOpSig op (Just x) ty loc
 
 mkConDecl cname ex_vars cxt details loc
   = ConDecl cname wkr_name ex_vars cxt details loc