[project @ 1996-04-09 10:27:46 by partain]

Sansom 1.3 changes through 960408

32 files changed, 306 insertions, 227 deletions

diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs
index adbd61f788..8018ad2c99 100644
--- a/ghc/compiler/basicTypes/Id.lhs
+++ b/ghc/compiler/basicTypes/Id.lhs
@@ -103,7 +103,7 @@ import IdInfo
 import Maybes		( maybeToBool )
 import Name		( appendRdr, nameUnique, mkLocalName, isLocalName,
 			  isLocallyDefinedName, isPreludeDefinedName,
-			  nameOrigName,
+			  nameOrigName, mkTupleDataConName,
 			  isAvarop, isAconop, getLocalName,
 			  isLocallyDefined, isPreludeDefined,
 			  getOrigName, getOccName,
@@ -129,7 +129,7 @@ import TyVar		( alphaTyVars, isEmptyTyVarSet, TyVarEnv(..) )
 import UniqFM
 import UniqSet		-- practically all of it
 import UniqSupply	( getBuiltinUniques )
-import Unique		( mkTupleDataConUnique, pprUnique, showUnique,
+import Unique		( pprUnique, showUnique,
 			  Unique{-instance Ord3-}
 			)
 import Util		( mapAccumL, nOfThem, zipEqual,
@@ -1409,8 +1409,8 @@ mkTupleCon :: Arity -> Id
 mkTupleCon arity
   = Id unique ty (TupleConId n arity) NoPragmaInfo tuplecon_info 
   where
-    n		= panic "mkTupleCon: its Name (Id)"
-    unique      = mkTupleDataConUnique arity
+    n		= mkTupleDataConName arity
+    unique      = uniqueOf n
     ty 		= mkSigmaTy tyvars []
 		   (mkFunTys tyvar_tys (applyTyCon tycon tyvar_tys))
     tycon	= mkTupleTyCon arity
diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs
index 14691d66b7..2c176ec181 100644
--- a/ghc/compiler/basicTypes/Name.lhs
+++ b/ghc/compiler/basicTypes/Name.lhs
@@ -25,6 +25,8 @@ module Name (
 	mkImplicitName,	isImplicitName,
 	mkBuiltinName,
 
+	mkFunTyConName, mkTupleDataConName, mkTupleTyConName,
+
 	NamedThing(..), -- class
 	ExportFlag(..), isExported,
 
@@ -49,11 +51,13 @@ import Ubiq
 import CStrings		( identToC, cSEP )
 import Outputable	( Outputable(..) )
 import PprStyle		( PprStyle(..), codeStyle )
+import PrelMods		( pRELUDE, pRELUDE_BUILTIN )
 import Pretty
-import PrelMods		( pRELUDE )
 import SrcLoc		( mkBuiltinSrcLoc, mkUnknownSrcLoc )
-import Unique		( pprUnique, Unique )
-import Util		( thenCmp, _CMP_STRING_, panic )
+import Unique		( funTyConKey, mkTupleDataConUnique, mkTupleTyConUnique,
+			  pprUnique, Unique
+			)
+import Util		( thenCmp, _CMP_STRING_, nOfThem, panic )
 \end{code}
 
 %************************************************************************
@@ -167,6 +171,21 @@ mkImplicitName u o = Global u o Implicit NotExported []
 mkBuiltinName :: Unique -> Module -> FAST_STRING -> Name
 mkBuiltinName u m n = Global u (Unqual n) Builtin NotExported []
 
+mkFunTyConName
+  = mkBuiltinName funTyConKey		       pRELUDE_BUILTIN SLIT("->")
+mkTupleDataConName arity
+  = mkBuiltinName (mkTupleDataConUnique arity) pRELUDE_BUILTIN (mk_tup_name arity)
+mkTupleTyConName   arity
+  = mkBuiltinName (mkTupleTyConUnique   arity) pRELUDE_BUILTIN (mk_tup_name arity)
+
+mk_tup_name 0 = SLIT("()")
+mk_tup_name 1 = panic "Name.mk_tup_name: 1 ???"
+mk_tup_name 2 = SLIT("(,)")   -- not strictly necessary
+mk_tup_name 3 = SLIT("(,,)")  -- ditto
+mk_tup_name 4 = SLIT("(,,,)") -- ditto
+mk_tup_name n
+  = _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")")
+
 	-- ToDo: what about module ???
 	-- ToDo: exported when compiling builtin ???
 
diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs
index 2b193da6e5..f1a0d30e95 100644
--- a/ghc/compiler/codeGen/CodeGen.lhs
+++ b/ghc/compiler/codeGen/CodeGen.lhs
@@ -44,7 +44,7 @@ import Util		( panic, assertPanic )
 codeGen :: FAST_STRING		-- module name
 	-> ([CostCentre],	-- local cost-centres needing declaring/registering
 	    [CostCentre])	-- "extern" cost-centres needing declaring
-	-> Bag FAST_STRING	-- import names
+	-> [Module]		-- import names
 	-> [TyCon]		-- tycons with data constructors to convert
 	-> FiniteMap TyCon [(Bool, [Maybe Type])]
 				-- tycon specialisation info
@@ -98,7 +98,7 @@ codeGen mod_name (local_CCs, extern_CCs) import_names gen_tycons tycon_specs stg
       = let
 	    register_ccs     = mkAbstractCs (map mk_register ccs)
 	    register_imports
-	      = foldBag mkAbsCStmts mk_import_register AbsCNop import_names
+	      = foldr (mkAbsCStmts . mk_import_register) AbsCNop import_names
 	in
 	mkAbstractCs [
 	    CCallProfCCMacro SLIT("START_REGISTER_CCS") [CLitLit (modnameToC (SLIT("_reg") _APPEND_ mod_name)) AddrRep],
diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs
index 3aa5c628f8..dc2b61ae20 100644
--- a/ghc/compiler/coreSyn/CoreLint.lhs
+++ b/ghc/compiler/coreSyn/CoreLint.lhs
@@ -570,13 +570,10 @@ mkAppMsg fun arg expr sty
 
 mkTyAppMsg :: Type -> Type -> CoreExpr -> ErrMsg
 mkTyAppMsg ty arg expr sty
-  = panic "mkTyAppMsg"
-{-
   = ppAboves [ppStr "Illegal type application:",
-	      ppHang (ppStr "Exp type:") 4 (ppr sty exp),
-	      ppHang (ppStr "Arg type:") 4 (ppr sty arg),
+	      ppHang (ppStr "Exp type:")   4 (ppr sty ty),
+	      ppHang (ppStr "Arg type:")   4 (ppr sty arg),
 	      ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
--}
 
 mkUsageAppMsg :: Type -> Usage -> CoreExpr -> ErrMsg
 mkUsageAppMsg ty u expr sty
diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs
index 2e017b8b46..4d8284d4d3 100644
--- a/ghc/compiler/coreSyn/CoreSyn.lhs
+++ b/ghc/compiler/coreSyn/CoreSyn.lhs
@@ -56,11 +56,15 @@ module CoreSyn (
 
 import Ubiq{-uitous-}
 
+-- ToDo:rm:
+--import PprCore		( GenCoreExpr{-instance-} )
+--import PprStyle		( PprStyle(..) )
+
 import CostCentre	( showCostCentre, CostCentre )
 import Id		( idType, GenId{-instance Eq-} )
 import Type		( isUnboxedType )
 import Usage		( UVar(..) )
-import Util		( panic, assertPanic )
+import Util		( panic, assertPanic {-pprTrace:ToDo:rm-} )
 \end{code}
 
 %************************************************************************
@@ -495,8 +499,9 @@ collectArgs expr
 
     valvars (App fun v) vacc | isValArg v = valvars fun (v:vacc)
     valvars fun vacc
-      = ASSERT(not (usage_app fun))
-	ASSERT(not (ty_app    fun))
+      = --ASSERT(not (usage_app fun))
+	--ASSERT(not (ty_app    fun))
+	(if (usage_app fun || ty_app fun) then trace "CoreSyn:valvars" {-(ppr PprDebug fun)-} else id) $
 	(fun, vacc)
 
     ---------------------------------------
diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs
index 2fc8a3bfea..e737450a3a 100644
--- a/ghc/compiler/coreSyn/CoreUtils.lhs
+++ b/ghc/compiler/coreSyn/CoreUtils.lhs
@@ -170,9 +170,7 @@ escErrorMsg (x:xs)   = x : escErrorMsg xs
 
 For making @Apps@ and @Lets@, we must take appropriate evasive
 action if the thing being bound has unboxed type.  @mkCoApp@ requires
-a name supply to do its work.  Other-monad code will call @mkCoApp@
-through its own interface function (e.g., the desugarer uses
-@mkCoAppDs@).
+a name supply to do its work.
 
 @mkCoApp@, @mkCoCon@ and @mkCoPrim@ also handle the
 arguments-must-be-atoms constraint.
@@ -199,12 +197,18 @@ mkCoApp e1 e2
 \end{code}
 
 \begin{code}
-{-LATER
-mkCoCon  :: Id     -> [CoreExpr] -> UniqSM CoreExpr
-mkCoPrim :: PrimOp -> [CoreExpr] -> UniqSM CoreExpr
+{-
+data CoreArgOrExpr
+  = AnArg   CoreArg
+  | AnExpr  CoreExpr
+
+mkCoApps :: CoreExpr -> [CoreArgOrExpr] -> UniqSM CoreExpr
+mkCoCon  :: Id       -> [CoreArgOrExpr] -> UniqSM CoreExpr
+mkCoPrim :: PrimOp   -> [CoreArgOrExpr] -> UniqSM CoreExpr
 
-mkCoCon con args = mkCoThing (Con con) args
-mkCoPrim op args = mkCoThing (Prim op) args
+mkCoApps fun args = mkCoThing (Con con) args
+mkCoCon  con args = mkCoThing (Con con) args
+mkCoPrim  op args = mkCoThing (Prim op) args
 
 mkCoThing thing arg_exprs
   = mapAndUnzipUs expr_to_arg arg_exprs `thenUs` \ (args, maybe_binds) ->
diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs
index c2c23ae2d6..e45e7bc6db 100644
--- a/ghc/compiler/deSugar/DsBinds.lhs
+++ b/ghc/compiler/deSugar/DsBinds.lhs
@@ -470,7 +470,7 @@ dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind var expr)
 \end{code}
 
 \begin{code}
-dsMonoBinds is_rec tyvars dicts binder_subst (FunMonoBind fun matches locn)
+dsMonoBinds is_rec tyvars dicts binder_subst (FunMonoBind fun _ matches locn)
   = putSrcLocDs locn	$
     let
 	new_fun      = binder_subst fun
diff --git a/ghc/compiler/deSugar/DsHsSyn.lhs b/ghc/compiler/deSugar/DsHsSyn.lhs
index 91601a112b..3adfab126e 100644
--- a/ghc/compiler/deSugar/DsHsSyn.lhs
+++ b/ghc/compiler/deSugar/DsHsSyn.lhs
@@ -57,7 +57,7 @@ collectTypedBinders (RecBind    bs) = collectTypedMonoBinders bs
 collectTypedMonoBinders :: TypecheckedMonoBinds -> [Id]
 collectTypedMonoBinders EmptyMonoBinds	      = []
 collectTypedMonoBinders (PatMonoBind pat _ _) = collectTypedPatBinders pat
-collectTypedMonoBinders (FunMonoBind f _ _)   = [f]
+collectTypedMonoBinders (FunMonoBind f _ _ _) = [f]
 collectTypedMonoBinders (VarMonoBind v _)     = [v]
 collectTypedMonoBinders (AndMonoBinds bs1 bs2)
  = collectTypedMonoBinders bs1 ++ collectTypedMonoBinders bs2
diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs
index 15dafc9d0e..d8908f1e04 100644
--- a/ghc/compiler/hsSyn/HsBinds.lhs
+++ b/ghc/compiler/hsSyn/HsBinds.lhs
@@ -237,6 +237,7 @@ data MonoBinds tyvar uvar id pat
 		    (GRHSsAndBinds tyvar uvar id pat)
 		    SrcLoc
   | FunMonoBind     id
+		    Bool			-- True => infix declaration
 		    [Match tyvar uvar id pat]	-- must have at least one Match
 		    SrcLoc
   | VarMonoBind	    id			-- TRANSLATION
@@ -262,8 +263,9 @@ instance (NamedThing id, Outputable id, Outputable pat,
     ppr sty (PatMonoBind pat grhss_n_binds locn)
       = ppHang (ppr sty pat) 4 (pprGRHSsAndBinds sty False grhss_n_binds)
 
-    ppr sty (FunMonoBind fun matches locn)
+    ppr sty (FunMonoBind fun inf matches locn)
       = pprMatches sty (False, pprNonOp sty fun) matches
+      -- ToDo: print infix if appropriate
 
     ppr sty (VarMonoBind name expr)
       = ppHang (ppCat [pprNonOp sty name, ppEquals]) 4 (ppr sty expr)
@@ -302,7 +304,7 @@ collectBinders (RecBind monobinds)    = collectMonoBinders monobinds
 collectMonoBinders :: MonoBinds tyvar uvar name (InPat name) -> [name]
 collectMonoBinders EmptyMonoBinds		     = []
 collectMonoBinders (PatMonoBind pat grhss_w_binds _) = collectPatBinders pat
-collectMonoBinders (FunMonoBind f matches _)	     = [f]
+collectMonoBinders (FunMonoBind f _ matches _)	     = [f]
 collectMonoBinders (VarMonoBind v expr) 	     = error "collectMonoBinders"
 collectMonoBinders (AndMonoBinds bs1 bs2)
  = collectMonoBinders bs1 ++ collectMonoBinders bs2
@@ -321,7 +323,7 @@ collectMonoBindersAndLocs (AndMonoBinds bs1 bs2)
 collectMonoBindersAndLocs (PatMonoBind pat grhss_w_binds locn)
   = collectPatBinders pat `zip` repeat locn
 
-collectMonoBindersAndLocs (FunMonoBind f matches locn) = [(f, locn)]
+collectMonoBindersAndLocs (FunMonoBind f _ matches locn) = [(f, locn)]
 
 #ifdef DEBUG
 collectMonoBindersAndLocs (VarMonoBind v expr)
diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs
index 0a0397ec27..5b74a4d412 100644
--- a/ghc/compiler/hsSyn/HsExpr.lhs
+++ b/ghc/compiler/hsSyn/HsExpr.lhs
@@ -227,7 +227,7 @@ pprExpr sty (OpApp e1 op e2)
       = ppSep [pp_e1, ppCat [pprOp sty v, pp_e2]]
 
 pprExpr sty (NegApp e)
-  = ppBeside (ppChar '-') (ppParens (pprExpr sty e))
+  = ppBeside (ppChar '-') (pprParendExpr sty e)
 
 pprExpr sty (HsPar e)
   = ppParens (pprExpr sty e)
diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs
index d96e8ecc8c..99fda06062 100644
--- a/ghc/compiler/hsSyn/HsPat.lhs
+++ b/ghc/compiler/hsSyn/HsPat.lhs
@@ -135,12 +135,18 @@ pprInPat sty (ConOpPatIn pat1 op pat2)
 	-- contexts & I'm lazy...); *PatIns are *rarely* printed anyway... (WDP)
 
 pprInPat sty (NegPatIn pat)
-  = ppBeside (ppChar '-') (ppParens (pprInPat sty pat))
+  = let
+	pp_pat = pprInPat sty pat
+    in
+    ppBeside (ppChar '-') (
+    case pat of
+      LitPatIn _ -> pp_pat
+      _          -> ppParens pp_pat
+    )
 
 pprInPat sty (ParPatIn pat)
   = ppParens (pprInPat sty pat)
 
-
 pprInPat sty (ListPatIn pats)
   = ppBesides [ppLbrack, interpp'SP sty pats, ppRbrack]
 pprInPat sty (TuplePatIn pats)
@@ -292,6 +298,8 @@ collectPatBinders (LazyPatIn pat)    = collectPatBinders pat
 collectPatBinders (AsPatIn a pat)    = a : collectPatBinders pat
 collectPatBinders (ConPatIn c pats)  = concat (map collectPatBinders pats)
 collectPatBinders (ConOpPatIn p1 c p2)= collectPatBinders p1 ++ collectPatBinders p2
+collectPatBinders (NegPatIn  pat)    = collectPatBinders pat
+collectPatBinders (ParPatIn  pat)    = collectPatBinders pat
 collectPatBinders (ListPatIn pats)   = concat (map collectPatBinders pats)
 collectPatBinders (TuplePatIn pats)  = concat (map collectPatBinders pats)
 collectPatBinders any_other_pat	     = [ {-no binders-} ]
diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs
index 9d2071362e..3507b79f8c 100644
--- a/ghc/compiler/main/Main.lhs
+++ b/ghc/compiler/main/Main.lhs
@@ -132,12 +132,15 @@ doIt (core_cmds, stg_cmds) input_pgm
     doDump opt_D_dump_rn "Renamer:"
 	(pp_show (ppr pprStyle rn_mod))		`thenMn_`
 
-    exitMn 0
-{- LATER ...
+--    exitMn 0
+{- LATER ... -}
 
     -- ******* TYPECHECKER
     show_pass "TypeCheck" 			`thenMn_`
-    case (case (typecheckModule tc_uniqs idinfo_fm rn_info rn_mod) of
+    let
+	rn_info = trace "Main.rn_info" (\ x -> Nothing, \ x -> Nothing)
+    in
+    case (case (typecheckModule tc_uniqs {-idinfo_fm-} rn_info rn_mod) of
 	    Succeeded (stuff, warns)
 		-> (emptyBag, warns, stuff)
 	    Failed (errs, warns)
@@ -300,7 +303,7 @@ doIt (core_cmds, stg_cmds) input_pgm
     exitMn 0
     } ) }
 
-LATER -}
+{- LATER -}
 
     }
   where
@@ -433,11 +436,11 @@ ppSourceStats (HsModule name version exports imports fixities typedecls typesigs
     count_bind (NonRecBind b) = count_monobinds b
     count_bind (RecBind b)    = count_monobinds b
 
-    count_monobinds EmptyMonoBinds	 = (0,0)
-    count_monobinds (AndMonoBinds b1 b2) = count_monobinds b1 `add2` count_monobinds b2
+    count_monobinds EmptyMonoBinds	  = (0,0)
+    count_monobinds (AndMonoBinds b1 b2)  = count_monobinds b1 `add2` count_monobinds b2
     count_monobinds (PatMonoBind (VarPatIn n) r _) = (1,0)
-    count_monobinds (PatMonoBind p r _)  = (0,1)
-    count_monobinds (FunMonoBind f m _)  = (0,1)
+    count_monobinds (PatMonoBind p r _)   = (0,1)
+    count_monobinds (FunMonoBind f _ m _) = (0,1)
 
     count_sigs sigs = foldr add4 (0,0,0,0) (map sig_info sigs)
 
diff --git a/ghc/compiler/parser/hsparser.y b/ghc/compiler/parser/hsparser.y
index 907e08a0ff..5e9018bc5e 100644
--- a/ghc/compiler/parser/hsparser.y
+++ b/ghc/compiler/parser/hsparser.y
@@ -245,9 +245,9 @@ BOOLEAN inpat;
 
 %type <utree>	exp oexp dexp kexp fexp aexp rbind texps
 		expL oexpL kexpL expLno oexpLno dexpLno kexpLno
-		qual gd leftexp
- 		apat bpat pat apatc conpat dpat fpat opat aapat
- 		dpatk fpatk opatk aapatk rpat
+		vallhs funlhs qual gd leftexp
+ 		pat bpat apat apatc conpat rpat
+ 		patk bpatk apatck conpatk
 
 
 %type <uid>	MINUS DARROW AS LAZY
@@ -835,7 +835,7 @@ instdef :
   	;
 
 
-valdef	:  opatk
+valdef	:  vallhs
 		{
 		  tree fn = function($1);
 		  PREVPATT = $1;
@@ -869,13 +869,23 @@ valdef	:  opatk
 		      FN = NULL;
 		      SAMEFN = 0;
 		    }
-		  else /* lhs is function */
+		  else
 		    $$ = mkfbind($3,startlineno);
 
 		  PREVPATT = NULL;
 		}
 	;
 
+vallhs  : patk					{ $$ = $1; }
+	| patk qvarop pat			{ $$ = mkinfixap($2,$1,$3); }
+	| funlhs				{ $$ = $1; }
+	;
+
+funlhs	:  qvark apat				{ $$ = mkap(mkident($1),$2); }
+	|  funlhs apat				{ $$ = mkap($1,$2); }
+	;
+
+
 valrhs	:  valrhs1 maybe_where			{ $$ = lsing(createpat($1, $2)); }
 	;
 
@@ -1154,90 +1164,6 @@ leftexp	:  LARROW exp				{ $$ = $2; }
 *                                                                     *
 **********************************************************************/
 
-/*
-	The xpatk business is to do with accurately recording
-	the starting line for definitions.
-*/
-
-opatk	:  dpatk
-	|  opatk qop opat %prec MINUS		{ $$ = mkinfixap($2,$1,$3); }
-	;
-
-opat	:  dpat
-	|  opat qop opat %prec MINUS		{ $$ = mkinfixap($2,$1,$3); }
-	;
-
-/*
-  This comes here because of the funny precedence rules concerning
-  prefix minus.
-*/
-
-
-dpat	:  MINUS fpat				{ $$ = mknegate($2); }
-	|  fpat
-	;
-
-	/* Function application */
-fpat	:  fpat aapat				{ $$ = mkap($1,$2); }
-	|  aapat
-	;
-
-dpatk	:  minuskey fpat			{ $$ = mknegate($2); }
-	|  fpatk
-	;
-
-	/* Function application */
-fpatk	:  fpatk aapat				{ $$ = mkap($1,$2); }
-	|  aapatk
-	;
-
-aapat	:  qvar		 			{ $$ = mkident($1); }
-	|  qvar AT apat			 	{ $$ = mkas($1,$3); }
-	|  gcon		 			{ $$ = mkident($1); }
-	|  qcon OCURLY rpats CCURLY		{ $$ = mkrecord($1,$3); }
-	|  lit_constant				{ $$ = mklit($1); }
-	|  WILDCARD				{ $$ = mkwildp(); }
-	|  OPAREN opat CPAREN			{ $$ = mkpar($2); }
-	|  OPAREN opat COMMA pats CPAREN 	{ $$ = mktuple(mklcons($2,$4)); }
-	|  OBRACK pats CBRACK			{ $$ = mkllist($2); }
-	|  LAZY apat				{ $$ = mklazyp($2); }
-	;
-
-
-aapatk	:  qvark	 			{ $$ = mkident($1); }
-	|  qvark AT apat	 		{ $$ = mkas($1,$3); }
-	|  gconk	 			{ $$ = mkident($1); }
-	|  qconk OCURLY rpats CCURLY		{ $$ = mkrecord($1,$3); }
-	|  lit_constant				{ $$ = mklit($1); setstartlineno(); }
-	|  WILDCARD				{ $$ = mkwildp(); setstartlineno(); }
-	|  oparenkey opat CPAREN		{ $$ = mkpar($2); }
-	|  oparenkey opat COMMA pats CPAREN 	{ $$ = mktuple(mklcons($2,$4)); }
-	|  obrackkey pats CBRACK		{ $$ = mkllist($2); }
-	|  lazykey apat				{ $$ = mklazyp($2); }
-	;
-
-gcon	:  qcon
-	|  OBRACK CBRACK			{ $$ = creategid(-1); }
-	|  OPAREN CPAREN			{ $$ = creategid(0); }
-	|  OPAREN commas CPAREN			{ $$ = creategid($2); }
-	;
-
-gconk	:  qconk		 		
-	|  obrackkey CBRACK			{ $$ = creategid(-1); }
-	|  oparenkey CPAREN			{ $$ = creategid(0); }
-	|  oparenkey commas CPAREN		{ $$ = creategid($2); }
-	;
-
-lampats	:  apat lampats				{ $$ = mklcons($1,$2); }
-	|  apat					{ $$ = lsing($1); }
-	/* right recursion? (WDP) */
-	;
-
-pats	:  pat COMMA pats			{ $$ = mklcons($1, $3); }
-	|  pat					{ $$ = lsing($1); }
-    	/* right recursion? (WDP) */
-	;
-
 pat	:  pat qconop bpat			{ $$ = mkinfixap($2,$1,$3); }
 	|  bpat
 	;
@@ -1245,8 +1171,8 @@ pat	:  pat qconop bpat			{ $$ = mkinfixap($2,$1,$3); }
 bpat	:  apatc
  	|  conpat
 	|  qcon OCURLY rpats CCURLY		{ $$ = mkrecord($1,$3); }
-	|  MINUS INTEGER			{ $$ = mklit(mkinteger(ineg($2))); }
-	|  MINUS FLOAT				{ $$ = mklit(mkfloatr(ineg($2))); }
+	|  MINUS INTEGER			{ $$ = mknegate(mklit(mkinteger($2))); }
+	|  MINUS FLOAT				{ $$ = mknegate(mklit(mkfloatr($2))); }
 	;
 
 conpat	:  gcon					{ $$ = mkident($1); }
@@ -1281,6 +1207,16 @@ lit_constant:
 	|  CLITLIT /* yurble yurble */		{ $$ = mkclitlit($1); }
 	;
 
+lampats	:  apat lampats				{ $$ = mklcons($1,$2); }
+	|  apat					{ $$ = lsing($1); }
+	/* right recursion? (WDP) */
+	;
+
+pats	:  pat COMMA pats			{ $$ = mklcons($1, $3); }
+	|  pat					{ $$ = lsing($1); }
+    	/* right recursion? (WDP) */
+	;
+
 rpats	: rpat					{ $$ = lsing($1); }
 	| rpats COMMA rpat			{ $$ = lapp($1,$3); }
 	;
@@ -1290,6 +1226,44 @@ rpat	:  qvar					{ $$ = mkrbind($1,mknothing()); }
 	;
 
 
+patk	:  patk qconop bpat			{ $$ = mkinfixap($2,$1,$3); }
+	|  bpatk
+	;
+
+bpatk	:  apatck
+ 	|  conpatk
+	|  qconk OCURLY rpats CCURLY		{ $$ = mkrecord($1,$3); }
+	|  minuskey INTEGER			{ $$ = mknegate(mklit(mkinteger($2))); }
+	|  minuskey FLOAT			{ $$ = mknegate(mklit(mkfloatr($2))); }
+	;
+
+conpatk	:  gconk				{ $$ = mkident($1); }
+	|  conpatk apat				{ $$ = mkap($1,$2); }
+	;
+
+apatck	:  qvark		 		{ $$ = mkident($1); }
+	|  qvark AT apat			{ $$ = mkas($1,$3); }
+	|  lit_constant				{ $$ = mklit($1); setstartlineno(); }
+	|  WILDCARD				{ $$ = mkwildp(); setstartlineno(); }
+	|  oparenkey pat CPAREN			{ $$ = mkpar($2); }
+	|  oparenkey pat COMMA pats CPAREN 	{ $$ = mktuple(mklcons($2,$4)); }
+	|  obrackkey pats CBRACK		{ $$ = mkllist($2); }
+	|  lazykey apat				{ $$ = mklazyp($2); }
+	;
+
+
+gcon	:  qcon
+	|  OBRACK CBRACK			{ $$ = creategid(-1); }
+	|  OPAREN CPAREN			{ $$ = creategid(0); }
+	|  OPAREN commas CPAREN			{ $$ = creategid($2); }
+	;
+
+gconk	:  qconk
+	|  obrackkey CBRACK			{ $$ = creategid(-1); }
+	|  oparenkey CPAREN			{ $$ = creategid(0); }
+	|  oparenkey commas CPAREN		{ $$ = creategid($2); }
+	;
+
 /**********************************************************************
 *                                                                     *
 *                                                                     *
@@ -1355,9 +1329,6 @@ classkey:   CLASS	{ setstartlineno();
 			}
 	;
 
-minuskey:   MINUS	{ setstartlineno(); }
-	;
-
 modulekey:  MODULE	{ setstartlineno();
 			  if(etags)
 #if 1/*etags*/
@@ -1377,6 +1348,9 @@ obrackkey:  OBRACK	{ setstartlineno(); }
 lazykey	:   LAZY	{ setstartlineno(); }
 	;
 
+minuskey:   MINUS	{ setstartlineno(); }
+	;
+
 
 /**********************************************************************
 *                                                                     *
diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs
index 901af61dfb..553da13e63 100644
--- a/ghc/compiler/prelude/PrelInfo.lhs
+++ b/ghc/compiler/prelude/PrelInfo.lhs
@@ -110,7 +110,7 @@ import CmdLineOpts	( opt_HideBuiltinNames,
 import FiniteMap	( FiniteMap, emptyFM, listToFM )
 import Id		( mkTupleCon, GenId, Id(..) )
 import Maybes		( catMaybes )
-import Name		( mkBuiltinName, getOrigName )
+import Name		( getOrigName )
 import RnHsSyn		( RnName(..) )
 import TyCon		( tyConDataCons, mkFunTyCon, mkTupleTyCon, TyCon )
 import Type
diff --git a/ghc/compiler/reader/PrefixToHs.lhs b/ghc/compiler/reader/PrefixToHs.lhs
index b24230c68c..033ed415f3 100644
--- a/ghc/compiler/reader/PrefixToHs.lhs
+++ b/ghc/compiler/reader/PrefixToHs.lhs
@@ -134,9 +134,9 @@ mkMonoBindsAndSigs sf sig_cvtr fbs
 
     mangle_bind (b_acc, s_acc) (RdrFunctionBinding srcline patbindings)
 	    -- must be a function binding...
-      = case (cvFunMonoBind sf patbindings) of { (var, matches) ->
+      = case (cvFunMonoBind sf patbindings) of { (var, inf, matches) ->
 	(b_acc `AndMonoBinds`
-	 FunMonoBind var matches (mkSrcLoc2 sf srcline), s_acc)
+	 FunMonoBind var inf matches (mkSrcLoc2 sf srcline), s_acc)
 	}
 \end{code}
 
@@ -149,14 +149,21 @@ cvPatMonoBind sf (RdrMatch_NoGuard srcline srcfun pat expr binding)
 cvPatMonoBind sf (RdrMatch_Guards srcline srcfun pat guardedexprs binding)
   = (pat, map (cvGRHS sf srcline) guardedexprs, cvBinds sf cvValSig binding)
 
-cvFunMonoBind :: SrcFile -> [RdrMatch] -> (RdrName {-VarName-}, [RdrNameMatch])
+cvFunMonoBind :: SrcFile -> [RdrMatch] -> (RdrName {-VarName-}, Bool {-InfixDefn-}, [RdrNameMatch])
 
 cvFunMonoBind sf matches
-  = (srcfun {- cheating ... -}, cvMatches sf False matches)
+  = (head srcfuns, head infixdefs, cvMatches sf False matches)
   where
-    srcfun = case (head matches) of
-	       RdrMatch_NoGuard _ sfun _ _ _ -> sfun
-	       RdrMatch_Guards  _ sfun _ _ _ -> sfun
+    (srcfuns, infixdefs) = unzip (map get_mdef matches)
+    -- ToDo: Check for consistent srcfun and infixdef
+
+    get_mdef (RdrMatch_NoGuard _ sfun pat _ _) = get_pdef pat
+    get_mdef (RdrMatch_Guards  _ sfun pat _ _) = get_pdef pat
+
+    get_pdef (ConPatIn fn _)     = (fn, False)
+    get_pdef (ConOpPatIn _ op _) = (op, True)
+    get_pdef (ParPatIn pat)	 = get_pdef pat
+
 
 cvMatches :: SrcFile -> Bool -> [RdrMatch] -> [RdrNameMatch]
 cvMatch	  :: SrcFile -> Bool -> RdrMatch   -> RdrNameMatch
@@ -173,10 +180,11 @@ cvMatch sf is_case rdr_match
 	  -- we most certainly want to keep it!	 Hence the monkey busines...
 
 	  (if is_case then -- just one pattern: leave it untouched...
-	      [pat']
-	   else
-	      case pat' of
-		ConPatIn _ pats -> pats
+	      [pat]
+	   else		   -- function pattern; extract arg patterns...
+	      case pat of ConPatIn fn pats    -> pats
+			  ConOpPatIn p1 op p2 -> [p1,p2]
+			  ParPatIn pat	      -> panic "PrefixToHs.cvMatch:ParPatIn"
 	  )
   where
     (pat, binding, guarded_exprs)
@@ -184,17 +192,7 @@ cvMatch sf is_case rdr_match
 	  RdrMatch_NoGuard ln b c expr    d -> (c,d, [OtherwiseGRHS expr (mkSrcLoc2 sf ln)])
 	  RdrMatch_Guards  ln b c gd_exps d -> (c,d, map (cvGRHS sf ln) gd_exps)
 
-    ---------------------
-    pat' = doctor_pat pat
-
-    -- a ConOpPatIn in the corner may be handled by converting it to
-    -- ConPatIn...
-
-    doctor_pat (ConOpPatIn p1 op p2) = ConPatIn op [p1, p2]
-    doctor_pat other_pat	     = other_pat
-
 cvGRHS :: SrcFile -> SrcLine -> (RdrNameHsExpr, RdrNameHsExpr) -> RdrNameGRHS
-
 cvGRHS sf sl (g, e) = GRHS g e (mkSrcLoc2 sf sl)
 \end{code}
 
diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs
index d934449ca3..cab11e558f 100644
--- a/ghc/compiler/rename/RnBinds.lhs
+++ b/ghc/compiler/rename/RnBinds.lhs
@@ -27,7 +27,7 @@ import HsPragmas	( isNoGenPragmas, noGenPragmas )
 import RdrHsSyn
 import RnHsSyn
 import RnMonad
-import RnExpr		( rnMatch, rnGRHSsAndBinds, rnPat )
+import RnExpr		( rnMatch, rnGRHSsAndBinds, rnPat, checkPrecInfixBind )
 
 import CmdLineOpts	( opt_SigsRequired )
 import Digraph		( stronglyConnComp )
@@ -169,13 +169,14 @@ rnMethodBinds class_name EmptyMonoBinds = returnRn EmptyMonoBinds
 
 rnMethodBinds class_name (AndMonoBinds mb1 mb2)
   = andRn AndMonoBinds (rnMethodBinds class_name mb1)
-			(rnMethodBinds class_name mb2)
+		       (rnMethodBinds class_name mb2)
 
-rnMethodBinds class_name (FunMonoBind occname matches locn)
-  = pushSrcLocRn locn			$
-    lookupClassOp class_name occname  	`thenRn` \ op_name ->
-    mapAndUnzipRn rnMatch matches	`thenRn` \ (new_matches, _) ->
-    returnRn (FunMonoBind op_name new_matches locn)
+rnMethodBinds class_name (FunMonoBind occname inf matches locn)
+  = pushSrcLocRn locn				$
+    lookupClassOp class_name occname  		`thenRn` \ op_name ->
+    mapAndUnzipRn rnMatch matches		`thenRn` \ (new_matches, _) ->
+--  checkPrecInfixBind inf op_name new_matches 	`thenRn_`
+    returnRn (FunMonoBind op_name inf new_matches locn)
 
 rnMethodBinds class_name (PatMonoBind (VarPatIn occname) grhss_and_binds locn)
   = pushSrcLocRn locn			$
@@ -346,10 +347,11 @@ flattenMonoBinds uniq sigs (PatMonoBind pat grhss_and_binds locn)
 	 )]
     )
 
-flattenMonoBinds uniq sigs (FunMonoBind name matches locn)
-  = pushSrcLocRn locn			$
-    lookupValue name			`thenRn` \ name' ->
-    mapAndUnzipRn rnMatch matches	`thenRn` \ (new_matches, fv_lists) ->
+flattenMonoBinds uniq sigs (FunMonoBind name inf matches locn)
+  = pushSrcLocRn locn				$
+    lookupValue name				`thenRn` \ name' ->
+    mapAndUnzipRn rnMatch matches		`thenRn` \ (new_matches, fv_lists) ->
+--  checkPrecInfixBind inf name' new_matches	`thenRn_`
     let
 	fvs = unionManyUniqSets fv_lists
 
@@ -362,7 +364,7 @@ flattenMonoBinds uniq sigs (FunMonoBind name matches locn)
       [(uniq,
 	unitUniqSet name',
 	fvs `unionUniqSets` sigs_fvs,
-	FunMonoBind name' new_matches locn,
+	FunMonoBind name' inf new_matches locn,
 	sigs_for_me
 	)]
     )
diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index 04db620b99..0b024e9b93 100644
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -13,7 +13,8 @@ free variables.
 #include "HsVersions.h"
 
 module RnExpr (
-	rnMatch, rnGRHSsAndBinds, rnPat
+	rnMatch, rnGRHSsAndBinds, rnPat,
+	checkPrecInfixBind
    ) where
 
 import Ubiq
@@ -74,13 +75,14 @@ rnPat (ConOpPatIn pat1 name pat2)
 
 rnPat neg@(NegPatIn pat)
   = getSrcLocRn		`thenRn` \ src_loc ->
-    addErrIfRn (not (is_lit pat)) (negPatErr neg src_loc)
+    addErrIfRn (not (valid_neg_pat pat)) (negPatErr neg src_loc)
 			`thenRn_`
     rnPat pat		`thenRn` \ pat' ->
     returnRn (NegPatIn pat')
   where
-    is_lit (LitPatIn _) = True
-    is_lit _            = False
+    valid_neg_pat (LitPatIn (HsInt  _)) = True
+    valid_neg_pat (LitPatIn (HsFrac _)) = True
+    valid_neg_pat _                     = False
 
 rnPat (ParPatIn pat)
   = rnPat pat		`thenRn` \ pat' ->
@@ -200,7 +202,7 @@ rnExpr (HsVar v)
   where
     fv_set vname@(RnName n)
       | isLocallyDefinedName n = unitUniqSet vname
-      | otherwise	       = emptyUniqSet
+    fv_set _		       = emptyUniqSet
 
 rnExpr (HsLit lit)
   = returnRn (HsLit lit, emptyUniqSet)
@@ -483,7 +485,7 @@ precParsePat pat@(ConOpPatIn (ConOpPatIn p11 op1 p12) op p2)
 precParsePat pat = returnRn pat
 
 
-data INFIX = INFIXL | INFIXR | INFIXN
+data INFIX = INFIXL | INFIXR | INFIXN deriving Eq
 
 lookupFixity :: RnName -> RnM_Fixes s (INFIX, Int)
 lookupFixity op
@@ -496,6 +498,42 @@ lookupFixity op
 \end{code}
 
 \begin{code}
+checkPrecInfixBind :: Bool -> RnName -> [RenamedPat] -> RnM_Fixes s ()
+
+checkPrecInfixBind False fn pats
+  = returnRn ()
+checkPrecInfixBind True op [p1,p2]
+  = checkPrec op p1 False	`thenRn_`
+    checkPrec op p2 True
+
+checkPrec op (ConOpPatIn _ op1 _) right
+  = lookupFixity op	`thenRn` \ (op_fix, op_prec) ->
+    lookupFixity op1	`thenRn` \ (op1_fix, op1_prec) ->
+    getSrcLocRn 	`thenRn` \ src_loc ->
+    let
+	inf_ok = op1_prec > op_prec || 
+	         op1_prec == op_prec &&
+		 (op1_fix == INFIXR && op_fix == INFIXR && right ||
+		  op1_fix == INFIXL && op_fix == INFIXL && not right)
+
+	info  = (op,op_fix,op_prec)
+	info1 = (op1,op1_fix,op1_prec)
+	(infol, infor) = if right then (info, info1) else (info1, info)
+
+	inf_err = precParseErr infol infor src_loc
+    in
+    addErrIfRn (not inf_ok) inf_err
+
+checkPrec op (NegPatIn _) right
+  = lookupFixity op	`thenRn` \ (op_fix, op_prec) ->
+    getSrcLocRn 	`thenRn` \ src_loc ->
+    addErrIfRn (6 < op_prec) (precParseNegPatErr (op,op_fix,op_prec) src_loc)
+
+checkPrec op pat right
+  = returnRn ()
+\end{code}
+
+\begin{code}
 negPatErr pat src_loc
   = addErrLoc src_loc "prefix `-' not applied to literal in pattern" ( \sty ->
     ppr sty pat) 
diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs
index 7f4b74b43e..432991ce08 100644
--- a/ghc/compiler/rename/RnHsSyn.lhs
+++ b/ghc/compiler/rename/RnHsSyn.lhs
@@ -13,7 +13,9 @@ import Ubiq
 import HsSyn
 
 import Id		( GenId, Id(..) )
-import Name		( isLocalName, nameUnique, Name, RdrName )
+import Name		( isLocalName, nameUnique, Name, RdrName(..){-ToDo: rm ..-},
+			  mkLocalName{-ToDo:rm-}
+			)
 import Outputable	( Outputable(..){-instance * []-} )
 import PprStyle		( PprStyle(..) )
 import PprType		( GenType, GenTyVar, TyCon )
@@ -21,7 +23,7 @@ import Pretty
 import TyCon		( TyCon )
 import TyVar		( GenTyVar )
 import Unique		( Unique )
-import Util		( panic, pprPanic )
+import Util		( panic, pprPanic, pprTrace{-ToDo:rm-} )
 \end{code}
 
 \begin{code}
@@ -100,7 +102,12 @@ instance NamedThing RnName where
     getName (RnClass n _)     = n
     getName (RnClassOp n _)   = n
     getName (RnImplicit n)    = n
-    getName (RnUnbound occ)   = pprPanic "getRnName:RnUnbound" (ppr PprDebug occ)
+    getName (RnUnbound occ)   = pprTrace "getRnName:RnUnbound: " (ppr PprDebug occ)
+				(case occ of
+				   Unqual n -> mkLocalName bottom n bottom2
+				   Qual m n -> mkLocalName bottom n bottom2)
+			      where bottom = panic "getRnName: unique"
+				    bottom2 = panic "getRnName: srcloc"
 
 instance Outputable RnName where
 #ifdef DEBUG
diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs
index b0ec1905be..dcbf83195f 100644
--- a/ghc/compiler/rename/RnNames.lhs
+++ b/ghc/compiler/rename/RnNames.lhs
@@ -189,7 +189,7 @@ doBind (RecBind mbind)    = doMBinds mbind
 
 doMBinds EmptyMonoBinds 			= returnRn emptyBag
 doMBinds (PatMonoBind pat grhss_and_binds locn) = doPat locn pat
-doMBinds (FunMonoBind p_name _ locn) 	        = doName locn p_name
+doMBinds (FunMonoBind p_name _ _ locn) 	        = doName locn p_name
 doMBinds (AndMonoBinds mbinds1 mbinds2)
   = andRn unionBags (doMBinds mbinds1) (doMBinds mbinds2)
 
@@ -214,8 +214,7 @@ doPat locn (RecPatIn name fields)
   = mapRn (doField locn) fields `thenRn` \ fields_s ->
     returnRn (unionManyBags fields_s)
 
-doField locn (field, _, True{-pun-}) = doName locn field
-doField locn (field, pat, _)	     = doPat locn pat
+doField locn (_, pat, _) = doPat locn pat
 
 doName locn rdr
   = newGlobalName locn Nothing rdr `thenRn` \ name ->
diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index 16cd506373..edcb5fefd0 100644
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -66,14 +66,14 @@ rnSource imp_mods imp_fixes (HsModule mod version exports _ fixes
     rnExports (mod:imp_mods) exports	`thenRn` \ exported_fn ->
     rnFixes fixes			`thenRn` \ src_fixes ->
     let
-	pair_name (InfixL n i) = (n, i)
-	pair_name (InfixR n i) = (n, i)
-	pair_name (InfixN n i) = (n, i)
+	pair_name inf@(InfixL n _) = (n, inf)
+	pair_name inf@(InfixR n _) = (n, inf)
+	pair_name inf@(InfixN n _) = (n, inf)
 
 	imp_fixes_fm = listToUFM (map pair_name (bagToList imp_fixes))
 	all_fixes_fm = addListToUFM imp_fixes_fm (map pair_name src_fixes)
     in
-    setExtraRn {-all_fixes_fm-}(panic "rnSource:all_fixes_fm") $
+    setExtraRn all_fixes_fm $
 
     mapRn rnTyDecl	ty_decls	`thenRn` \ new_ty_decls ->
     mapRn rnSpecDataSig specdata_sigs	`thenRn` \ new_specdata_sigs ->
@@ -87,8 +87,7 @@ rnSource imp_mods imp_fixes (HsModule mod version exports _ fixes
 
     returnRn (
 	      HsModule mod version
-		trashed_exports trashed_imports
-		{-new_fixes-}(panic "rnSource:new_fixes (Hi, Patrick!)")
+		trashed_exports trashed_imports	src_fixes
 		new_ty_decls new_specdata_sigs new_class_decls
 		new_inst_decls new_specinst_sigs new_defaults
 		new_binds [] src_loc,
@@ -96,8 +95,8 @@ rnSource imp_mods imp_fixes (HsModule mod version exports _ fixes
 	      occ_info
 	     )
   where
-    trashed_exports = panic "rnSource:trashed_exports"
-    trashed_imports = panic "rnSource:trashed_imports"
+    trashed_exports = trace "rnSource:trashed_exports" Nothing
+    trashed_imports = trace "rnSource:trashed_imports" []
 \end{code}
 
 %*********************************************************
diff --git a/ghc/compiler/typecheck/GenSpecEtc.lhs b/ghc/compiler/typecheck/GenSpecEtc.lhs
index 438e59a0d8..087206a612 100644
--- a/ghc/compiler/typecheck/GenSpecEtc.lhs
+++ b/ghc/compiler/typecheck/GenSpecEtc.lhs
@@ -312,7 +312,7 @@ is_elem v vs = isIn "isUnResMono" v vs
 isUnResMono sigs (PatMonoBind (VarPat (TcId v)) _ _)	= v `is_elem` sigs
 isUnResMono sigs (PatMonoBind other      _ _)		= False
 isUnResMono sigs (VarMonoBind (TcId v) _)		= v `is_elem` sigs
-isUnResMono sigs (FunMonoBind _ _ _)			= True
+isUnResMono sigs (FunMonoBind _ _ _ _)			= True
 isUnResMono sigs (AndMonoBinds mb1 mb2)			= isUnResMono sigs mb1 &&
 							  isUnResMono sigs mb2
 isUnResMono sigs EmptyMonoBinds				= True
diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index 7bd91f9897..2fb8408a97 100644
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -421,11 +421,11 @@ tcMonoBinds bind@(PatMonoBind pat grhss_and_binds locn)
     returnTc (PatMonoBind pat2 grhss_and_binds2 locn,
 	      plusLIE lie_pat lie)
 
-tcMonoBinds (FunMonoBind name matches locn)
+tcMonoBinds (FunMonoBind name inf matches locn)
   = tcAddSrcLoc locn				$
     tcLookupLocalValueOK "tcMonoBinds" name	`thenNF_Tc` \ id ->
     tcMatchesFun name (idType id) matches	`thenTc` \ (matches', lie) ->
-    returnTc (FunMonoBind (TcId id) matches' locn, lie)
+    returnTc (FunMonoBind (TcId id) inf matches' locn, lie)
 \end{code}
 
 %************************************************************************
diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs
index ea4828a9ea..b1bbb956d7 100644
--- a/ghc/compiler/typecheck/TcDeriv.lhs
+++ b/ghc/compiler/typecheck/TcDeriv.lhs
@@ -33,7 +33,7 @@ import TcSimplify	( tcSimplifyThetas )
 import RnUtils		( GlobalNameMappers(..), GlobalNameMapper(..) )
 --import RnBinds4		( rnMethodBinds, rnTopBinds )
 
-import Bag		( Bag, isEmptyBag, unionBags, listToBag )
+import Bag		( emptyBag{-ToDo:rm-}, Bag, isEmptyBag, unionBags, listToBag )
 import Class		( GenClass, getClassKey )
 import CmdLineOpts	( opt_CompilingPrelude )
 import ErrUtils		( pprBagOfErrors, addErrLoc, Error(..) )
@@ -162,7 +162,9 @@ tcDeriving  :: Module			-- name of module under scrutiny
 		      RenamedHsBinds,	-- Extra generated bindings
 		      PprStyle -> Pretty)  -- Printable derived instance decls;
 				     	   -- for debugging via -ddump-derivings.
-tcDeriving = panic "tcDeriving: ToDo LATER"
+
+tcDeriving modname renamer_name_funs inst_decl_infos_in fixities
+  = returnTc (trace "tcDeriving:ToDo" (emptyBag, EmptyBinds, \ x -> ppNil))
 {- LATER:
 
 tcDeriving modname renamer_name_funs inst_decl_infos_in fixities
diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index 809e08f9ff..2cabcf1ab3 100644
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -166,6 +166,10 @@ tcExpr (HsLit lit@(HsString str))
 %************************************************************************
 
 \begin{code}
+tcExpr (HsPar expr) = tcExpr expr
+
+tcExpr (NegApp expr) = panic "tcExpr:NegApp"
+
 tcExpr (HsLam match)
   = tcMatch match	`thenTc` \ (match',lie,ty) ->
     returnTc (HsLam match', lie, ty)
diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs
index d4147869bb..0baa230826 100644
--- a/ghc/compiler/typecheck/TcGenDeriv.lhs
+++ b/ghc/compiler/typecheck/TcGenDeriv.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 \section[TcGenDeriv]{Generating derived instance declarations}
 
@@ -830,7 +830,7 @@ mk_easy_FunMonoBind :: RdrName -> [RdrNamePat]
 		    -> RdrNameMonoBinds
 
 mk_easy_FunMonoBind fun pats binds expr
-  = FunMonoBind fun [mk_easy_Match pats binds expr] mkGeneratedSrcLoc
+  = FunMonoBind fun False{-not infix-} [mk_easy_Match pats binds expr] mkGeneratedSrcLoc
 
 mk_easy_Match pats binds expr
   = foldr PatMatch
@@ -849,7 +849,7 @@ mk_FunMonoBind	:: RdrName
 
 mk_FunMonoBind fun [] = panic "TcGenDeriv:mk_FunMonoBind"
 mk_FunMonoBind fun pats_and_exprs
-  = FunMonoBind fun (map mk_match pats_and_exprs) mkGeneratedSrcLoc
+  = FunMonoBind fun False{-not infix-} (map mk_match pats_and_exprs) mkGeneratedSrcLoc
   where
     mk_match (pats, expr)
       = foldr PatMatch
diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index 24054217dc..8369296627 100644
--- a/ghc/compiler/typecheck/TcHsSyn.lhs
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -231,10 +231,10 @@ zonkMonoBinds (VarMonoBind var expr)
     zonkExpr expr	`thenNF_Tc` \ new_expr ->
     returnNF_Tc (VarMonoBind new_var new_expr)
 
-zonkMonoBinds (FunMonoBind name ms locn)
+zonkMonoBinds (FunMonoBind name inf ms locn)
   = zonkId name			`thenNF_Tc` \ new_name ->
     mapNF_Tc zonkMatch ms	`thenNF_Tc` \ new_ms ->
-    returnNF_Tc (FunMonoBind new_name new_ms locn)
+    returnNF_Tc (FunMonoBind new_name inf new_ms locn)
 \end{code}
 
 %************************************************************************
diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index 62379841eb..0d54c22294 100644
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -651,7 +651,7 @@ processInstBinds1 inst_tyvars avail_insts method_ids mbind
     -- Renamer has reduced us to these two cases.
     let
 	(op,locn) = case mbind of
-		      FunMonoBind op _ locn	       -> (op, locn)
+		      FunMonoBind op _ _ locn	       -> (op, locn)
 		      PatMonoBind (VarPatIn op) _ locn -> (op, locn)
 
         occ    = getLocalName op
@@ -724,9 +724,9 @@ processInstBinds1 inst_tyvars avail_insts method_ids mbind
 tcMethodBind :: TcIdOcc s -> TcType s -> RenamedMonoBinds
 	     -> TcM s (TcMonoBinds s, LIE s)
 
-tcMethodBind meth_id meth_ty (FunMonoBind name matches locn)
+tcMethodBind meth_id meth_ty (FunMonoBind name inf matches locn)
   = tcMatchesFun name meth_ty matches `thenTc` \ (rhs', lie) ->
-    returnTc (FunMonoBind meth_id rhs' locn, lie)
+    returnTc (FunMonoBind meth_id inf rhs' locn, lie)
 
 tcMethodBind meth_id meth_ty pbind@(PatMonoBind pat grhss_and_binds locn)
   -- pat is sure to be a (VarPatIn op)
diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs
index 16b0ca28bc..9c8d253510 100644
--- a/ghc/compiler/typecheck/TcPat.lhs
+++ b/ghc/compiler/typecheck/TcPat.lhs
@@ -72,9 +72,12 @@ tcPat pat_in@(AsPatIn name pat)
     unifyTauTy (idType id) ty		`thenTc_`
     returnTc (AsPat (TcId id) pat', lie, ty)
 
-tcPat (WildPatIn)
+tcPat WildPatIn
   = newTyVarTy mkTypeKind	`thenNF_Tc` \ tyvar_ty ->
     returnTc (WildPat tyvar_ty, emptyLIE, tyvar_ty)
+
+tcPat (ParPatIn parend_pat)
+  = tcPat parend_pat
 \end{code}
 
 %************************************************************************
diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs
index 5ba046388a..9597b938e3 100644
--- a/ghc/compiler/types/PprType.lhs
+++ b/ghc/compiler/types/PprType.lhs
@@ -178,8 +178,9 @@ ppr_corner sty env ctxt_prec (TyConTy FunTyCon usage) arg_tys
   where
     (ty1:ty2:_) = arg_tys
 
-ppr_corner sty env ctxt_prec (TyConTy (TupleTyCon a) usage) arg_tys
-  = ASSERT(length arg_tys == a)
+ppr_corner sty env ctxt_prec (TyConTy (TupleTyCon _ _ a) usage) arg_tys
+  = --ASSERT(length arg_tys == a)
+    (if (length arg_tys /= a) then pprTrace "ppr_corner:" (ppCat [ppInt a, ppInterleave ppComma (map (pprGenType PprDebug) arg_tys)]) else id) $
     ppBesides [ppLparen, arg_tys_w_commas, ppRparen]
   where
     arg_tys_w_commas = ppIntersperse pp'SP (map (ppr_ty sty env tOP_PREC) arg_tys)
@@ -312,7 +313,7 @@ showTyCon sty tycon = ppShow 80 (pprTyCon sty tycon)
 pprTyCon :: PprStyle -> TyCon -> Pretty
 
 pprTyCon sty FunTyCon 		        = ppStr "(->)"
-pprTyCon sty (TupleTyCon arity)	        = ppBeside (ppPStr SLIT("Tuple")) (ppInt arity)
+pprTyCon sty (TupleTyCon _ name _)      = ppr sty name
 pprTyCon sty (PrimTyCon uniq name kind) = ppr sty name
 
 pprTyCon sty tycon@(DataTyCon uniq name kind tyvars ctxt cons derivings nd)
@@ -524,9 +525,9 @@ pprTyCon sty@PprInterface this_tycon@(DataTyCon u n k vs ctxt cons derivings dat
 
     pp_NONE = ppPStr SLIT("_N_")
 
-pprTyCon PprInterface (TupleTyCon a) specs
+pprTyCon PprInterface (TupleTyCon _ name _) specs
   = ASSERT (null specs)
-    ppCat [ ppStr "{- Tuple", ppInt a, ppStr "-}" ]
+    ppCat [ ppStr "{- ", ppr PprForUser name, ppStr "-}" ]
 
 pprTyCon PprInterface (PrimTyCon k n a kind_fn) specs
   = ASSERT (null specs)
diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs
index 87dfc622d6..e0a6ed282c 100644
--- a/ghc/compiler/types/TyCon.lhs
+++ b/ghc/compiler/types/TyCon.lhs
@@ -51,7 +51,9 @@ import Kind		( Kind, mkBoxedTypeKind, mkArrowKind, resultKind, argKind )
 import PrelMods		( pRELUDE_BUILTIN )
 
 import Maybes
-import Name		( Name, RdrName(..), appendRdr, nameUnique )
+import Name		( Name, RdrName(..), appendRdr, nameUnique,
+			  mkTupleTyConName, mkFunTyConName
+			)
 import Unique		( Unique, funTyConKey, mkTupleTyConUnique )
 import Pretty		( Pretty(..), PrettyRep )
 import PprStyle		( PprStyle )
@@ -74,7 +76,10 @@ data TyCon
 		[Class]		-- Classes which have derived instances
 		NewOrData
 
-  | TupleTyCon	Arity	-- just a special case of DataTyCon
+  | TupleTyCon	Unique		-- cached
+		Name		-- again, we could do without this, but
+				-- it makes life somewhat easier
+		Arity	-- just a special case of DataTyCon
 			-- Kind = BoxedTypeKind
 			--      -> ... (n times) ...
 			--	-> BoxedTypeKind
@@ -113,9 +118,14 @@ data NewOrData
 
 \begin{code}
 mkFunTyCon   = FunTyCon
-mkTupleTyCon = TupleTyCon
 mkSpecTyCon  = SpecTyCon
 
+mkTupleTyCon arity
+  = TupleTyCon u n arity 
+  where
+    n = mkTupleTyConName arity
+    u = uniqueOf n
+
 mkDataTyCon name
   = DataTyCon (nameUnique name) name
 mkPrimTyCon name
@@ -160,7 +170,7 @@ tyConKind (SpecTyCon tc tys)
     spec kind (Nothing : tys) =
       argKind kind `mkArrowKind` spec (resultKind kind) tys
 
-tyConKind (TupleTyCon n)
+tyConKind (TupleTyCon _ _ n)
   = mkArrow n
    where
     mkArrow 0 = mkBoxedTypeKind
@@ -173,7 +183,7 @@ tyConKind (TupleTyCon n)
 tyConUnique :: TyCon -> Unique
 tyConUnique FunTyCon			   = funTyConKey
 tyConUnique (DataTyCon uniq _ _ _ _ _ _ _) = uniq
-tyConUnique (TupleTyCon a) 		   = mkTupleTyConUnique a
+tyConUnique (TupleTyCon uniq _ _)	   = uniq
 tyConUnique (PrimTyCon uniq _ _) 	   = uniq
 tyConUnique (SynTyCon uniq _ _ _ _ _)      = uniq
 tyConUnique (SpecTyCon _ _ )		   = panic "tyConUnique:SpecTyCon"
@@ -181,7 +191,7 @@ tyConUnique (SpecTyCon _ _ )		   = panic "tyConUnique:SpecTyCon"
 tyConArity :: TyCon -> Arity
 tyConArity FunTyCon			 = 2
 tyConArity (DataTyCon _ _ _ tvs _ _ _ _) = length tvs
-tyConArity (TupleTyCon arity)		 = arity
+tyConArity (TupleTyCon _ _ arity)	 = arity
 tyConArity (PrimTyCon _ _ _)		 = 0	-- ??
 tyConArity (SpecTyCon _ _)		 = 0
 tyConArity (SynTyCon _ _ _ arity _ _)    = arity
@@ -195,7 +205,7 @@ synTyConArity _				 = Nothing
 tyConTyVars :: TyCon -> [TyVar]
 tyConTyVars FunTyCon			  = [alphaTyVar,betaTyVar]
 tyConTyVars (DataTyCon _ _ _ tvs _ _ _ _) = tvs
-tyConTyVars (TupleTyCon arity)		  = take arity alphaTyVars
+tyConTyVars (TupleTyCon _ _ arity)	  = take arity alphaTyVars
 tyConTyVars (SynTyCon _ _ _ _ tvs _)      = tvs
 tyConTyVars (PrimTyCon _ _ _) 	     	  = panic "tyConTyVars:PrimTyCon"
 tyConTyVars (SpecTyCon _ _ ) 	     	  = panic "tyConTyVars:SpecTyCon"
@@ -206,14 +216,14 @@ tyConDataCons :: TyCon -> [Id]
 tyConFamilySize  :: TyCon -> Int
 
 tyConDataCons (DataTyCon _ _ _ _ _ data_cons _ _) = data_cons
-tyConDataCons (TupleTyCon a)			  = [mkTupleCon a]
+tyConDataCons (TupleTyCon _ _ a)		  = [mkTupleCon a]
 tyConDataCons other				  = []
 	-- You may think this last equation should fail,
 	-- but it's quite convenient to return no constructors for
 	-- a synonym; see for example the call in TcTyClsDecls.
 
 tyConFamilySize (DataTyCon _ _ _ _ _ data_cons _ _) = length data_cons
-tyConFamilySize (TupleTyCon a)			    = 1
+tyConFamilySize (TupleTyCon _ _ _)		    = 1
 \end{code}
 
 \begin{code}
@@ -229,14 +239,15 @@ getSynTyConDefn (SynTyCon _ _ _ _ tyvars ty) = (tyvars,ty)
 
 \begin{code}
 maybeTyConSingleCon :: TyCon -> Maybe Id
-maybeTyConSingleCon (TupleTyCon arity)	          = Just (mkTupleCon arity)
+
+maybeTyConSingleCon (TupleTyCon _ _ arity)        = Just (mkTupleCon arity)
 maybeTyConSingleCon (DataTyCon _ _ _ _ _ [c] _ _) = Just c
 maybeTyConSingleCon (DataTyCon _ _ _ _ _ _   _ _) = Nothing
 maybeTyConSingleCon (PrimTyCon _ _ _)	          = Nothing
 maybeTyConSingleCon (SpecTyCon tc tys)            = panic "maybeTyConSingleCon:SpecTyCon"
 						  -- requires DataCons of TyCon
 
-isEnumerationTyCon (TupleTyCon arity)
+isEnumerationTyCon (TupleTyCon _ _ arity)
   = arity == 0
 isEnumerationTyCon (DataTyCon _ _ _ _ _ data_cons _ _)
   = not (null data_cons) && all is_nullary data_cons
@@ -274,7 +285,7 @@ instance Ord3 TyCon where
   cmp FunTyCon		          FunTyCon		      = EQ_
   cmp (DataTyCon a _ _ _ _ _ _ _) (DataTyCon b _ _ _ _ _ _ _) = a `cmp` b
   cmp (SynTyCon a _ _ _ _ _)      (SynTyCon b _ _ _ _ _)      = a `cmp` b
-  cmp (TupleTyCon a)	          (TupleTyCon b)	      = a `cmp` b
+  cmp (TupleTyCon _ _ a)          (TupleTyCon _ _ b)	      = a `cmp` b
   cmp (PrimTyCon a _ _)		  (PrimTyCon b _ _)	      = a `cmp` b
   cmp (SpecTyCon tc1 mtys1)	  (SpecTyCon tc2 mtys2)
     = panic# "cmp on SpecTyCons" -- case (tc1 `cmp` tc2) of { EQ_ -> mtys1 `cmp` mtys2; xxx -> xxx }
@@ -288,7 +299,7 @@ instance Ord3 TyCon where
       tag2 = tag_TyCon other_2
       tag_TyCon FunTyCon    		    = ILIT(1)
       tag_TyCon (DataTyCon _ _ _ _ _ _ _ _) = ILIT(2)
-      tag_TyCon (TupleTyCon _)		    = ILIT(3)
+      tag_TyCon (TupleTyCon _ _ _)	    = ILIT(3)
       tag_TyCon (PrimTyCon  _ _ _)	    = ILIT(4)
       tag_TyCon (SpecTyCon  _ _) 	    = ILIT(5)
 
@@ -317,10 +328,8 @@ instance NamedThing TyCon where
     getName (PrimTyCon _ n _)		= n
     getName (SpecTyCon tc _)		= getName tc
     getName (SynTyCon _ n _ _ _ _)	= n
-{- LATER:
-    getName FunTyCon			= (pRELUDE_BUILTIN, SLIT("(->)"))
-    getName (TupleTyCon a)		= (pRELUDE_BUILTIN, _PK_ ("Tuple" ++ show a))
--}
+    getName FunTyCon			= mkFunTyConName
+    getName (TupleTyCon _ n _)		= n
     getName tc				= panic "TyCon.getName"
 
 {- LATER:
diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
index 0d25048aa1..0fd31ef62f 100644
--- a/ghc/compiler/types/Type.lhs
+++ b/ghc/compiler/types/Type.lhs
@@ -41,6 +41,11 @@ import IdLoop	 -- for paranoia checking
 import TyLoop	 -- for paranoia checking
 import PrelLoop  -- for paranoia checking
 
+-- ToDo:rm 
+--import PprType	( pprGenType ) -- ToDo: rm
+--import PprStyle ( PprStyle(..) )
+--import Util	( pprPanic )
+
 -- friends:
 import Class	( getClassSig, getClassOpLocalType, GenClass{-instances-} )
 import Kind	( mkBoxedTypeKind, resultKind )
@@ -368,7 +373,7 @@ getAppDataTyCon ty
   = case maybeAppDataTyCon ty of
       Just stuff -> stuff
 #ifdef DEBUG
-      Nothing    -> panic "Type.getAppDataTyCon" -- (ppr PprShowAll ty)
+      Nothing    -> panic "Type.getAppDataTyCon: " -- (pprGenType PprShowAll ty)
 #endif
 
 
diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs
index aeb06ebbae..09fcdc78fc 100644
--- a/ghc/compiler/utils/Outputable.lhs
+++ b/ghc/compiler/utils/Outputable.lhs
@@ -46,7 +46,7 @@ interppSP  sty xs = ppIntersperse ppSP (map (ppr sty) xs)
 
 interpp'SP :: Outputable a => PprStyle -> [a] -> Pretty
 interpp'SP sty xs
-  = ppInterleave sep (map (ppr sty) xs)
+  = ppIntersperse sep (map (ppr sty) xs)
   where
     sep = ppBeside ppComma ppSP