[project @ 1996-04-08 16:15:43 by partain]

SLPJ 1.3 hacks through 960408

76 files changed, 1045 insertions, 626 deletions

diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs
index 75f1520367..adbd61f788 100644
--- a/ghc/compiler/basicTypes/Id.lhs
+++ b/ghc/compiler/basicTypes/Id.lhs
@@ -35,8 +35,8 @@ module Id {- (
 	idPrimRep, getInstIdModule,
 	getMentionedTyConsAndClassesFromId,
 
-	dataConTag,
-	dataConSig, getInstantiatedDataConSig,
+	dataConTag, dataConStrictMarks,
+	dataConSig, dataConArgTys,
 	dataConTyCon, dataConArity,
 	dataConFieldLabels,
 
@@ -104,14 +104,13 @@ import Maybes		( maybeToBool )
 import Name		( appendRdr, nameUnique, mkLocalName, isLocalName,
 			  isLocallyDefinedName, isPreludeDefinedName,
 			  nameOrigName,
-			  RdrName(..), Name
-			)
-import FieldLabel	( fieldLabelName, FieldLabel{-instances-} )
-import Outputable	( isAvarop, isAconop, getLocalName,
+			  isAvarop, isAconop, getLocalName,
 			  isLocallyDefined, isPreludeDefined,
 			  getOrigName, getOccName,
-			  isExported, ExportFlag(..)
+			  isExported, ExportFlag(..),
+			  RdrName(..), Name
 			)
+import FieldLabel	( fieldLabelName, FieldLabel{-instances-} )
 import PragmaInfo	( PragmaInfo(..) )
 import PrelMods		( pRELUDE_BUILTIN )
 import PprType		( getTypeString, typeMaybeString, specMaybeTysSuffix,
@@ -133,7 +132,7 @@ import UniqSupply	( getBuiltinUniques )
 import Unique		( mkTupleDataConUnique, pprUnique, showUnique,
 			  Unique{-instance Ord3-}
 			)
-import Util		( mapAccumL, nOfThem,
+import Util		( mapAccumL, nOfThem, zipEqual,
 			  panic, panic#, pprPanic, assertPanic
 			)
 \end{code}
@@ -1379,7 +1378,7 @@ mkDataCon n stricts fields tvs ctxt args_tys tycon
       = let
 	    (inst_env, tyvars, tyvar_tys)
 	      = instantiateTyVarTemplates tvs
-					  (map getItsUnique tvs)
+					  (map uniqueOf tvs)
 	in
 	    -- the "context" and "arg_tys" have TyVarTemplates in them, so
 	    -- we instantiate those types to have the right TyVars in them
@@ -1446,7 +1445,7 @@ mkTupleCon arity
 	BEND
       where
 	tyvar_tmpls	= take arity alphaTyVars
-	(_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map getItsUnique tyvar_tmpls)
+	(_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map uniqueOf tyvar_tmpls)
 -}
 
 fIRST_TAG :: ConTag
@@ -1477,6 +1476,21 @@ dataConSig (Id _ _ (TupleConId _ arity) _ _)
 
 dataConFieldLabels :: DataCon -> [FieldLabel]
 dataConFieldLabels (Id _ _ (DataConId _ _ _ fields _ _ _ _) _ _) = fields
+dataConFieldLabels (Id _ _ (TupleConId _ _)		    _ _) = []
+
+dataConStrictMarks :: DataCon -> [StrictnessMark]
+dataConStrictMarks (Id _ _ (DataConId _ _ stricts _ _ _ _ _) _ _) = stricts
+dataConStrictMarks (Id _ _ (TupleConId _ arity)		     _ _) 
+  = take arity (repeat NotMarkedStrict)
+
+dataConArgTys :: DataCon 
+	      -> [Type] 	-- Instantiated at these types
+	      -> [Type]		-- Needs arguments of these types
+dataConArgTys con_id inst_tys
+ = map (instantiateTy tenv) arg_tys
+ where
+    (tyvars, _, arg_tys, _) = dataConSig con_id
+    tenv 		    = tyvars `zipEqual` inst_tys
 \end{code}
 
 \begin{code}
@@ -1493,62 +1507,6 @@ recordSelectorFieldLabel :: Id -> FieldLabel
 recordSelectorFieldLabel (Id _ _ (RecordSelId lbl) _ _) = lbl
 \end{code}
 
-{- LATER
-dataConTyCon	(Id _ _ _ (SpecId unspec tys _))
-  = mkSpecTyCon (dataConTyCon unspec) tys
-
-dataConSig (Id _ _ _ (SpecId unspec ty_maybes _))
-  = (spec_tyvars, spec_theta_ty, spec_arg_tys, spec_tycon)
-  where
-    (tyvars, theta_ty, arg_tys, tycon) = dataConSig unspec
-
-    ty_env = tyvars `zip` ty_maybes
-
-    spec_tyvars = foldr nothing_tyvars [] ty_env
-    nothing_tyvars (tyvar, Nothing) l = tyvar : l
-    nothing_tyvars (tyvar, Just ty) l = l
-
-    spec_env = foldr just_env [] ty_env
-    just_env (tyvar, Nothing) l = l
-    just_env (tyvar, Just ty) l = (tyvar, ty) : l
-    spec_arg_tys = map (instantiateTauTy spec_env) arg_tys
-
-    spec_theta_ty = if null theta_ty then []
-		    else panic "dataConSig:ThetaTy:SpecDataCon"
-    spec_tycon    = mkSpecTyCon tycon ty_maybes
--}
-\end{code}
-
-\begin{pseudocode}
-@getInstantiatedDataConSig@ takes a constructor and some types to which
-it is applied; it returns its signature instantiated to these types.
-
-\begin{code}
-getInstantiatedDataConSig ::
-	   DataCon	-- The data constructor
-			--   Not a specialised data constructor
-	-> [TauType]	-- Types to which applied
-			--   Must be fully applied i.e. contain all types of tycon
-	-> ([TauType],	-- Types of dict args
-	    [TauType],	-- Types of regular args
-	    TauType	-- Type of result
-	   )
-
-getInstantiatedDataConSig data_con inst_tys
-  = ASSERT(isDataCon data_con)
-    let
-	(tvs, theta, arg_tys, tycon) = dataConSig data_con
-
-	inst_env = ASSERT(length tvs == length inst_tys)
-		   tvs `zip` inst_tys
-
-	theta_tys = [ instantiateTy inst_env (mkDictTy c t) | (c,t) <- theta ]
-	cmpnt_tys = [ instantiateTy inst_env arg_ty | arg_ty <- arg_tys ]
-	result_ty = instantiateTy inst_env (applyTyCon tycon inst_tys)
-    in
-    -- Are the first/third results ever used?
-    (theta_tys, cmpnt_tys, result_ty)
-\end{code}
 
 Data type declarations are of the form:
 \begin{verbatim}
diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs
index f4667bb796..14691d66b7 100644
--- a/ghc/compiler/basicTypes/Name.lhs
+++ b/ghc/compiler/basicTypes/Name.lhs
@@ -25,19 +25,29 @@ module Name (
 	mkImplicitName,	isImplicitName,
 	mkBuiltinName,
 
+	NamedThing(..), -- class
+	ExportFlag(..), isExported,
+
 	nameUnique,
 	nameOrigName,
 	nameOccName,
 	nameExportFlag,
 	nameSrcLoc,
 	isLocallyDefinedName,
-	isPreludeDefinedName
+	isPreludeDefinedName,
+
+	getOrigName, getOccName, getExportFlag,
+	getSrcLoc, isLocallyDefined, isPreludeDefined,
+	getLocalName, getOrigNameRdr, ltLexical,
+
+	isOpLexeme, pprOp, pprNonOp,
+	isConop, isAconop, isAvarid, isAvarop
     ) where
 
 import Ubiq
 
 import CStrings		( identToC, cSEP )
-import Outputable	( Outputable(..), ExportFlag(..), isConop )
+import Outputable	( Outputable(..) )
 import PprStyle		( PprStyle(..), codeStyle )
 import Pretty
 import PrelMods		( pRELUDE )
@@ -272,3 +282,170 @@ pp_prov Builtin  = ppPStr SLIT("/BUILTIN")
 pp_prov _        = ppNil
 \end{code}
 
+%************************************************************************
+%*									*
+\subsection[ExportFlag-datatype]{The @ExportFlag@ datatype}
+%*									*
+%************************************************************************
+
+The export flag @ExportAll@ means `export all there is', so there are
+times when it is attached to a class or data type which has no
+ops/constructors (if the class/type was imported abstractly).  In
+fact, @ExportAll@ is attached to everything except to classes/types
+which are being {\em exported} abstractly, regardless of how they were
+imported.
+
+\begin{code}
+data ExportFlag
+  = ExportAll		-- export with all constructors/methods
+  | ExportAbs		-- export abstractly
+  | NotExported
+
+isExported a
+  = case (getExportFlag a) of
+      NotExported -> False
+      _		  -> True
+
+#ifdef USE_ATTACK_PRAGMAS
+{-# SPECIALIZE isExported :: Class -> Bool #-}
+{-# SPECIALIZE isExported :: Id -> Bool #-}
+{-# SPECIALIZE isExported :: TyCon -> Bool #-}
+#endif
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Overloaded functions related to Names}
+%*									*
+%************************************************************************
+
+\begin{code}
+class NamedThing a where
+    getName :: a -> Name
+\end{code}
+
+\begin{code}
+getOrigName	    :: NamedThing a => a -> (Module, FAST_STRING)
+getOccName	    :: NamedThing a => a -> RdrName
+getExportFlag	    :: NamedThing a => a -> ExportFlag
+getSrcLoc	    :: NamedThing a => a -> SrcLoc
+isLocallyDefined    :: NamedThing a => a -> Bool
+isPreludeDefined    :: NamedThing a => a -> Bool
+
+getOrigName	    = nameOrigName 	   . getName
+getOccName	    = nameOccName  	   . getName
+getExportFlag	    = nameExportFlag	   . getName
+getSrcLoc	    = nameSrcLoc	   . getName
+isLocallyDefined    = isLocallyDefinedName . getName
+isPreludeDefined    = isPreludeDefinedName . getName
+
+getLocalName :: (NamedThing a) => a -> FAST_STRING
+getLocalName = snd . getOrigName
+
+getOrigNameRdr :: (NamedThing a) => a -> RdrName
+getOrigNameRdr n | isPreludeDefined n = Unqual str
+		 | otherwise          = Qual mod str
+  where
+    (mod,str) = getOrigName n
+\end{code}
+
+@ltLexical@ is used for sorting things into lexicographical order, so
+as to canonicalize interfaces.  [Regular @(<)@ should be used for fast
+comparison.]
+
+\begin{code}
+a `ltLexical` b
+  = BIND isLocallyDefined a	_TO_ a_local ->
+    BIND isLocallyDefined b	_TO_ b_local ->
+    BIND getOrigName a		_TO_ (a_mod, a_name) ->
+    BIND getOrigName b		_TO_ (b_mod, b_name) ->
+    if a_local || b_local then
+       a_name < b_name	-- can't compare module names
+    else
+       case _CMP_STRING_ a_mod b_mod of
+	 LT_  -> True
+	 EQ_  -> a_name < b_name
+	 GT__ -> False
+    BEND BEND BEND BEND
+
+#ifdef USE_ATTACK_PRAGMAS
+{-# SPECIALIZE ltLexical :: Class -> Class -> Bool #-}
+{-# SPECIALIZE ltLexical :: Id -> Id -> Bool #-}
+{-# SPECIALIZE ltLexical :: TyCon -> TyCon -> Bool #-}
+#endif
+\end{code}
+
+These functions test strings to see if they fit the lexical categories
+defined in the Haskell report.  Normally applied as in e.g. @isConop
+(getLocalName foo)@
+
+\begin{code}
+isConop, isAconop, isAvarid, isAvarop :: FAST_STRING -> Bool
+
+isConop cs
+  | _NULL_ cs	= False
+  | c == '_'	= isConop (_TAIL_ cs)		-- allow for leading _'s
+  | otherwise	= isUpper c || c == ':' 
+		  || c == '[' || c == '('	-- [] () and (,,) come is as Conop strings !!!
+		  || isUpperISO c
+  where					
+    c = _HEAD_ cs
+
+isAconop cs
+  | _NULL_ cs	= False
+  | otherwise	= c == ':'
+  where
+    c = _HEAD_ cs
+
+isAvarid cs
+  | _NULL_ cs	 = False
+  | c == '_'	 = isAvarid (_TAIL_ cs)	-- allow for leading _'s
+  | isLower c	 = True
+  | isLowerISO c = True
+  | otherwise    = False
+  where
+    c = _HEAD_ cs
+
+isAvarop cs
+  | _NULL_ cs	 		    = False
+  | isLower c    		    = False
+  | isUpper c    		    = False
+  | c `elem` "!#$%&*+./<=>?@\\^|~-" = True
+  | isSymbolISO c		    = True
+  | otherwise			    = False
+  where
+    c = _HEAD_ cs
+
+isSymbolISO c = ord c `elem` (0xd7 : 0xf7 : [0xa1 .. 0xbf])
+isUpperISO  c = 0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c
+isLowerISO  c = 0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c
+\end{code}
+
+And one ``higher-level'' interface to those:
+
+\begin{code}
+isOpLexeme :: NamedThing a => a -> Bool
+
+isOpLexeme v
+  = let str = snd (getOrigName v) in isAvarop str || isAconop str
+
+-- print `vars`, (op) correctly
+pprOp, pprNonOp :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty
+
+pprOp sty var
+  = if isOpLexeme var
+    then ppr sty var
+    else ppBesides [ppChar '`', ppr sty var, ppChar '`']
+
+pprNonOp sty var
+  = if isOpLexeme var
+    then ppBesides [ppLparen, ppr sty var, ppRparen]
+    else ppr sty var
+
+#ifdef USE_ATTACK_PRAGMAS
+{-# SPECIALIZE isOpLexeme :: Id -> Bool #-}
+{-# SPECIALIZE pprNonOp :: PprStyle -> Id -> Pretty #-}
+{-# SPECIALIZE pprNonOp :: PprStyle -> TyCon -> Pretty #-}
+{-# SPECIALIZE pprOp :: PprStyle -> Id -> Pretty #-}
+#endif
+\end{code}
diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs
index d3ee26e544..b77ed34ece 100644
--- a/ghc/compiler/basicTypes/Unique.lhs
+++ b/ghc/compiler/basicTypes/Unique.lhs
@@ -21,7 +21,7 @@ Haskell).
 --<mkdependHS:friends> UniqSupply
 
 module Unique (
-	Unique, Uniquable(..),
+	Unique,
 	u2i,				-- hack: used in UniqFM
 
 	pprUnique, pprUnique10, showUnique,
@@ -54,6 +54,7 @@ module Unique (
 	charPrimTyConKey,
 	charTyConKey,
 	consDataConKey,
+	dataClassKey,
 	doubleDataConKey,
 	doublePrimTyConKey,
 	doubleTyConKey,
@@ -114,6 +115,10 @@ module Unique (
 	parErrorIdKey,
 	parIdKey,
 	patErrorIdKey,
+	recConErrorIdKey,
+	recUpdErrorIdKey,
+	irrefutPatErrorIdKey,
+	nonExhaustiveGuardsErrorIdKey,
 	primIoTyConKey,
 	ratioDataConKey,
 	ratioTyConKey,
@@ -290,9 +295,6 @@ instance Ord3 Unique where
     cmp = cmpUnique
 
 -----------------
-class Uniquable a where
-    uniqueOf :: a -> Unique
-
 instance Uniquable Unique where
     uniqueOf u = u
 \end{code}
@@ -415,6 +417,7 @@ monadZeroClassKey	= mkPreludeClassUnique 15
 binaryClassKey		= mkPreludeClassUnique 16
 cCallableClassKey	= mkPreludeClassUnique 17	
 cReturnableClassKey	= mkPreludeClassUnique 18
+dataClassKey		= mkPreludeClassUnique 19
 \end{code}
 
 %************************************************************************
@@ -531,40 +534,44 @@ wordDataConKey				= mkPreludeDataConUnique 41
 %************************************************************************
 
 \begin{code}
-absentErrorIdKey	= mkPreludeMiscIdUnique	 1
-appendIdKey 		= mkPreludeMiscIdUnique  2
-augmentIdKey		= mkPreludeMiscIdUnique	 3
-buildIdKey		= mkPreludeMiscIdUnique	 4
-errorIdKey		= mkPreludeMiscIdUnique	 5
-foldlIdKey		= mkPreludeMiscIdUnique	 6
-foldrIdKey		= mkPreludeMiscIdUnique	 7
-forkIdKey   	    	= mkPreludeMiscIdUnique  8
-int2IntegerIdKey	= mkPreludeMiscIdUnique	 9
-integerMinusOneIdKey	= mkPreludeMiscIdUnique	10
-integerPlusOneIdKey	= mkPreludeMiscIdUnique	11
-integerPlusTwoIdKey	= mkPreludeMiscIdUnique	12
-integerZeroIdKey	= mkPreludeMiscIdUnique	13
-packCStringIdKey	= mkPreludeMiscIdUnique	14
-parErrorIdKey		= mkPreludeMiscIdUnique	15
-parIdKey		= mkPreludeMiscIdUnique	16
-patErrorIdKey		= mkPreludeMiscIdUnique	17
-realWorldPrimIdKey	= mkPreludeMiscIdUnique 18
-runSTIdKey		= mkPreludeMiscIdUnique 19
-seqIdKey		= mkPreludeMiscIdUnique 20
-traceIdKey		= mkPreludeMiscIdUnique	21
-unpackCString2IdKey	= mkPreludeMiscIdUnique	22
-unpackCStringAppendIdKey= mkPreludeMiscIdUnique	23
-unpackCStringFoldrIdKey	= mkPreludeMiscIdUnique 24
-unpackCStringIdKey	= mkPreludeMiscIdUnique	25
-voidPrimIdKey		= mkPreludeMiscIdUnique	26
-mainIdKey		= mkPreludeMiscIdUnique	27
-mainPrimIOIdKey		= mkPreludeMiscIdUnique	28
+absentErrorIdKey	      = mkPreludeMiscIdUnique  1
+appendIdKey 		      = mkPreludeMiscIdUnique  2
+augmentIdKey		      = mkPreludeMiscIdUnique  3
+buildIdKey		      = mkPreludeMiscIdUnique  4
+errorIdKey		      = mkPreludeMiscIdUnique  5
+foldlIdKey		      = mkPreludeMiscIdUnique  6
+foldrIdKey		      = mkPreludeMiscIdUnique  7
+forkIdKey   	    	      = mkPreludeMiscIdUnique  8
+int2IntegerIdKey	      = mkPreludeMiscIdUnique  9
+integerMinusOneIdKey	      = mkPreludeMiscIdUnique 10
+integerPlusOneIdKey	      = mkPreludeMiscIdUnique 11
+integerPlusTwoIdKey	      = mkPreludeMiscIdUnique 12
+integerZeroIdKey	      = mkPreludeMiscIdUnique 13
+packCStringIdKey	      = mkPreludeMiscIdUnique 14
+parErrorIdKey		      = mkPreludeMiscIdUnique 15
+parIdKey		      = mkPreludeMiscIdUnique 16
+patErrorIdKey		      = mkPreludeMiscIdUnique 17
+realWorldPrimIdKey	      = mkPreludeMiscIdUnique 18
+runSTIdKey		      = mkPreludeMiscIdUnique 19
+seqIdKey		      = mkPreludeMiscIdUnique 20
+traceIdKey		      = mkPreludeMiscIdUnique 21
+unpackCString2IdKey	      = mkPreludeMiscIdUnique 22
+unpackCStringAppendIdKey      = mkPreludeMiscIdUnique 23
+unpackCStringFoldrIdKey	      = mkPreludeMiscIdUnique 24
+unpackCStringIdKey	      = mkPreludeMiscIdUnique 25
+voidPrimIdKey		      = mkPreludeMiscIdUnique 26
+mainIdKey		      = mkPreludeMiscIdUnique 27
+mainPrimIOIdKey		      = mkPreludeMiscIdUnique 28
+recConErrorIdKey	      = mkPreludeMiscIdUnique 29
+recUpdErrorIdKey	      = mkPreludeMiscIdUnique 30
+irrefutPatErrorIdKey	      = mkPreludeMiscIdUnique 31
+nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 32
 
 #ifdef GRAN
-parLocalIdKey		= mkPreludeMiscIdUnique 29
-parGlobalIdKey		= mkPreludeMiscIdUnique 30
-noFollowIdKey		= mkPreludeMiscIdUnique 31
-copyableIdKey		= mkPreludeMiscIdUnique 32
+parLocalIdKey		= mkPreludeMiscIdUnique 33
+parGlobalIdKey		= mkPreludeMiscIdUnique 34
+noFollowIdKey		= mkPreludeMiscIdUnique 35
+copyableIdKey		= mkPreludeMiscIdUnique 36
 #endif
 \end{code}
 
@@ -572,15 +579,15 @@ Certain class operations from Prelude classes.  They get
 their own uniques so we can look them up easily when we want
 to conjure them up during type checking.        
 \begin{code}					  
-fromIntClassOpKey	= mkPreludeMiscIdUnique 33
-fromIntegerClassOpKey	= mkPreludeMiscIdUnique 34
-fromRationalClassOpKey	= mkPreludeMiscIdUnique 35
-enumFromClassOpKey	= mkPreludeMiscIdUnique 36
-enumFromThenClassOpKey	= mkPreludeMiscIdUnique 37
-enumFromToClassOpKey	= mkPreludeMiscIdUnique 38
-enumFromThenToClassOpKey= mkPreludeMiscIdUnique 39
-eqClassOpKey		= mkPreludeMiscIdUnique 40
-geClassOpKey		= mkPreludeMiscIdUnique 41
+fromIntClassOpKey	= mkPreludeMiscIdUnique 37
+fromIntegerClassOpKey	= mkPreludeMiscIdUnique 38
+fromRationalClassOpKey	= mkPreludeMiscIdUnique 39
+enumFromClassOpKey	= mkPreludeMiscIdUnique 40
+enumFromThenClassOpKey	= mkPreludeMiscIdUnique 41
+enumFromToClassOpKey	= mkPreludeMiscIdUnique 42
+enumFromThenToClassOpKey= mkPreludeMiscIdUnique 43
+eqClassOpKey		= mkPreludeMiscIdUnique 44
+geClassOpKey		= mkPreludeMiscIdUnique 45
 \end{code}
 
 
diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs
index e678d180d4..8c5814a7ad 100644
--- a/ghc/compiler/codeGen/CgBindery.lhs
+++ b/ghc/compiler/codeGen/CgBindery.lhs
@@ -44,7 +44,7 @@ import Id		( idPrimRep, toplevelishId, isDataCon,
 			  GenId{-instance NamedThing-}
 			)
 import Maybes		( catMaybes )
-import Outputable	( isLocallyDefined )
+import Name		( isLocallyDefined )
 import PprAbsC		( pprAmode )
 import PprStyle		( PprStyle(..) )
 import StgSyn		( StgArg(..), StgLiveVars(..), GenStgArg(..) )
diff --git a/ghc/compiler/codeGen/CgConTbls.lhs b/ghc/compiler/codeGen/CgConTbls.lhs
index a3113e441f..c35219edd1 100644
--- a/ghc/compiler/codeGen/CgConTbls.lhs
+++ b/ghc/compiler/codeGen/CgConTbls.lhs
@@ -40,7 +40,7 @@ import Id		( dataConTag, dataConSig,
 			  emptyIdSet,
 			  GenId{-instance NamedThing-}
 			)
-import Outputable	( getLocalName )
+import Name		( getLocalName )
 import PrimRep		( getPrimRepSize, PrimRep(..) )
 import TyCon		( tyConDataCons, mkSpecTyCon )
 import Type		( typePrimRep )
diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs
index 6256db0a14..f7eb45a539 100644
--- a/ghc/compiler/codeGen/ClosureInfo.lhs
+++ b/ghc/compiler/codeGen/ClosureInfo.lhs
@@ -86,7 +86,7 @@ import Id		( idType, idPrimRep, getIdArity,
 			)
 import IdInfo		( arityMaybe )
 import Maybes		( assocMaybe, maybeToBool )
-import Outputable	( isLocallyDefined, getLocalName )
+import Name		( isLocallyDefined, getLocalName )
 import PprStyle		( PprStyle(..) )
 import PprType		( GenType{-instance Outputable-} )
 import PrimRep		( getPrimRepSize, separateByPtrFollowness )
diff --git a/ghc/compiler/coreSyn/CoreLift.lhs b/ghc/compiler/coreSyn/CoreLift.lhs
index 9020e0b41e..71383a55ed 100644
--- a/ghc/compiler/coreSyn/CoreLift.lhs
+++ b/ghc/compiler/coreSyn/CoreLift.lhs
@@ -25,7 +25,7 @@ import Id		( idType, mkSysLocal,
 			  nullIdEnv, growIdEnvList, lookupIdEnv, IdEnv(..),
 			  GenId{-instances-}
 			)
-import Outputable	( isLocallyDefined, getSrcLoc )
+import Name		( isLocallyDefined, getSrcLoc )
 import PrelInfo		( liftDataCon, mkLiftTy, statePrimTyCon )
 import TyCon		( isBoxedTyCon, TyCon{-instance-} )
 import Type		( maybeAppDataTyCon, eqTy )
diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs
index 6cff5a159e..3aa5c628f8 100644
--- a/ghc/compiler/coreSyn/CoreLint.lhs
+++ b/ghc/compiler/coreSyn/CoreLint.lhs
@@ -19,12 +19,11 @@ import Bag
 import Kind		( Kind{-instance-} )
 import Literal		( literalType, Literal{-instance-} )
 import Id		( idType, isBottomingId,
-			  getInstantiatedDataConSig, GenId{-instances-}
+			  dataConArgTys, GenId{-instances-}
 			)
 import Maybes		( catMaybes )
-import Outputable	( isLocallyDefined, getSrcLoc,
-			  Outputable(..){-instance * []-}
-			)
+import Name		( isLocallyDefined, getSrcLoc )
+import Outputable	( Outputable(..){-instance * []-} )
 import PprCore
 import PprStyle		( PprStyle(..) )
 import PprType		( GenType, GenTyVar, TyCon )
@@ -344,7 +343,7 @@ lintAlgAlt scrut_ty tycon{-ToDo: use it!-} (con,args,rhs)
 	 addErrL (mkAlgAltMsg1 scrut_ty)
       Just (tycon, tys_applied, cons) ->
 	 let
-	   (_, arg_tys, _) = getInstantiatedDataConSig con tys_applied
+	   arg_tys = dataConArgTys con tys_applied
 	 in
 	 checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `seqL`
 	 checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)
diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs
index ddc7658249..2fc8a3bfea 100644
--- a/ghc/compiler/coreSyn/CoreUtils.lhs
+++ b/ghc/compiler/coreSyn/CoreUtils.lhs
@@ -12,7 +12,7 @@ module CoreUtils (
 	substCoreExpr, substCoreBindings
 
 	, mkCoreIfThenElse
-	, mkErrorApp, escErrorMsg
+	, escErrorMsg -- ToDo: kill
 	, argToExpr
 	, unTagBinders, unTagBindersAlts
 	, manifestlyWHNF, manifestlyBottom
@@ -44,8 +44,7 @@ import PprStyle		( PprStyle(..) )
 import PprType		( GenType{-instances-} )
 import Pretty		( ppAboves )
 import PrelInfo		( trueDataCon, falseDataCon,
-			  augmentId, buildId,
-			  pAT_ERROR_ID
+			  augmentId, buildId
 			)
 import PrimOp		( primOpType, PrimOp(..) )
 import SrcLoc		( mkUnknownSrcLoc )
@@ -153,15 +152,20 @@ mkCoreIfThenElse guard then_expr else_expr
 \end{code}
 
 \begin{code}
-mkErrorApp :: Type -> Id -> String -> CoreExpr
+{- OLD:
+mkErrorApp :: Id -> Type -> Id -> String -> CoreExpr
 
-mkErrorApp ty str_var error_msg
+mkErrorApp err_fun ty str_var error_msg
   = Let (NonRec str_var (Lit (NoRepStr (_PK_ error_msg)))) (
-    mkApp (Var pAT_ERROR_ID) [] [ty] [VarArg str_var])
+    mkApp (Var err_fun) [] [ty] [VarArg str_var])
+-}
 
+escErrorMsg = panic "CoreUtils.escErrorMsg: To Die"
+{- OLD:
 escErrorMsg [] = []
 escErrorMsg ('%':xs) = '%' : '%' : escErrorMsg xs
 escErrorMsg (x:xs)   = x : escErrorMsg xs
+-}
 \end{code}
 
 For making @Apps@ and @Lets@, we must take appropriate evasive
diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs
index 4a503e47aa..412c62d4c5 100644
--- a/ghc/compiler/coreSyn/PprCore.lhs
+++ b/ghc/compiler/coreSyn/PprCore.lhs
@@ -32,6 +32,7 @@ import Id		( idType, getIdInfo, getIdStrictness,
 			)
 import IdInfo		( ppIdInfo, StrictnessInfo(..) )
 import Literal		( Literal{-instances-} )
+import Name		( isOpLexeme )
 import Outputable	-- quite a few things
 import PprEnv
 import PprType		( GenType{-instances-}, GenTyVar{-instance-} )
diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs
index ec1bdd4fff..c2c23ae2d6 100644
--- a/ghc/compiler/deSugar/DsBinds.lhs
+++ b/ghc/compiler/deSugar/DsBinds.lhs
@@ -27,7 +27,6 @@ import DsUtils
 import Match		( matchWrapper )
 
 import CmdLineOpts	( opt_SccProfilingOn, opt_CompilingPrelude )
-import CoreUtils	( escErrorMsg )
 import CostCentre	( mkAllDictsCC, preludeDictsCostCentre )
 import Id		( idType, DictVar(..), GenId )
 import ListSetOps	( minusList, intersectLists )
@@ -472,23 +471,19 @@ dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind var expr)
 
 \begin{code}
 dsMonoBinds is_rec tyvars dicts binder_subst (FunMonoBind fun matches locn)
-  = putSrcLocDs locn	(
+  = putSrcLocDs locn	$
     let
-	new_fun = binder_subst fun
+	new_fun      = binder_subst fun
+	error_string = "function " ++ showForErr fun
     in
-    matchWrapper (FunMatch fun) matches (error_msg new_fun) `thenDs` \ (args, body) ->
+    matchWrapper (FunMatch fun) matches error_string	`thenDs` \ (args, body) ->
     returnDs [(new_fun,
 	       mkLam tyvars (dicts ++ args) body)]
-    )
-  where
-    error_msg fun = "%F" -- "incomplete pattern(s) to match in function \""
-		++ (escErrorMsg (ppShow 80 (ppr PprForUser fun))) ++ "\""
 
 dsMonoBinds is_rec tyvars dicts binder_subst (PatMonoBind (VarPat v) grhss_and_binds locn)
-  = putSrcLocDs locn	(
-    dsGuarded grhss_and_binds locn `thenDs` \ body_expr ->
+  = putSrcLocDs locn	$
+    dsGuarded grhss_and_binds 		`thenDs` \ body_expr ->
     returnDs [(binder_subst v, mkLam tyvars dicts body_expr)]
-    )
 \end{code}
 
 %==============================================
@@ -531,9 +526,9 @@ Then we transform to:
 
 \begin{code}
 dsMonoBinds is_rec tyvars [] binder_subst (PatMonoBind pat grhss_and_binds locn)
-  = putSrcLocDs locn (
+  = putSrcLocDs locn $
 
-    dsGuarded grhss_and_binds locn `thenDs` \ body_expr ->
+    dsGuarded grhss_and_binds		`thenDs` \ body_expr ->
 
 {- KILLED by Sansom. 95/05
 	-- make *sure* there are no primitive types in the pattern
@@ -549,7 +544,6 @@ dsMonoBinds is_rec tyvars [] binder_subst (PatMonoBind pat grhss_and_binds locn)
     mkSelectorBinds tyvars pat
 	[(binder, binder_subst binder) | binder <- pat_binders]
 	body_expr
-    )
   where
     pat_binders = collectTypedPatBinders pat
 	-- NB For a simple tuple pattern, these binders
diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs
index b54e111991..e19eddf902 100644
--- a/ghc/compiler/deSugar/DsCCall.lhs
+++ b/ghc/compiler/deSugar/DsCCall.lhs
@@ -16,7 +16,7 @@ import DsMonad
 import DsUtils
 
 import CoreUtils	( coreExprType )
-import Id		( getInstantiatedDataConSig, mkTupleCon )
+import Id		( dataConArgTys, mkTupleCon )
 import Maybes		( maybeToBool )
 import PprStyle		( PprStyle(..) )
 import PprType		( GenType{-instances-} )
@@ -192,7 +192,7 @@ we decide what's happening with enumerations. ADR
     (Just (tycon, tycon_arg_tys, data_cons)) = maybe_data_type
     (the_data_con : other_data_cons)       = data_cons
 
-    (_, data_con_arg_tys, _) = getInstantiatedDataConSig the_data_con tycon_arg_tys
+    data_con_arg_tys = dataConArgTys the_data_con tycon_arg_tys
     (data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys
 
 can't_see_datacons_error thing ty
@@ -292,7 +292,7 @@ boxResult result_ty
     Just (tycon, tycon_arg_tys, data_cons) = maybe_data_type
     (the_data_con : other_data_cons)       = data_cons
 
-    (_, data_con_arg_tys, _)               = getInstantiatedDataConSig the_data_con tycon_arg_tys
+    data_con_arg_tys		           = dataConArgTys the_data_con tycon_arg_tys
     (the_prim_result_ty : other_args_tys)  = data_con_arg_tys
 
     (state_and_prim_datacon, state_and_prim_ty) = getStatePairingConInfo the_prim_result_ty
diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs
index 088809955e..0e4afdc199 100644
--- a/ghc/compiler/deSugar/DsExpr.lhs
+++ b/ghc/compiler/deSugar/DsExpr.lhs
@@ -13,13 +13,17 @@ import DsLoop		-- partly to get dsBinds, partly to chk dsExpr
 
 import HsSyn		( HsExpr(..), HsLit(..), ArithSeqInfo(..),
 			  Match, Qual, HsBinds, Stmt, PolyType )
-import TcHsSyn		( TypecheckedHsExpr(..), TypecheckedHsBinds(..) )
+import TcHsSyn		( TypecheckedHsExpr(..), TypecheckedHsBinds(..),
+			  TypecheckedRecordBinds(..)
+			)
 import CoreSyn
 
 import DsMonad
 import DsCCall		( dsCCall )
 import DsListComp	( dsListComp )
-import DsUtils		( mkAppDs, mkConDs, mkPrimDs, dsExprToAtom )
+import DsUtils		( mkAppDs, mkConDs, mkPrimDs, dsExprToAtom,
+			  mkErrorAppDs, showForErr
+			)
 import Match		( matchWrapper )
 
 import CoreUnfold	( UnfoldingDetails(..), UnfoldingGuidance(..),
@@ -27,19 +31,26 @@ import CoreUnfold	( UnfoldingDetails(..), UnfoldingGuidance(..),
 import CoreUtils	( coreExprType, substCoreExpr, argToExpr,
 			  mkCoreIfThenElse, unTagBinders )
 import CostCentre	( mkUserCC )
+import FieldLabel	( FieldLabel{-instance Eq/Outputable-} )
 import Id		( mkTupleCon, idType, nullIdEnv, addOneToIdEnv,
-			  getIdUnfolding )
+			  getIdUnfolding, dataConArgTys, dataConFieldLabels,
+			  recordSelectorFieldLabel
+			)
 import Literal		( mkMachInt, Literal(..) )
 import MagicUFs		( MagicUnfoldingFun )
 import PprStyle		( PprStyle(..) )
 import PprType		( GenType )
 import PrelInfo		( mkTupleTy, unitTy, nilDataCon, consDataCon,
-			  charDataCon, charTy )
+			  charDataCon, charTy, rEC_CON_ERROR_ID,
+			  rEC_UPD_ERROR_ID
+			)
 import Pretty		( ppShow, ppBesides, ppPStr, ppStr )
-import Type		( splitSigmaTy, typePrimRep )
+import Type		( splitSigmaTy, splitFunTy, typePrimRep,
+			  getAppDataTyCon
+			)
 import TyVar		( nullTyVarEnv, addOneToTyVarEnv )
 import Usage		( UVar(..) )
-import Util		( pprError, panic )
+import Util		( zipEqual, pprError, panic, assertPanic )
 
 maybeBoxedPrimType = panic "DsExpr.maybeBoxedPrimType"
 splitTyArgs = panic "DsExpr.splitTyArgs"
@@ -170,10 +181,7 @@ dsExpr (HsLitOut (HsStringPrim s) _)
 -- end of literals magic. --
 
 dsExpr expr@(HsLam a_Match)
-  = let
-	error_msg = "%L" --> "pattern-matching failed in lambda"
-    in
-    matchWrapper LambdaMatch [a_Match] error_msg `thenDs` \ (binders, matching_code) ->
+  = matchWrapper LambdaMatch [a_Match] "lambda"	`thenDs` \ (binders, matching_code) ->
     returnDs ( mkValLam binders matching_code )
 
 dsExpr expr@(HsApp e1 e2)    = dsApp expr []
@@ -247,11 +255,8 @@ dsExpr (HsSCC cc expr)
 
 dsExpr expr@(HsCase discrim matches src_loc)
   = putSrcLocDs src_loc $
-    dsExpr discrim		`thenDs` \ core_discrim ->
-    let
-	error_msg = "%C" --> "pattern-matching failed in case"
-    in
-    matchWrapper CaseMatch matches error_msg `thenDs` \ ([discrim_var], matching_code) ->
+    dsExpr discrim				`thenDs` \ core_discrim ->
+    matchWrapper CaseMatch matches "case"	`thenDs` \ ([discrim_var], matching_code) ->
     returnDs ( mkCoLetAny (NonRec discrim_var core_discrim) matching_code )
 
 dsExpr (ListComp expr quals)
@@ -267,6 +272,30 @@ dsExpr (HsDoOut stmts m_id mz_id src_loc)
   = putSrcLocDs src_loc $
     panic "dsExpr:HsDoOut"
 
+dsExpr (HsIf guard_expr then_expr else_expr src_loc)
+  = putSrcLocDs src_loc $
+    dsExpr guard_expr	`thenDs` \ core_guard ->
+    dsExpr then_expr	`thenDs` \ core_then ->
+    dsExpr else_expr	`thenDs` \ core_else ->
+    returnDs (mkCoreIfThenElse core_guard core_then core_else)
+
+\end{code}
+
+
+Type lambda and application
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+dsExpr (TyLam tyvars expr)
+  = dsExpr expr `thenDs` \ core_expr ->
+    returnDs (mkTyLam tyvars core_expr)
+
+dsExpr expr@(TyApp e tys) = dsApp expr []
+\end{code}
+
+
+Various data construction things
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+\begin{code}
 dsExpr (ExplicitListOut ty xs)
   = case xs of
       []     -> returnDs (mk_nil_con ty)
@@ -281,15 +310,9 @@ dsExpr (ExplicitTuple expr_list)
 	    (map coreExprType core_exprs)
 	    core_exprs
 
-dsExpr (RecordCon con  rbinds) = panic "dsExpr:RecordCon"
-dsExpr (RecordUpd aexp rbinds) = panic "dsExpr:RecordUpd"
-
-dsExpr (HsIf guard_expr then_expr else_expr src_loc)
-  = putSrcLocDs src_loc $
-    dsExpr guard_expr	`thenDs` \ core_guard ->
-    dsExpr then_expr	`thenDs` \ core_then ->
-    dsExpr else_expr	`thenDs` \ core_else ->
-    returnDs (mkCoreIfThenElse core_guard core_then core_else)
+dsExpr (HsCon con tys args)
+  = mapDs dsExpr args	`thenDs` \ args_exprs ->
+    mkConDs con tys args_exprs
 
 dsExpr (ArithSeqOut expr (From from))
   = dsExpr expr		  `thenDs` \ expr2 ->
@@ -316,38 +339,119 @@ dsExpr (ArithSeqOut expr (FromThenTo from thn two))
     mkAppDs expr2 [] [from2, thn2, two2]
 \end{code}
 
+Record construction and update
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For record construction we do this (assuming T has three arguments)
 
-Type lambda and application
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-\begin{code}
-dsExpr (TyLam tyvars expr)
-  = dsExpr expr `thenDs` \ core_expr ->
-    returnDs (mkTyLam tyvars core_expr)
+	T { op2 = e }
+==>
+	let err = /\a -> recConErr a 
+	T (recConErr t1 "M.lhs/230/op1") 
+	  e 
+	  (recConErr t1 "M.lhs/230/op3")
 
-dsExpr expr@(TyApp e tys) = dsApp expr []
-\end{code}
+recConErr then converts its arugment string into a proper message
+before printing it as
+
+	M.lhs, line 230: missing field op1 was evaluated
 
 
-Record construction and update
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 \begin{code}
-{-
 dsExpr (RecordCon con_expr rbinds)
   = dsExpr con_expr	`thenDs` \ con_expr' ->
     let
-	con_args = map mk_arg (arg_tys `zip` fieldLabelTags)
-	(arg_tys, data_ty) = splitFunTy (coreExprType con_expr')
+	con_id   = get_con_id con_expr'
+	(arg_tys, data_ty) = splitFunTy (idType con_id)
 
-	mk_arg (arg_ty, tag) = case [  | (sel_id,rhs) <- rbinds,
-					 fieldLabelTag (recordSelectorFieldLabel sel_id) == tag
+	mk_arg (arg_ty, lbl) = case [rhs | (sel_id,rhs,_) <- rbinds,
+					   lbl == recordSelectorFieldLabel sel_id
 				    ] of
 				 (rhs:rhss) -> ASSERT( null rhss )
 					       dsExpr rhs
 
-				 [] -> returnDs ......GONE HOME!>>>>>
+				 [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (showForErr lbl)
+    in
+    mapDs mk_arg (arg_tys `zip` dataConFieldLabels con_id) `thenDs` \ con_args ->
 
-    mkAppDs con_expr [] con_args
--}
+    mkAppDs con_expr' [] con_args
+  where
+	-- The "con_expr'" is simply an application of the constructor Id
+	-- to types and (perhaps) dictionaries.  This boring little 
+	-- function gets the constructor out.
+    get_con_id (App fun _) = get_con_id fun
+    get_con_id (Var con)   = con
+\end{code}
+
+Record update is a little harder. Suppose we have the decl:
+
+	data T = T1 {op1, op2, op3 :: Int}
+	       | T2 {op4, op1 :: Int}
+	       | T3
+
+Then we translate as follows:
+
+	r { op2 = e }
+===>
+	let op2 = e in
+	case r of
+	  T1 op1 _ op3 -> T1 op1 op2 op3
+	  T2 op4 _     -> T2 op4 op2
+	  other	       -> recUpdError "M.lhs/230"
+
+It's important that we use the constructor Ids for T1, T2 etc on the
+RHSs, and do not generate a Core Con directly, because the constructor
+might do some argument-evaluation first; and may have to throw away some
+dictionaries.
+
+\begin{code}
+dsExpr (RecordUpdOut record_expr dicts rbinds)
+  = dsExpr record_expr	`thenDs` \ record_expr' ->
+
+	-- Desugar the rbinds, and generate let-bindings if
+	-- necessary so that we don't lose sharing
+--    dsRbinds rbinds		$ \ rbinds' ->
+    let rbinds' = panic "dsExpr:RecordUpdOut:rbinds'" in
+    let
+	record_ty		= coreExprType record_expr'
+	(tycon, inst_tys, cons) = getAppDataTyCon record_ty
+	cons_to_upd  	 	= filter has_all_fields cons
+
+	-- initial_args are passed to every constructor
+	initial_args		= map TyArg inst_tys ++ map VarArg dicts
+		
+	mk_val_arg (field, arg_id) 
+	  = case [arg | (f, arg) <- rbinds', f==field] of
+		(arg:args) -> ASSERT(null args)
+			      arg
+		[]	   -> VarArg arg_id
+
+	mk_alt con
+	  = newSysLocalsDs (dataConArgTys con inst_tys)	`thenDs` \ arg_ids ->
+	    let 
+		val_args = map mk_val_arg (dataConFieldLabels con `zipEqual` arg_ids)
+	    in
+	    returnDs (con, arg_ids, mkGenApp (mkGenApp (Var con) initial_args) val_args)
+
+	mk_default
+	  | length cons_to_upd == length cons 
+	  = returnDs NoDefault
+	  | otherwise			    
+	  = newSysLocalDs record_ty			`thenDs` \ deflt_id ->
+	    mkErrorAppDs rEC_UPD_ERROR_ID record_ty ""	`thenDs` \ err ->
+	    returnDs (BindDefault deflt_id err)
+    in
+    mapDs mk_alt cons_to_upd	`thenDs` \ alts ->
+    mk_default			`thenDs` \ deflt ->
+
+    returnDs (Case record_expr' (AlgAlts alts deflt))
+
+  where
+    has_all_fields :: Id -> Bool
+    has_all_fields con_id 
+      = all ok rbinds
+      where
+	con_fields        = dataConFieldLabels con_id
+	ok (sel_id, _, _) = recordSelectorFieldLabel sel_id `elem` con_fields
 \end{code}
 
 Dictionary lambda and application
@@ -503,6 +607,24 @@ apply_to_args fun args
     sep a@(UsageArg _) _	  = panic "DsExpr:apply_to_args:UsageArg"
 \end{code}
 
+
+\begin{code}
+dsRbinds :: TypecheckedRecordBinds		-- The field bindings supplied
+	 -> ([(Id, CoreArg)] -> DsM CoreExpr)	-- A continuation taking the field
+						-- bindings with atomic rhss
+	 -> DsM CoreExpr			-- The result of the continuation,
+						-- wrapped in suitable Lets
+
+dsRbinds [] continue_with 
+  = continue_with []
+
+dsRbinds ((sel_id, rhs, pun_flag) : rbinds) continue_with
+  = dsExpr rhs		`thenDs` \ rhs' ->
+    dsExprToAtom rhs'	$ \ rhs_atom ->
+    dsRbinds rbinds	$ \ rbinds' ->
+    continue_with ((panic "dsRbinds:field_label?"{-sel_id-}, rhs_atom) : rbinds')
+\end{code}	
+
 \begin{code}
 do_unfold ty_env val_env (Lam (TyBinder tyvar) body) (TyArg ty : args)
   = do_unfold (addOneToTyVarEnv ty_env tyvar ty) val_env body args
diff --git a/ghc/compiler/deSugar/DsGRHSs.lhs b/ghc/compiler/deSugar/DsGRHSs.lhs
index d90e330396..938d8657ed 100644
--- a/ghc/compiler/deSugar/DsGRHSs.lhs
+++ b/ghc/compiler/deSugar/DsGRHSs.lhs
@@ -21,8 +21,8 @@ import CoreSyn		( CoreBinding(..), CoreExpr(..), mkCoLetsAny )
 import DsMonad
 import DsUtils
 
-import CoreUtils	( escErrorMsg, mkErrorApp, mkCoreIfThenElse )
-import PrelInfo		( stringTy )
+import CoreUtils	( mkCoreIfThenElse )
+import PrelInfo		( stringTy, nON_EXHAUSTIVE_GUARDS_ERROR_ID )
 import PprStyle		( PprStyle(..) )
 import Pretty		( ppShow )
 import SrcLoc		( SrcLoc{-instance-} )
@@ -42,23 +42,15 @@ necessary.  The type argument gives the type of the ei.
 
 \begin{code}
 dsGuarded :: TypecheckedGRHSsAndBinds
-	  -> SrcLoc
 	  -> DsM CoreExpr
 
-dsGuarded (GRHSsAndBindsOut grhss binds err_ty) err_loc
+dsGuarded (GRHSsAndBindsOut grhss binds err_ty)
   = dsBinds binds				`thenDs` \ core_binds ->
     dsGRHSs err_ty PatBindMatch [] grhss 	`thenDs` \ (MatchResult can_it_fail _ core_grhss_fn _) ->
     case can_it_fail of
 	CantFail -> returnDs (mkCoLetsAny core_binds (core_grhss_fn (panic "It can't fail")))
-	CanFail  -> newSysLocalDs stringTy	`thenDs` \ str_var -> -- to hold the String
-		    returnDs (mkCoLetsAny core_binds (core_grhss_fn (error_expr str_var)))
-  where
-    unencoded_part_of_msg = escErrorMsg (ppShow 80 (ppr PprForUser err_loc))
-
-    error_expr :: Id -> CoreExpr
-    error_expr str_var = mkErrorApp err_ty str_var
-			  (unencoded_part_of_msg
-			  ++ "%N") --> ": non-exhaustive guards"
+	CanFail  -> mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID err_ty "" `thenDs` \ error_expr ->
+		    returnDs (mkCoLetsAny core_binds (core_grhss_fn error_expr))
 \end{code}
 
 Desugar a list of (grhs, expr) pairs [grhs = guarded
diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs
index 700db9e238..9726092b57 100644
--- a/ghc/compiler/deSugar/DsUtils.lhs
+++ b/ghc/compiler/deSugar/DsUtils.lhs
@@ -15,7 +15,7 @@ module DsUtils (
 	combineMatchResults,
 	dsExprToAtom,
 	mkCoAlgCaseMatchResult,
-	mkAppDs, mkConDs, mkPrimDs,
+	mkAppDs, mkConDs, mkPrimDs, mkErrorAppDs,
 	mkCoLetsMatchResult,
 	mkCoPrimCaseMatchResult,
 	mkFailurePair,
@@ -23,7 +23,8 @@ module DsUtils (
 	mkSelectorBinds,
 	mkTupleBind,
 	mkTupleExpr,
-	selectMatchVars
+	selectMatchVars,
+	showForErr
     ) where
 
 import Ubiq
@@ -37,10 +38,13 @@ import CoreSyn
 
 import DsMonad
 
-import CoreUtils	( coreExprType, escErrorMsg, mkCoreIfThenElse, mkErrorApp )
-import PrelInfo		( stringTy )
-import Id		( idType, getInstantiatedDataConSig, mkTupleCon,
+import CoreUtils	( coreExprType, mkCoreIfThenElse )
+import PprStyle		( PprStyle(..) )
+import PrelInfo		( stringTy, iRREFUT_PAT_ERROR_ID )
+import Pretty		( ppShow )
+import Id		( idType, dataConArgTys, mkTupleCon,
 			  DataCon(..), DictVar(..), Id(..), GenId )
+import Literal		( Literal(..) )
 import TyCon		( mkTupleTyCon )
 import Type		( mkTyVarTys, mkRhoTy, mkFunTys, isUnboxedType,
 			  applyTyCon, getAppDataTyCon
@@ -141,7 +145,7 @@ mkCoAlgCaseMatchResult var alts
 		     -- We need to build new locals for the args of the constructor,
 		     -- and figuring out their types is somewhat tiresome.
 		let
-			(_,arg_tys,_) = getInstantiatedDataConSig con tycon_arg_tys
+			arg_tys = dataConArgTys con tycon_arg_tys
 		in
 		newSysLocalsDs arg_tys	`thenDs` \ arg_ids ->
 
@@ -252,8 +256,6 @@ dsExprsToAtoms (arg:args) continue_with
 %*									*
 %************************************************************************
 
-Plumb the desugarer's @UniqueSupply@ in/out of the @UniqSupply@ monad
-world.
 \begin{code}
 mkAppDs  :: CoreExpr -> [Type] -> [CoreExpr] -> DsM CoreExpr
 mkConDs  :: Id       -> [Type] -> [CoreExpr] -> DsM CoreExpr
@@ -272,6 +274,24 @@ mkPrimDs op tys arg_exprs
     returnDs (mkPrim op [] tys vals)
 \end{code}
 
+\begin{code}
+showForErr :: Outputable a => a -> String		-- Boring but useful
+showForErr thing = ppShow 80 (ppr PprForUser thing)
+
+mkErrorAppDs :: Id 		-- The error function
+	     -> Type		-- Type to which it should be applied
+	     -> String		-- The error message string to pass
+	     -> DsM CoreExpr
+
+mkErrorAppDs err_id ty msg
+  = getSrcLocDs			`thenDs` \ (file, line) ->
+    let
+	full_msg = file ++ "|" ++ line ++ "|" ++msg
+	msg_lit  = NoRepStr (_PK_ full_msg)
+    in
+    returnDs (mkApp (Var err_id) [] [ty] [LitArg msg_lit])
+\end{code}
+
 %************************************************************************
 %*									*
 \subsection[mkSelectorBind]{Make a selector bind}
@@ -303,17 +323,10 @@ mkSelectorBinds :: [TyVar]	    -- Variables wrt which the pattern is polymorphic
 		-> DsM [(Id,CoreExpr)]
 
 mkSelectorBinds tyvars pat locals_and_globals val_expr
-  = getSrcLocDs		`thenDs` \ (src_file, src_line) ->
-
-    if is_simple_tuple_pat pat then
+  = if is_simple_tuple_pat pat then
 	mkTupleBind tyvars [] locals_and_globals val_expr
     else
-	newSysLocalDs stringTy	`thenDs` \ str_var -> -- to hold the string
-	let
-	    src_loc_str   = escErrorMsg ('"' : src_file) ++ "%l" ++ src_line
-	    error_string  = src_loc_str ++ "%~" --> ": pattern-match failed on an irrefutable pattern"
-	    error_msg     = mkErrorApp res_ty str_var error_string
-	in
+	mkErrorAppDs iRREFUT_PAT_ERROR_ID res_ty ""	`thenDs` \ error_msg ->
 	matchSimply val_expr pat res_ty local_tuple error_msg `thenDs` \ tuple_expr ->
 	mkTupleBind tyvars [] locals_and_globals tuple_expr
   where
diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs
index c7d0b5d860..4380041333 100644
--- a/ghc/compiler/deSugar/Match.lhs
+++ b/ghc/compiler/deSugar/Match.lhs
@@ -18,16 +18,16 @@ import TcHsSyn		( TypecheckedPat(..), TypecheckedMatch(..),
 import DsHsSyn		( outPatType, collectTypedPatBinders )
 import CoreSyn
 
+import CoreUtils	( coreExprType )
 import DsMonad
 import DsGRHSs		( dsGRHSs )
 import DsUtils
 import MatchCon		( matchConFamily )
 import MatchLit		( matchLiterals )
 
-import CoreUtils	( escErrorMsg, mkErrorApp )
 import FieldLabel	( allFieldLabelTags, fieldLabelTag )
 import Id		( idType, mkTupleCon, dataConSig,
-			  recordSelectorFieldLabel,
+			  dataConArgTys, recordSelectorFieldLabel,
 			  GenId{-instance-}
 			)
 import PprStyle		( PprStyle(..) )
@@ -38,7 +38,9 @@ import PrelInfo		( nilDataCon, consDataCon, mkTupleTy, mkListTy,
 			  integerTy, intPrimTy, charPrimTy,
 			  floatPrimTy, doublePrimTy, stringTy,
 			  addrTy, addrPrimTy, addrDataCon,
-			  wordTy, wordPrimTy, wordDataCon )
+			  wordTy, wordPrimTy, wordDataCon,
+			  pAT_ERROR_ID
+			)
 import Type		( isPrimType, eqTy, getAppDataTyCon,
 			  instantiateTauTy
 			)
@@ -329,14 +331,12 @@ tidy1 v (ConOpPat pat1 id pat2 ty) match_result
 tidy1 v (RecPat con_id pat_ty rpats) match_result
   = returnDs (ConPat con_id pat_ty pats, match_result)
   where
-    pats 		    = map mk_pat tagged_arg_tys
+    pats 	     = map mk_pat tagged_arg_tys
 
 	-- Boring stuff to find the arg-tys of the constructor
-    (tyvars, _, arg_tys, _) = dataConSig con_id
-    (_, inst_tys, _) 	    = getAppDataTyCon pat_ty
-    tenv 		    = tyvars `zip` inst_tys
-    con_arg_tys'	    = map (instantiateTauTy tenv) arg_tys
-    tagged_arg_tys	    = con_arg_tys' `zip` allFieldLabelTags
+    (_, inst_tys, _) = getAppDataTyCon pat_ty
+    con_arg_tys'     = dataConArgTys con_id inst_tys 
+    tagged_arg_tys   = con_arg_tys' `zip` allFieldLabelTags
 
 	-- mk_pat picks a WildPat of the appropriate type for absent fields,
 	-- and the specified pattern for present fields
@@ -613,16 +613,12 @@ matchWrapper kind [(GRHSMatch
 matchWrapper kind matches error_string
   = flattenMatches kind matches	`thenDs` \ eqns_info@(EqnInfo arg_pats (MatchResult _ result_ty _ _) : _) ->
 
-    selectMatchVars arg_pats	`thenDs` \ new_vars ->
-    match new_vars eqns_info []	`thenDs` \ match_result ->
+    selectMatchVars arg_pats				`thenDs` \ new_vars ->
+    match new_vars eqns_info []				`thenDs` \ match_result ->
+
+    mkErrorAppDs pAT_ERROR_ID result_ty error_string	`thenDs` \ fail_expr ->
+    extractMatchResult match_result fail_expr		`thenDs` \ result_expr ->
 
-    getSrcLocDs			`thenDs` \ (src_file, src_line) ->
-    newSysLocalDs stringTy	`thenDs` \ str_var -> -- to hold the String
-    let
-	src_loc_str = escErrorMsg ('"' : src_file) ++ "%l" ++ src_line
-	fail_expr   = mkErrorApp result_ty str_var (src_loc_str++": "++error_string)
-    in
-    extractMatchResult match_result fail_expr	`thenDs` \ result_expr ->
     returnDs (new_vars, result_expr)
 \end{code}
 
@@ -703,4 +699,15 @@ flattenMatches kind (match : matches)
 	returnDs (EqnInfo pats (mkCoLetsMatchResult core_binds match_result))
       where
 	pats = reverse pats_so_far	-- They've accumulated in reverse order
+
+    flatten_match pats_so_far (SimpleMatch expr) 
+      = dsExpr expr		`thenDs` \ core_expr ->
+	returnDs (EqnInfo pats
+		    (MatchResult CantFail (coreExprType core_expr) 
+			      (\ ignore -> core_expr)
+			      NoMatchContext))
+	-- The NoMatchContext is just a place holder.  In a simple match,
+	-- the matching can't fail, so we won't generate an error message.
+      where
+	pats = reverse pats_so_far	-- They've accumulated in reverse order
 \end{code}
diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs
index bcc9133cb3..15dafc9d0e 100644
--- a/ghc/compiler/hsSyn/HsBinds.lhs
+++ b/ghc/compiler/hsSyn/HsBinds.lhs
@@ -22,7 +22,10 @@ import HsTypes		( PolyType )
 
 --others:
 import Id		( DictVar(..), Id(..), GenId )
-import Outputable
+import Name		( pprNonOp )
+import Outputable	( interpp'SP, ifnotPprForUser,
+			  Outputable(..){-instance * (,)-}
+			)
 import Pretty
 import SrcLoc		( SrcLoc{-instances-} )
 --import TyVar		( GenTyVar{-instances-} )
diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs
index 6952ef0c8b..750519a66c 100644
--- a/ghc/compiler/hsSyn/HsDecls.lhs
+++ b/ghc/compiler/hsSyn/HsDecls.lhs
@@ -20,7 +20,10 @@ import HsPragmas	( DataPragmas, ClassPragmas,
 import HsTypes
 
 -- others:
-import Outputable
+import Name		( pprOp, pprNonOp )
+import Outputable	( interppSP, interpp'SP,
+			  Outputable(..){-instance * []-}
+			)
 import Pretty
 import SrcLoc		( SrcLoc )
 import Util		( cmpList, panic#{-ToDo:rm eventually-} )
diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs
index 8c62d1835d..0a0397ec27 100644
--- a/ghc/compiler/hsSyn/HsExpr.lhs
+++ b/ghc/compiler/hsSyn/HsExpr.lhs
@@ -19,7 +19,8 @@ import HsTypes		( PolyType )
 
 -- others:
 import Id		( DictVar(..), GenId, Id(..) )
-import Outputable
+import Name		( isOpLexeme, pprOp )
+import Outputable	( interppSP, interpp'SP, ifnotPprForUser )
 import PprType		( pprGenType, pprParendGenType, GenType{-instance-} )
 import Pretty
 import PprStyle		( PprStyle(..) )
@@ -109,6 +110,10 @@ data HsExpr tyvar uvar id pat
   | RecordUpd	(HsExpr tyvar uvar id pat)
 		(HsRecordBinds tyvar uvar id pat)
 
+  | RecordUpdOut	(HsExpr tyvar uvar id pat)	-- TRANSLATION
+			[id]				-- Dicts needed for construction
+			(HsRecordBinds tyvar uvar id pat)
+
   | ExprWithTySig		-- signature binding
 		(HsExpr tyvar uvar id pat)
 		(PolyType id)
@@ -165,6 +170,11 @@ Everything from here on appears only in typechecker output.
   |  SingleDict			-- a simple special case of Dictionary
 		id		-- local dictionary name
 
+  |  HsCon 			-- TRANSLATION; a constructor application
+	Id			-- used only in the RHS of constructor definitions
+	[GenType tyvar uvar]
+	[HsExpr tyvar uvar id pat]
+
 type HsRecordBinds tyvar uvar id pat
   = [(id, HsExpr tyvar uvar id pat, Bool)]
 	-- True <=> source code used "punning",
diff --git a/ghc/compiler/hsSyn/HsLoop.lhi b/ghc/compiler/hsSyn/HsLoop.lhi
index e425c234d1..34b1926073 100644
--- a/ghc/compiler/hsSyn/HsLoop.lhi
+++ b/ghc/compiler/hsSyn/HsLoop.lhi
@@ -2,10 +2,11 @@
 
 interface HsLoop where
 
-import HsExpr( HsExpr )
-import Outputable( NamedThing, Outputable )
-import HsBinds ( Bind, HsBinds, MonoBinds, Sig, nullBinds, nullMonoBinds )
-import HsDecls ( ConDecl )
+import HsExpr	( HsExpr )
+import HsBinds	( Bind, HsBinds, MonoBinds, Sig, nullBinds, nullMonoBinds )
+import HsDecls	( ConDecl )
+import Name	( NamedThing )
+import Outputable ( Outputable )
 
 -- HsExpr outputs
 data HsExpr tyvar uvar id pat
diff --git a/ghc/compiler/hsSyn/HsMatches.lhs b/ghc/compiler/hsSyn/HsMatches.lhs
index b257cd336e..7aed7aee48 100644
--- a/ghc/compiler/hsSyn/HsMatches.lhs
+++ b/ghc/compiler/hsSyn/HsMatches.lhs
@@ -45,6 +45,8 @@ data Match tyvar uvar id pat
   = PatMatch	    pat
 		    (Match tyvar uvar id pat)
   | GRHSMatch	    (GRHSsAndBinds tyvar uvar id pat)
+
+  | SimpleMatch	    (HsExpr tyvar uvar id pat)		-- Used in translations
 \end{code}
 
 Sets of guarded right hand sides (GRHSs). In:
diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs
index 9cf88be29a..d96e8ecc8c 100644
--- a/ghc/compiler/hsSyn/HsPat.lhs
+++ b/ghc/compiler/hsSyn/HsPat.lhs
@@ -26,7 +26,8 @@ import HsLoop		( HsExpr )
 -- others:
 import Id		( GenId, dataConSig )
 import Maybes		( maybeToBool )
-import Outputable
+import Name		( pprOp, pprNonOp )
+import Outputable	( interppSP, interpp'SP, ifPprShowAll )
 import PprStyle		( PprStyle(..) )
 import Pretty
 import TyCon		( maybeTyConSingleCon )
diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs
index f857b89329..901af61dfb 100644
--- a/ghc/compiler/prelude/PrelInfo.lhs
+++ b/ghc/compiler/prelude/PrelInfo.lhs
@@ -18,7 +18,13 @@ module PrelInfo (
 	BuiltinKeys(..), BuiltinIdInfos(..),
 
 	-- *odd* values that need to be reached out and grabbed:
-	eRROR_ID, pAT_ERROR_ID, aBSENT_ERROR_ID,
+	eRROR_ID,
+	pAT_ERROR_ID,
+	rEC_CON_ERROR_ID,
+	rEC_UPD_ERROR_ID,
+	iRREFUT_PAT_ERROR_ID,
+	nON_EXHAUSTIVE_GUARDS_ERROR_ID,
+	aBSENT_ERROR_ID,
 	packStringForCId,
 	unpackCStringId, unpackCString2Id,
 	unpackCStringAppendId, unpackCStringFoldrId,
@@ -104,8 +110,7 @@ import CmdLineOpts	( opt_HideBuiltinNames,
 import FiniteMap	( FiniteMap, emptyFM, listToFM )
 import Id		( mkTupleCon, GenId, Id(..) )
 import Maybes		( catMaybes )
-import Name		( mkBuiltinName )
-import Outputable	( getOrigName )
+import Name		( mkBuiltinName, getOrigName )
 import RnHsSyn		( RnName(..) )
 import TyCon		( tyConDataCons, mkFunTyCon, mkTupleTyCon, TyCon )
 import Type
diff --git a/ghc/compiler/prelude/PrelVals.lhs b/ghc/compiler/prelude/PrelVals.lhs
index 5c5375a590..1f0fe9529b 100644
--- a/ghc/compiler/prelude/PrelVals.lhs
+++ b/ghc/compiler/prelude/PrelVals.lhs
@@ -70,8 +70,19 @@ pc_bottoming_Id key mod name ty
 eRROR_ID
   = pc_bottoming_Id errorIdKey pRELUDE_BUILTIN SLIT("error") errorTy
 
+generic_ERROR_ID u n
+  = pc_bottoming_Id u pRELUDE_BUILTIN n errorTy
+
 pAT_ERROR_ID
-  = pc_bottoming_Id patErrorIdKey pRELUDE_BUILTIN SLIT("patError#") errorTy
+  = generic_ERROR_ID patErrorIdKey SLIT("patError#")
+rEC_CON_ERROR_ID
+  = generic_ERROR_ID recConErrorIdKey SLIT("recConError#")
+rEC_UPD_ERROR_ID
+  = generic_ERROR_ID recUpdErrorIdKey SLIT("recUpdError#")
+iRREFUT_PAT_ERROR_ID
+  = generic_ERROR_ID irrefutPatErrorIdKey SLIT("irrefutPatError#")
+nON_EXHAUSTIVE_GUARDS_ERROR_ID
+  = generic_ERROR_ID nonExhaustiveGuardsErrorIdKey SLIT("nonExhaustiveGuardsError#")
 
 aBSENT_ERROR_ID
   = pc_bottoming_Id absentErrorIdKey pRELUDE_BUILTIN SLIT("absent#")
diff --git a/ghc/compiler/profiling/CostCentre.lhs b/ghc/compiler/profiling/CostCentre.lhs
index f60cff34c0..4253749fe6 100644
--- a/ghc/compiler/profiling/CostCentre.lhs
+++ b/ghc/compiler/profiling/CostCentre.lhs
@@ -27,17 +27,18 @@ module CostCentre (
 	cmpCostCentre	-- used for removing dups in a list
     ) where
 
+import Ubiq{-uitous-}
+
 import Id		( externallyVisibleId, GenId, Id(..) )
 import CStrings		( identToC, stringToC )
 import Maybes		( Maybe(..) )
-import Name		( showRdr, RdrName )
-import Outputable
+import Name		( showRdr, getOccName, RdrName )
 import Pretty		( ppShow, prettyToUn )
 import PprStyle		( PprStyle(..) )
 import UniqSet
 import Unpretty
 import Util
-import Ubiq
+
 showId = panic "Whoops"
 pprIdInUnfolding = panic "Whoops"
 \end{code}
diff --git a/ghc/compiler/profiling/SCCauto.lhs b/ghc/compiler/profiling/SCCauto.lhs
index eb8f1430ad..6f6b12b7c8 100644
--- a/ghc/compiler/profiling/SCCauto.lhs
+++ b/ghc/compiler/profiling/SCCauto.lhs
@@ -23,9 +23,9 @@ import CmdLineOpts	( opt_AutoSccsOnAllToplevs,
 			  opt_SccGroup
 			)
 import CoreSyn
-import Id		( isTopLevId, GenId{-instances-} )
-import Outputable	( isExported )
 import CostCentre	( mkAutoCC, IsCafCC(..) )
+import Id		( isTopLevId, GenId{-instances-} )
+import Name		( isExported )
 \end{code}
 
 \begin{code}
diff --git a/ghc/compiler/reader/RdrHsSyn.lhs b/ghc/compiler/reader/RdrHsSyn.lhs
index 29f69cb316..758ea33f1e 100644
--- a/ghc/compiler/reader/RdrHsSyn.lhs
+++ b/ghc/compiler/reader/RdrHsSyn.lhs
@@ -52,7 +52,7 @@ module RdrHsSyn (
 import Ubiq
 
 import HsSyn
-import Outputable	( ExportFlag(..) )
+import Name		( ExportFlag(..) )
 \end{code}
 
 \begin{code}
diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs
index 386dcbe9a2..e116f7e696 100644
--- a/ghc/compiler/rename/Rename.lhs
+++ b/ghc/compiler/rename/Rename.lhs
@@ -26,8 +26,7 @@ import MainMonad
 import Bag		( isEmptyBag, unionBags, bagToList, listToBag )
 import ErrUtils		( Error(..), Warning(..) )
 import FiniteMap	( emptyFM, eltsFM )
-import Name		( Name, RdrName(..) )
-import Outputable	( getOrigNameRdr, isLocallyDefined )
+import Name		( getOrigNameRdr, isLocallyDefined, Name, RdrName(..) )
 import PrelInfo		( BuiltinNames(..), BuiltinKeys(..) )
 import UniqFM		( emptyUFM, lookupUFM, addListToUFM_C, eltsUFM )
 import UniqSupply	( splitUniqSupply )
@@ -67,7 +66,7 @@ renameModule b_names b_keys us
   = findHiFiles			`thenPrimIO` \ hi_files ->
     newVar (emptyFM, hi_files)	`thenPrimIO` \ iface_var ->
 
-    fixPrimIO ( \ (_, _, _, _, rec_occ_fm, rec_export_fn) ->
+    fixPrimIO ( \ ~(_, _, _, _, rec_occ_fm, rec_export_fn) ->
     let
 	rec_occ_fn :: Name -> [RdrName]
 	rec_occ_fn n = case lookupUFM rec_occ_fm n of
diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index 86ba6803bf..04db620b99 100644
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -25,8 +25,7 @@ import RnHsSyn
 import RnMonad
 
 import ErrUtils		( addErrLoc )
-import Name		( isLocallyDefinedName, Name, RdrName )
-import Outputable	( pprOp )
+import Name		( isLocallyDefinedName, pprOp, Name, RdrName )
 import Pretty
 import UniqFM		( lookupUFM )
 import UniqSet		( emptyUniqSet, unitUniqSet,
diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs
index 9c8ab0dfdf..7f4b74b43e 100644
--- a/ghc/compiler/rename/RnHsSyn.lhs
+++ b/ghc/compiler/rename/RnHsSyn.lhs
@@ -12,11 +12,11 @@ import Ubiq
 
 import HsSyn
 
-import Name		( isLocalName, nameUnique, Name, RdrName )
 import Id		( GenId, Id(..) )
-import Outputable	( Outputable(..) )
-import PprType		( GenType, GenTyVar, TyCon )
+import Name		( isLocalName, nameUnique, Name, RdrName )
+import Outputable	( Outputable(..){-instance * []-} )
 import PprStyle		( PprStyle(..) )
+import PprType		( GenType, GenTyVar, TyCon )
 import Pretty
 import TyCon		( TyCon )
 import TyVar		( GenTyVar )
diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs
index 49765f117f..076f7d16d2 100644
--- a/ghc/compiler/rename/RnMonad.lhs
+++ b/ghc/compiler/rename/RnMonad.lhs
@@ -48,10 +48,9 @@ import ErrUtils		( Error(..), Warning(..) )
 import FiniteMap	( FiniteMap, emptyFM, lookupFM, addToFM )
 import Maybes		( assocMaybe )
 import Name		( Module(..), RdrName(..), isQual,
-			  Name, mkLocalName, mkImplicitName
+			  Name, mkLocalName, mkImplicitName,
+			  getOccName
 			)
-import Outputable	( getOccName )
-import PprStyle		( PprStyle )
 import Pretty		( Pretty(..), PrettyRep )
 import SrcLoc		( SrcLoc, mkUnknownSrcLoc )
 import UniqFM		( UniqFM, emptyUFM )
diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs
index 384f9f844a..b0ec1905be 100644
--- a/ghc/compiler/rename/RnNames.lhs
+++ b/ghc/compiler/rename/RnNames.lhs
@@ -26,8 +26,10 @@ import RnUtils		( RnEnv(..), emptyRnEnv, extendGlobalRnEnv, qualNameErr, dupName
 import Bag		( emptyBag, unitBag, unionBags, unionManyBags, mapBag, listToBag, bagToList )
 import ErrUtils		( Error(..), Warning(..), addShortErrLocLine )
 import FiniteMap	( fmToList )
-import Name		( RdrName(..), isQual, mkTopLevName, mkImportedName, nameExportFlag, Name )
-import Outputable	( getLocalName, getSrcLoc, pprNonOp )
+import Name		( RdrName(..), Name, isQual, mkTopLevName,
+			  mkImportedName, nameExportFlag,
+			  getLocalName, getSrcLoc, pprNonOp
+			)
 import PrelInfo		( BuiltinNames(..), BuiltinKeys(..) )
 import PrelMods		( fromPrelude )
 import Pretty
diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index 235e945938..16cd506373 100644
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -21,9 +21,8 @@ import RnBinds		( rnTopBinds, rnMethodBinds )
 import Bag		( bagToList )
 import Class		( derivableClassKeys )
 import ListSetOps	( unionLists, minusList )
-import Name		( RdrName )
 import Maybes		( maybeToBool, catMaybes )
-import Outputable	( isLocallyDefined, isAvarid, getLocalName, ExportFlag(..) )
+import Name		( isLocallyDefined, isAvarid, getLocalName, ExportFlag(..), RdrName )
 import Pretty
 import SrcLoc		( SrcLoc )
 import Unique		( Unique )
diff --git a/ghc/compiler/rename/RnUtils.lhs b/ghc/compiler/rename/RnUtils.lhs
index f79e7c47a4..721fa8e245 100644
--- a/ghc/compiler/rename/RnUtils.lhs
+++ b/ghc/compiler/rename/RnUtils.lhs
@@ -30,8 +30,7 @@ import ErrUtils		( addShortErrLocLine, addErrLoc )
 import FiniteMap	( FiniteMap, emptyFM, isEmptyFM,
 			  lookupFM, addListToFM, addToFM )
 import Maybes		( maybeToBool )
-import Name		( RdrName(..), isQual )
-import Outputable	( pprNonOp, getLocalName )
+import Name		( RdrName(..), isQual, pprNonOp, getLocalName )
 import PprStyle		( PprStyle(..) )
 import Pretty
 import RnHsSyn		( RnName )
diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs
index 94e9fc6c0a..0574b4150e 100644
--- a/ghc/compiler/simplCore/OccurAnal.lhs
+++ b/ghc/compiler/simplCore/OccurAnal.lhs
@@ -33,7 +33,8 @@ import Id		( idWantsToBeINLINEd, isConstMethodId,
 			  GenId{-instance Eq-}
 			)
 import Maybes		( maybeToBool )
-import Outputable	( isExported, Outputable(..){-instance * (,) -} )
+import Name		( isExported )
+import Outputable	( Outputable(..){-instance * (,) -} )
 import PprCore
 import PprStyle		( PprStyle(..) )
 import PprType		( GenType{-instance Outputable-}, GenTyVar{-ditto-} )
diff --git a/ghc/compiler/simplCore/SATMonad.lhs b/ghc/compiler/simplCore/SATMonad.lhs
index 1b6b20c0b1..eb0b36d102 100644
--- a/ghc/compiler/simplCore/SATMonad.lhs
+++ b/ghc/compiler/simplCore/SATMonad.lhs
@@ -217,7 +217,7 @@ saTransform binder rhs
 	    -- tag (or Exported tag) modified.
 	    fake_binder = mkSysLocal
 			    (getOccName binder _APPEND_ SLIT("_fsat"))
-			    (getItsUnique binder)
+			    (uniqueOf binder)
 			    (idType binder)
 			    mkUnknownSrcLoc
 	    rec_body = mkValLam non_static_args
diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs
index f2d0fe60f5..f07a328b01 100644
--- a/ghc/compiler/simplCore/SimplEnv.lhs
+++ b/ghc/compiler/simplCore/SimplEnv.lhs
@@ -64,7 +64,8 @@ import Id		( idType, getIdUnfolding, getIdStrictness,
 			  IdEnv(..), IdSet(..), GenId )
 import IdInfo		( StrictnessInfo )
 import Literal		( isNoRepLit, Literal{-instances-} )
-import Outputable	( isLocallyDefined, Outputable(..){-instances-} )
+import Name		( isLocallyDefined )
+import Outputable	( Outputable(..){-instances-} )
 import PprCore		-- various instances
 import PprStyle		( PprStyle(..) )
 import PprType		( GenType, GenTyVar )
diff --git a/ghc/compiler/simplCore/SimplPgm.lhs b/ghc/compiler/simplCore/SimplPgm.lhs
index dc9d1c4846..3db8a5f5c8 100644
--- a/ghc/compiler/simplCore/SimplPgm.lhs
+++ b/ghc/compiler/simplCore/SimplPgm.lhs
@@ -20,8 +20,8 @@ import Id		( externallyVisibleId,
 			  GenId{-instance Ord3-}
 			)
 import Maybes		( catMaybes )
+import Name		( isExported )
 import OccurAnal	( occurAnalyseBinds )
-import Outputable	( isExported )
 import Pretty		( ppAboves, ppBesides, ppInt, ppChar, ppStr )
 import SimplEnv
 import SimplMonad
diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs
index f546fbc054..3e9c6aab64 100644
--- a/ghc/compiler/simplCore/SimplUtils.lhs
+++ b/ghc/compiler/simplCore/SimplUtils.lhs
@@ -27,7 +27,7 @@ import BinderInfo
 import CmdLineOpts	( SimplifierSwitch(..) )
 import CoreSyn
 import CoreUtils	( manifestlyWHNF )
-import Id		( idType, isBottomingId, idWantsToBeINLINEd,
+import Id		( idType, isBottomingId, idWantsToBeINLINEd, dataConArgTys,
 			  getIdArity, GenId{-instance Eq-}
 			)
 import IdInfo		( arityMaybe )
@@ -40,7 +40,6 @@ import Type		( eqTy, isPrimType, maybeAppDataTyCon, getTyVar_maybe )
 import TyVar		( GenTyVar{-instance Eq-} )
 import Util		( isIn, panic )
 
-getInstantiatedDataConSig =  panic "SimplUtils.getInstantiatedDataConSig (ToDo)"
 \end{code}
 
 
@@ -375,7 +374,7 @@ mkIdentityAlts rhs_ty
   = case (maybeAppDataTyCon rhs_ty) of
 	Just (tycon, ty_args, [data_con]) ->  -- algebraic type suitable for unpacking
 	    let
-		(_,inst_con_arg_tys,_) = getInstantiatedDataConSig data_con ty_args
+		inst_con_arg_tys = dataConArgTys data_con ty_args
 	    in
 	    newIds inst_con_arg_tys	`thenSmpl` \ new_bindees ->
 	    let
diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index 3bbb88af2b..76b17d945b 100644
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -26,7 +26,7 @@ import Id		( idType, idWantsToBeINLINEd,
 import IdInfo		( willBeDemanded, DemandInfo )
 import Literal		( isNoRepLit )
 import Maybes		( maybeToBool )
-import Outputable	( isLocallyDefined )
+import Name		( isLocallyDefined )
 import PprStyle		( PprStyle(..) )
 import PprType		( GenType{-instance Outputable-} )
 import PrelInfo		( realWorldStateTy )
diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs
index 51ea249d60..48ac2b6501 100644
--- a/ghc/compiler/simplStg/SimplStg.lhs
+++ b/ghc/compiler/simplStg/SimplStg.lhs
@@ -14,7 +14,7 @@ import StgSyn
 import StgUtils
 
 import LambdaLift	( liftProgram )
-import Outputable	( isLocallyDefined )
+import Name		( isLocallyDefined )
 import SCCfinal		( stgMassageForProfiling )
 import SatStgRhs	( satStgRhs )
 import StgLint		( lintStgBindings )
@@ -33,7 +33,7 @@ import Id		( nullIdEnv, lookupIdEnv, addOneToIdEnv,
 			)
 import MainMonad	( writeMn, thenMn_, thenMn, returnMn, MainIO(..) )
 import Maybes		( maybeToBool )
-import Outputable	( isExported )
+import Name		( isExported )
 import PprType		( GenType{-instance Outputable-} )
 import Pretty		( ppShow, ppAbove, ppAboves, ppStr )
 import UniqSupply	( splitUniqSupply )
diff --git a/ghc/compiler/simplStg/StgVarInfo.lhs b/ghc/compiler/simplStg/StgVarInfo.lhs
index 097251a2cb..ed675f705c 100644
--- a/ghc/compiler/simplStg/StgVarInfo.lhs
+++ b/ghc/compiler/simplStg/StgVarInfo.lhs
@@ -25,7 +25,7 @@ import Id		( emptyIdSet, mkIdSet, minusIdSet,
 			  GenId{-instance Eq-}
 			)
 import Maybes		( maybeToBool )
-import Outputable	( isLocallyDefined )
+import Name		( isLocallyDefined )
 import PprStyle		( PprStyle(..) )
 import PprType		( GenType{-instance Outputable-} )
 import Util		( panic, pprPanic, assertPanic )
diff --git a/ghc/compiler/specialise/SpecUtils.lhs b/ghc/compiler/specialise/SpecUtils.lhs
index e1aa07065a..4f83c8ef7c 100644
--- a/ghc/compiler/specialise/SpecUtils.lhs
+++ b/ghc/compiler/specialise/SpecUtils.lhs
@@ -33,7 +33,7 @@ import Id		( idType, isDictFunId, isConstMethodId_maybe,
 			  GenId {-instance NamedThing -}
 			)
 import Maybes		( maybeToBool, catMaybes, firstJust )
-import Outputable	( isAvarop, pprNonOp, getOrigName )
+import Name		( isAvarop, pprNonOp, getOrigName )
 import PprStyle		( PprStyle(..) )
 import PprType		( pprGenType, pprParendGenType, pprMaybeTy,
 			  TyCon{-ditto-}, GenType{-ditto-}, GenTyVar
diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs
index 18d1d078e5..15230b43e0 100644
--- a/ghc/compiler/specialise/Specialise.lhs
+++ b/ghc/compiler/specialise/Specialise.lhs
@@ -44,7 +44,8 @@ import Id		( idType, isDefaultMethodId_maybe, toplevelishId,
 			)
 import Literal		( Literal{-instance Outputable-} )
 import Maybes		( catMaybes, firstJust, maybeToBool )
-import Outputable	( interppSP, isLocallyDefined, Outputable(..){-instance * []-} )
+import Name		( isLocallyDefined )
+import Outputable	( interppSP, Outputable(..){-instance * []-} )
 import PprStyle		( PprStyle(..) )
 import PprType		( pprGenType, pprParendGenType, pprMaybeTy,
 			  GenType{-instance Outputable-}, GenTyVar{-ditto-},
diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs
index 50a9bc07bd..c3bd393c51 100644
--- a/ghc/compiler/stgSyn/CoreToStg.lhs
+++ b/ghc/compiler/stgSyn/CoreToStg.lhs
@@ -28,7 +28,7 @@ import Id		( mkSysLocal, idType, isBottomingId,
 			  IdEnv(..), GenId{-instance NamedThing-}
 			)
 import Literal		( mkMachInt, Literal(..) )
-import Outputable	( isExported )
+import Name		( isExported )
 import PrelInfo		( unpackCStringId, unpackCString2Id, stringTy,
 			  integerTy, rationalTy, ratioDataCon,
 			  integerZeroId, integerPlusOneId,
diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs
index 8d1ccfa5ec..9f3c14b224 100644
--- a/ghc/compiler/stgSyn/StgLint.lhs
+++ b/ghc/compiler/stgSyn/StgLint.lhs
@@ -13,7 +13,7 @@ import Ubiq{-uitous-}
 import StgSyn
 
 import Bag		( emptyBag, isEmptyBag, snocBag, foldBag )
-import Id		( idType, isDataCon,
+import Id		( idType, isDataCon, dataConArgTys,
 			  emptyIdSet, isEmptyIdSet, elementOfIdSet,
 			  mkIdSet, intersectIdSets,
 			  unionIdSets, idSetToList, IdSet(..),
@@ -21,9 +21,8 @@ import Id		( idType, isDataCon,
 			)
 import Literal		( literalType, Literal{-instance Outputable-} )
 import Maybes		( catMaybes )
-import Outputable	( Outputable(..){-instance * []-},
-			  isLocallyDefined, getSrcLoc
-			)
+import Name		( isLocallyDefined, getSrcLoc )
+import Outputable	( Outputable(..){-instance * []-} )
 import PprType		( GenType{-instance Outputable-}, TyCon )
 import Pretty		-- quite a bit of it
 import PrimOp		( primOpType )
@@ -35,7 +34,6 @@ import Util		( zipEqual, pprPanic, panic, panic# )
 
 infixr 9 `thenL`, `thenL_`, `thenMaybeL`, `thenMaybeL_`
 
-getInstantiatedDataConSig = panic "StgLint.getInstantiatedDataConSig (ToDo)"
 splitTypeWithDictsAsArgs = panic "StgLint.splitTypeWithDictsAsArgs (ToDo)"
 unDictifyTy = panic "StgLint.unDictifyTy (ToDo)"
 \end{code}
@@ -228,7 +226,7 @@ lintAlgAlt scrut_ty (con, args, _, rhs)
 	 addErrL (mkAlgAltMsg1 scrut_ty)
       Just (tycon, tys_applied, cons) ->
 	 let
-	   (_, arg_tys, _) = getInstantiatedDataConSig con tys_applied
+	   arg_tys = dataConArgTys con tys_applied
 	 in
 	 checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `thenL_`
 	 checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)
diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs
index 395eaa077e..ba87f68fb9 100644
--- a/ghc/compiler/stgSyn/StgSyn.lhs
+++ b/ghc/compiler/stgSyn/StgSyn.lhs
@@ -44,8 +44,8 @@ import Ubiq{-uitous-}
 import CostCentre	( showCostCentre )
 import Id		( idPrimRep, GenId{-instance NamedThing-} )
 import Literal		( literalPrimRep, isLitLitLit, Literal{-instance Outputable-} )
-import Outputable	( isExported, isOpLexeme, ifPprDebug,
-			  interppSP, interpp'SP,
+import Name		( isExported, isOpLexeme )
+import Outputable	( ifPprDebug, interppSP, interpp'SP,
 			  Outputable(..){-instance * Bool-}
 			)
 import PprStyle		( PprStyle(..) )
diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs
index 1020b6726b..11c621fb33 100644
--- a/ghc/compiler/stranal/SaAbsInt.lhs
+++ b/ghc/compiler/stranal/SaAbsInt.lhs
@@ -21,7 +21,7 @@ import CoreSyn
 import CoreUnfold	( UnfoldingDetails(..), FormSummary )
 import CoreUtils	( unTagBinders )
 import Id		( idType, getIdStrictness, getIdUnfolding,
-			  dataConSig
+			  dataConSig, dataConArgTys
 			)
 import IdInfo		( StrictnessInfo(..), Demand(..),
 			  wwPrim, wwStrict, wwEnum, wwUnpack
@@ -44,7 +44,6 @@ import Util		( isIn, isn'tIn, nOfThem, zipWithEqual,
 			  pprTrace, panic, pprPanic, assertPanic
 			)
 
-getInstantiatedDataConSig = panic "SaAbsInt.getInstantiatedDataConSig (ToDo)"
 returnsRealWorld = panic "SaAbsInt.returnsRealWorld (ToDo)"
 \end{code}
 
@@ -848,7 +847,7 @@ findRecDemand strflags seen str_fn abs_fn ty
 	 Just (tycon,tycon_arg_tys,[data_con]) | tycon `not_elem` seen ->
 	   -- Single constructor case, tycon not already seen higher up
 	   let
-	      (_,cmpnt_tys,_) = getInstantiatedDataConSig data_con tycon_arg_tys
+	      cmpnt_tys = dataConArgTys data_con tycon_arg_tys
 	      prod_len = length cmpnt_tys
 
 	      compt_strict_infos
diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs
index 4d1fa7a576..0b9913ceef 100644
--- a/ghc/compiler/stranal/WwLib.lhs
+++ b/ghc/compiler/stranal/WwLib.lhs
@@ -15,7 +15,7 @@ module WwLib (
 import Ubiq{-uitous-}
 
 import CoreSyn
-import Id		( idType, mkSysLocal )
+import Id		( idType, mkSysLocal, dataConArgTys )
 import IdInfo		( mkStrictnessInfo, nonAbsentArgs, Demand(..) )
 import PrelInfo		( aBSENT_ERROR_ID )
 import SrcLoc		( mkUnknownSrcLoc )
@@ -26,7 +26,6 @@ import UniqSupply	( returnUs, thenUs, thenMaybeUs,
 import Util		( zipWithEqual, assertPanic, panic )
 
 quantifyTy = panic "WwLib.quantifyTy"
-getInstantiatedDataConSig = panic "WwLib.getInstantiatedDataConSig"
 \end{code}
 
 %************************************************************************
@@ -327,8 +326,7 @@ mk_ww_arg_processing (arg : args) (WwUnpack cmpnt_infos : infos) max_extra_args
 			-- The main event: a single-constructor data type
 
 	    let
-		(_,inst_con_arg_tys,_)
-		  = getInstantiatedDataConSig data_con tycon_arg_tys
+		inst_con_arg_tys = dataConArgTys data_con tycon_arg_tys
 	    in
 	    getUniques (length inst_con_arg_tys)    `thenUs` \ uniqs ->
 
diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index 71d7651383..fd242812a5 100644
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -45,7 +45,7 @@ import Bag	( emptyBag, unitBag, unionBags, unionManyBags, listToBag, consBag )
 import Class	( Class(..), GenClass, ClassInstEnv(..), getClassInstEnv )
 import Id	( GenId, idType, mkInstId )
 import MatchEnv	( lookupMEnv, insertMEnv )
-import Name	( mkLocalName, Name )
+import Name	( mkLocalName, getLocalName, Name )
 import Outputable
 import PprType	( GenClass, TyCon, GenType, GenTyVar )	
 import PprStyle	( PprStyle(..) )
@@ -538,6 +538,10 @@ data InstOrigin s
   = OccurrenceOf (TcIdOcc s)	-- Occurrence of an overloaded identifier
   | OccurrenceOfCon Id		-- Occurrence of a data constructor
 
+  | RecordUpdOrigin
+
+  | DataDeclOrigin		-- Typechecking a data declaration
+
   | InstanceDeclOrigin		-- Typechecking an instance decl
 
   | LiteralOrigin	HsLit	-- Occurrence of a literal
diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index 16e80698b4..7bd91f9897 100644
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -36,7 +36,7 @@ import Kind		( mkBoxedTypeKind, mkTypeKind )
 import Id		( GenId, idType, mkUserId )
 import IdInfo		( noIdInfo )
 import Maybes		( assocMaybe, catMaybes, Maybe(..) )
-import Outputable	( pprNonOp )
+import Name		( pprNonOp )
 import PragmaInfo	( PragmaInfo(..) )
 import Pretty
 import RnHsSyn		( RnName )	-- instances
@@ -213,6 +213,175 @@ tcBindAndSigs binder_rn_names bind sigs prag_info_fn
 		RecBind _    -> mkTypeKind	-- Non-recursive, so we permit unboxed types
 \end{code}
 
+
+===========
+\begin{code}
+{-
+
+data SigInfo
+  = SigInfo	RnName
+		(TcIdBndr s)		-- Polymorpic version
+		(TcIdBndr s)		-- Monomorphic verstion
+		[TcType s] [TcIdOcc s] 	-- Instance information for the monomorphic version
+
+
+
+	-- Deal with type signatures
+    tcTySigs sigs		`thenTc` \ sig_infos ->
+    let
+	sig_binders   = [binder      | SigInfo binder _ _ _ _  <- sig_infos]
+	poly_sigs     = [(name,poly) | SigInfo name poly _ _ _ <- sig_infos]
+	mono_sigs     = [(name,mono) | SigInfo name _ mono _ _ <- sig_infos]
+	nosig_binders = binders `minusList` sig_binders
+    in
+
+
+	-- Typecheck the binding group
+    tcExtendLocalEnv poly_sigs		(
+    newMonoIds nosig_binders kind	(\ nosig_local_ids ->
+	    tcMonoBinds mono_sigs mono_binds	`thenTc` \ binds_w_lies ->
+	    returnTc (nosig_local_ids, binds_w_lies)
+    ))					`thenTc` \ (nosig_local_ids, binds_w_lies) ->
+
+
+	-- Decide what to generalise over
+    getImplicitStuffToGen sig_ids binds_w_lies	
+			`thenTc` \ (tyvars_not_to_gen, tyvars_to_gen, lie_to_gen) ->
+
+
+	-- Make poly_ids for all the binders that don't have type signatures
+    let
+	dicts_to_gen = map instToId (bagToList lie_to_gen)
+	dict_tys = map tcIdType dicts_to_gen
+
+	mk_poly binder local_id = mkUserId (getName binder) ty noPragmaInfo
+		       where
+			  ty = mkForAllTys tyvars_to_gen $
+			       mkFunTys dict_tys $
+			       tcIdType local_id
+
+	tys_to_gen     = mkTyVarTys tyvars_to_gen
+	more_sig_infos = [ SigInfo binder (mk_poly binder local_id) 
+				   local_id tys_to_gen dicts_to_gen lie_to_gen
+			 | (binder, local_id) <- nosig_binders `zipEqual` nosig_local_ids
+			 ]
+
+	local_binds = [ (local_id, DictApp (mkHsTyApp (HsVar local_id) inst_tys) dicts)
+		      | SigInfo _ _ local_id inst_tys dicts <- more_sig_infos
+		      ]
+
+	all_sig_infos = sig_infos ++ more_sig_infos	-- Contains a "signature" for each binder
+    in
+
+
+	-- Now generalise the bindings
+    let
+      find_sig lid = head [ (pid, tvs, ds, lie) 
+		          | SigInfo _ pid lid' tvs ds lie, 
+			    lid==lid'
+			  ]
+	-- Do it again, but with increased free_tyvars/reduced_tyvars_to_gen:
+	-- We still need to do this simplification, because some dictionaries 
+	-- may gratuitously constrain some tyvars over which we *are* going 
+	-- to generalise. 
+	-- For example d::Eq (Foo a b), where Foo is instanced as above.
+      gen_bind (bind, lie)
+	= tcSimplifyWithExtraGlobals tyvars_not_to_gen tyvars_to_gen avail lie
+				    `thenTc` \ (lie_free, dict_binds) ->
+	  returnTc (AbsBind tyvars_to_gen_here
+			    dicts
+			    (local_ids `zipEqual` poly_ids)
+			    (dict_binds ++ local_binds)
+			    bind,
+		    lie_free)
+	where
+	  local_ids  = bindersOf bind
+	  local_sigs = [sig | sig@(SigInfo _ _ local_id _ _) <- all_sig_infos,
+			      local_id `elem` local_ids
+		       ]
+
+	  (tyvars_to_gen_here, dicts, avail) 
+		= case (local_ids, sigs) of
+
+		    ([local_id], [SigInfo _ _ _ tyvars_to_gen dicts lie])
+			  -> (tyvars_to_gen, dicts, lie)
+
+		    other -> (tyvars_to_gen, dicts, avail)
+\end{code}
+
+@getImplicitStuffToGen@ decides what type variables
+and LIE to generalise over.
+
+For a "restricted group" -- see the monomorphism restriction
+for a definition -- we bind no dictionaries, and
+remove from tyvars_to_gen any constrained type variables
+
+*Don't* simplify dicts at this point, because we aren't going
+to generalise over these dicts.  By the time we do simplify them
+we may well know more.  For example (this actually came up)
+	f :: Array Int Int
+	f x = array ... xs where xs = [1,2,3,4,5]
+We don't want to generate lots of (fromInt Int 1), (fromInt Int 2)
+stuff.  If we simplify only at the f-binding (not the xs-binding)
+we'll know that the literals are all Ints, and we can just produce
+Int literals!
+
+Find all the type variables involved in overloading, the "constrained_tyvars"
+These are the ones we *aren't* going to generalise.
+We must be careful about doing this:
+ (a) If we fail to generalise a tyvar which is not actually
+	constrained, then it will never, ever get bound, and lands
+	up printed out in interface files!  Notorious example:
+		instance Eq a => Eq (Foo a b) where ..
+	Here, b is not constrained, even though it looks as if it is.
+	Another, more common, example is when there's a Method inst in
+	the LIE, whose type might very well involve non-overloaded
+	type variables.
+ (b) On the other hand, we mustn't generalise tyvars which are constrained,
+	because we are going to pass on out the unmodified LIE, with those
+	tyvars in it.  They won't be in scope if we've generalised them.
+
+So we are careful, and do a complete simplification just to find the
+constrained tyvars. We don't use any of the results, except to
+find which tyvars are constrained.
+
+\begin{code}
+getImplicitStuffToGen is_restricted sig_ids binds_w_lies
+  | isUnRestrictedGroup tysig_vars bind
+  = tcSimplify tyvars_to_gen lie	`thenTc` \ (_, _, dicts_to_gen) ->
+    returnNF_Tc (emptyTyVarSet, tyvars_to_gen, dicts_to_gen)
+
+  | otherwise
+  = tcSimplify tyvars_to_gen lie	    `thenTc` \ (_, _, constrained_dicts) ->
+     let
+	  -- ASSERT: dicts_sig is already zonked!
+	  constrained_tyvars    = foldBag unionTyVarSets tyVarsOfInst emptyTyVarSet constrained_dicts
+	  reduced_tyvars_to_gen = tyvars_to_gen `minusTyVarSet` constrained_tyvars
+     in
+     returnTc (constrained_tyvars, reduced_tyvars_to_gen, emptyLIE)
+
+  where
+    sig_ids   = [sig_var | (TySigInfo sig_id _ _ _ _) <- ty_sigs]
+
+    (tyvars_to_gen, lie) = foldBag (\(tv1,lie2) (tv2,lie2) -> (tv1 `unionTyVarSets` tv2,
+							       lie1 `plusLIE` lie2))
+				    get
+				    (emptyTyVarSet, emptyLIE)
+				    binds_w_lies
+    get (bind, lie)
+      = case bindersOf bind of
+	  [local_id] | local_id `in` sig_ids -> 	-- A simple binding with
+							-- a type signature
+			(emptyTyVarSet, emptyLIE)
+
+	  local_ids ->					-- Complex binding or no type sig
+			(foldr (unionTyVarSets . tcIdType) emptyTyVarSet local_ids, 
+			 lie)
+-}
+\end{code}
+			   
+
+
 \begin{code}
 tc_bind :: RenamedBind -> TcM s (TcBind s, LIE s)
 
diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index ea8e4773c2..a48bc1e3c5 100644
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -41,7 +41,7 @@ import CoreUtils	( escErrorMsg )
 import Id		( mkSuperDictSelId, mkMethodSelId, mkDefaultMethodId,
 			  idType )
 import IdInfo		( noIdInfo )
-import Outputable	( isLocallyDefined, getOrigName, getLocalName )
+import Name		( isLocallyDefined, getOrigName, getLocalName )
 import PrelVals		( pAT_ERROR_ID )
 import PprStyle
 import Pretty
diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs
index 8d3aad6b83..ea4828a9ea 100644
--- a/ghc/compiler/typecheck/TcDeriv.lhs
+++ b/ghc/compiler/typecheck/TcDeriv.lhs
@@ -39,7 +39,6 @@ import CmdLineOpts	( opt_CompilingPrelude )
 import ErrUtils		( pprBagOfErrors, addErrLoc, Error(..) )
 import Id		( dataConSig, dataConArity )
 import Maybes		( assocMaybe, maybeToBool, Maybe(..) )
---import Name		( Name(..) )
 import Outputable
 import PprType		( GenType, GenTyVar, GenClass, TyCon )
 import PprStyle
diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs
index 98800bdee6..290db74634 100644
--- a/ghc/compiler/typecheck/TcEnv.lhs
+++ b/ghc/compiler/typecheck/TcEnv.lhs
@@ -13,7 +13,7 @@ module TcEnv(
 
 	tcExtendGlobalValEnv, tcExtendLocalValEnv,
 	tcLookupLocalValue, tcLookupLocalValueOK, tcLookupLocalValueByKey, 
-	tcLookupGlobalValue, tcLookupGlobalValueByKey, tcGlobalOcc,
+	tcLookupGlobalValue, tcLookupGlobalValueByKey,
 
 	newMonoIds, newLocalIds, newLocalId,
 	tcGetGlobalTyVars
@@ -36,8 +36,7 @@ import Class	( Class(..), GenClass, getClassSig )
 
 import TcMonad
 
-import Name		( Name{-instance NamedThing-} )
-import Outputable 	( getOccName, getSrcLoc )
+import Name		( getOccName, getSrcLoc, Name{-instance NamedThing-} )
 import PprStyle
 import Pretty
 import RnHsSyn		( RnName(..) )
@@ -256,23 +255,6 @@ tcLookupGlobalValue name
     def = panic "tcLookupGlobalValue"
 #endif
 
--- A useful function that takes an occurrence of a global thing
--- and instantiates its type with fresh type variables
-tcGlobalOcc :: RnName 
-	    -> NF_TcM s (Id, 		-- The Id
-			  [TcType s], 	-- Instance types
-			  TcType s)	-- Rest of its type
-
-tcGlobalOcc name
-  = tcLookupGlobalValue name	`thenNF_Tc` \ id ->
-    let
-      (tyvars, rho) = splitForAllTy (idType id)
-    in
-    tcInstTyVars tyvars		`thenNF_Tc` \ (tyvars', arg_tys, tenv) ->
-    tcInstType tenv rho		`thenNF_Tc` \ rho' ->
-    returnNF_Tc (id, arg_tys, rho')
-
-
 tcLookupGlobalValueByKey :: Unique -> NF_TcM s Id
 tcLookupGlobalValueByKey uniq
   = tcGetEnv 		`thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index d2e9b4893d..809e08f9ff 100644
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -30,21 +30,20 @@ import Inst		( Inst, InstOrigin(..), OverloadedLit(..),
 			  newMethod, newMethodWithGivenTy, newDicts )
 import TcBinds		( tcBindsAndThen )
 import TcEnv		( tcLookupLocalValue, tcLookupGlobalValue, tcLookupClassByKey,
-			  tcLookupGlobalValueByKey, newMonoIds, tcGetGlobalTyVars,
-			  tcGlobalOcc
+			  tcLookupGlobalValueByKey, newMonoIds, tcGetGlobalTyVars
 			)
 import TcMatches	( tcMatchesCase, tcMatch )
 import TcMonoType	( tcPolyType )
 import TcPat		( tcPat )
 import TcSimplify	( tcSimplifyAndCheck, tcSimplifyRank2 )
 import TcType		( TcType(..), TcMaybe(..),
-			  tcInstType, tcInstTcType, tcInstTyVars,
+			  tcInstId, tcInstType, tcInstTheta, tcInstTcType, tcInstTyVars,
 			  newTyVarTy, zonkTcTyVars, zonkTcType )
 import TcKind		( TcKind )
 
 import Class		( Class(..), getClassSig )
 import FieldLabel	( fieldLabelName )
-import Id		( Id(..), GenId, idType, dataConFieldLabels )
+import Id		( Id(..), GenId, idType, dataConFieldLabels, dataConSig )
 import Kind		( Kind, mkBoxedTypeKind, mkTypeKind, mkArrowKind )
 import GenSpecEtc	( checkSigTyVars, checkSigTyVarsGivenGlobals )
 import Name		( Name{-instance Eq-} )
@@ -56,7 +55,7 @@ import Type		( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys,
 			  getTyVar_maybe, getFunTy_maybe,
 			  splitForAllTy, splitRhoTy, splitSigmaTy, splitFunTy,
 			  isTauTy, mkFunTys, tyVarsOfType, getForAllTy_maybe,
-			  maybeAppDataTyCon
+			  getAppDataTyCon, maybeAppDataTyCon
 			)
 import TyVar		( GenTyVar, TyVarSet(..), unionTyVarSets, mkTyVarSet )
 import Unify		( unifyTauTy, unifyTauTyList, unifyTauTyLists, unifyFunTy )
@@ -85,7 +84,7 @@ tcExpr :: RenamedHsExpr -> TcM s (TcExpr s, LIE s, TcType s)
 
 \begin{code}
 tcExpr (HsVar name)
-  = tcId name		`thenTc` \ (expr', lie, res_ty) ->
+  = tcId name		`thenNF_Tc` \ (expr', lie, res_ty) ->
 
     -- Check that the result type doesn't have any nested for-alls.
     -- For example, a "build" on its own is no good; it must be
@@ -356,40 +355,55 @@ tcExpr (ExplicitTuple exprs)
     returnTc (ExplicitTuple exprs', lie, mkTupleTy (length tys) tys)
 
 tcExpr (RecordCon (HsVar con) rbinds)
-  = tcGlobalOcc con		`thenNF_Tc` \ (con_id, arg_tys, con_rho) ->
+  = tcId con				`thenNF_Tc` \ (con_expr, con_lie, con_tau) ->
     let
-	(con_theta, con_tau) = splitRhoTy con_rho
 	(_, record_ty)       = splitFunTy con_tau
-	con_expr	     = mkHsTyApp (HsVar (RealId con_id)) arg_tys
     in
-	-- TEMPORARY ASSERT
-    ASSERT( null con_theta )
-
 	-- Con is syntactically constrained to be a data constructor
     ASSERT( maybeToBool (maybeAppDataTyCon record_ty ) )
 
     tcRecordBinds record_ty rbinds		`thenTc` \ (rbinds', rbinds_lie) ->
 
+	-- Check that the record bindings match the constructor
+    tcLookupGlobalValue con			`thenNF_Tc` \ con_id ->
     checkTc (checkRecordFields rbinds con_id)
 	    (badFieldsCon con rbinds)		`thenTc_`
 
-    returnTc (RecordCon con_expr rbinds', panic "tcExpr:RecordCon:con_lie???" {-con_lie???-} `plusLIE` rbinds_lie, record_ty)
+    returnTc (RecordCon con_expr rbinds', con_lie `plusLIE` rbinds_lie, record_ty)
+
+-- One small complication in RecordUpd is that we have to generate some 
+-- dictionaries for the data type context, since we are going to
+-- do some construction.
+--
+-- What dictionaries do we need?  For the moment we assume that all
+-- data constructors have the same context, and grab it from the first
+-- constructor.  If they have varying contexts then we'd have to 
+-- union the ones that could participate in the update.
 
 tcExpr (RecordUpd record_expr rbinds)
-  = tcExpr record_expr			`thenTc` \ (record_expr', record_lie, record_ty) ->
+  = ASSERT( not (null rbinds) )
+    tcAddErrCtxt recordUpdCtxt			$
+
+    tcExpr record_expr			`thenTc` \ (record_expr', record_lie, record_ty) ->
     tcRecordBinds record_ty rbinds	`thenTc` \ (rbinds', rbinds_lie) ->
 
 	-- Check that the field names are plausible
     zonkTcType record_ty		`thenNF_Tc` \ record_ty' ->
     let
-	maybe_tycon_stuff = maybeAppDataTyCon record_ty'
-	Just (tycon, args_tys, data_cons) = maybe_tycon_stuff
+	(tycon, inst_tys, data_cons) = getAppDataTyCon record_ty'
+	-- The record binds are non-empty (syntax); so at least one field
+	-- label will have been unified with record_ty by tcRecordBinds;
+	-- field labels must be of data type; hencd the getAppDataTyCon must succeed.
+	(tyvars, theta, _, _) = dataConSig (head data_cons)
     in
-    checkTc (maybeToBool maybe_tycon_stuff)
-	    (panic "TcExpr:Records:mystery error message") `thenTc_`
+    tcInstTheta (tyvars `zipEqual` inst_tys) theta	`thenNF_Tc` \ theta' ->
+    newDicts RecordUpdOrigin theta'			`thenNF_Tc` \ (con_lie, dicts) ->
     checkTc (any (checkRecordFields rbinds) data_cons)
 	    (badFieldsUpd rbinds)		`thenTc_`
-    returnTc (RecordUpd record_expr' rbinds', record_lie `plusLIE` rbinds_lie, record_ty)
+
+    returnTc (RecordUpdOut record_expr' dicts rbinds', 
+	      con_lie `plusLIE` record_lie `plusLIE` rbinds_lie, 
+	      record_ty)
 
 tcExpr (ArithSeqIn seq@(From expr))
   = tcExpr expr					`thenTc`    \ (expr', lie1, ty) ->
@@ -505,7 +519,7 @@ tcApp fun args
 	-- In the HsVar case we go straight to tcId to avoid hitting the
 	-- rank-2 check, which we check later here anyway
     (case fun of
-	HsVar name -> tcId name
+	HsVar name -> tcId name	`thenNF_Tc` \ stuff -> returnTc stuff
 	other	   -> tcExpr fun
     )					`thenTc` \ (fun', lie_fun, fun_ty) ->
 
@@ -623,7 +637,7 @@ tcArg expected_arg_ty arg
 %************************************************************************
 
 \begin{code}
-tcId :: RnName -> TcM s (TcExpr s, LIE s, TcType s)
+tcId :: RnName -> NF_TcM s (TcExpr s, LIE s, TcType s)
 
 tcId name
   = 	-- Look up the Id and instantiate its type
@@ -637,20 +651,25 @@ tcId name
 		      tcInstTcType tenv rho		`thenNF_Tc` \ rho' ->
 		      returnNF_Tc (TcId tc_id, arg_tys', rho')
 
-	Nothing ->    tcGlobalOcc name			`thenNF_Tc` \ (id, arg_tys, rho) ->
-		      returnNF_Tc (RealId id, arg_tys, rho)
+	Nothing ->    tcLookupGlobalValue name	`thenNF_Tc` \ id ->
+		      let
+			(tyvars, rho) = splitForAllTy (idType id)
+		      in
+		      tcInstTyVars tyvars		`thenNF_Tc` \ (tyvars', arg_tys, tenv) ->
+		      tcInstType tenv rho		`thenNF_Tc` \ rho' ->
+		      returnNF_Tc (RealId id, arg_tys, rho')
 
     )					`thenNF_Tc` \ (tc_id_occ, arg_tys, rho) ->
 
 	-- Is it overloaded?
     case splitRhoTy rho of
       ([], tau)    -> 	-- Not overloaded, so just make a type application
-		    	returnTc (mkHsTyApp (HsVar tc_id_occ) arg_tys, emptyLIE, tau)
+		    	returnNF_Tc (mkHsTyApp (HsVar tc_id_occ) arg_tys, emptyLIE, tau)
 
       (theta, tau) ->	-- Overloaded, so make a Method inst
 			newMethodWithGivenTy (OccurrenceOf tc_id_occ)
 				tc_id_occ arg_tys rho		`thenNF_Tc` \ (lie, meth_id) ->
-			returnTc (HsVar meth_id, lie, tau)
+			returnNF_Tc (HsVar meth_id, lie, tau)
 \end{code}
 
 
@@ -808,7 +827,8 @@ tcRecordBinds expected_record_ty rbinds
     returnTc (rbinds', plusLIEs lies)
   where
     do_bind (field_label, rhs, pun_flag)
-      = tcGlobalOcc field_label		`thenNF_Tc` \ (sel_id, _, tau) ->
+      = tcLookupGlobalValue field_label	`thenNF_Tc` \ sel_id ->
+	tcInstId sel_id			`thenNF_Tc` \ (_, _, tau) ->
 
 		-- Record selectors all have type
 		-- 	forall a1..an.  T a1 .. an -> tau
@@ -918,11 +938,13 @@ rank2ArgCtxt arg expected_arg_ty sty
 		   ppr sty expected_arg_ty])
 
 badFieldsUpd rbinds sty
-  = ppHang (ppStr "In a record update construct, no constructor has all these fields:")
+  = ppHang (ppStr "No constructor has all these fields:")
 	 4 (interpp'SP sty fields)
   where
     fields = [field | (field, _, _) <- rbinds]
 
+recordUpdCtxt sty = ppStr "In a record update construct"
+
 badFieldsCon con rbinds sty
   = ppHang (ppBesides [ppStr "Inconsistent constructor:", ppr sty con])
 	 4 (ppBesides [ppStr "and fields:", interpp'SP sty fields])
diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index 97b1f4e284..24054217dc 100644
--- a/ghc/compiler/typecheck/TcHsSyn.lhs
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -21,6 +21,7 @@ module TcHsSyn (
 	TypecheckedQual(..), TypecheckedStmt(..),
 	TypecheckedMatch(..), TypecheckedHsModule(..),
 	TypecheckedGRHSsAndBinds(..), TypecheckedGRHS(..),
+	TypecheckedRecordBinds(..),
 
 	mkHsTyApp, mkHsDictApp,
 	mkHsTyLam, mkHsDictLam,
@@ -95,6 +96,7 @@ type TypecheckedStmt		= Stmt		TyVar UVar Id TypecheckedPat
 type TypecheckedMatch		= Match		TyVar UVar Id TypecheckedPat
 type TypecheckedGRHSsAndBinds	= GRHSsAndBinds TyVar UVar Id TypecheckedPat
 type TypecheckedGRHS		= GRHS		TyVar UVar Id TypecheckedPat
+type TypecheckedRecordBinds	= HsRecordBinds TyVar UVar Id TypecheckedPat
 type TypecheckedHsModule	= HsModule	TyVar UVar Id TypecheckedPat
 \end{code}
 
diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index 0d43182c0f..62379841eb 100644
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -63,7 +63,7 @@ import CoreUtils	( escErrorMsg )
 import Id		( GenId, idType, isDefaultMethodId_maybe )
 import ListSetOps	( minusList )
 import Maybes 		( maybeToBool, expectJust )
-import Outputable	( getLocalName, getOrigName )
+import Name		( getLocalName, getOrigName )
 import PrelInfo		( pAT_ERROR_ID )
 import PprType		( GenType, GenTyVar, GenClass, GenClassOp, TyCon,
 			  pprParendGenType )
@@ -663,8 +663,7 @@ processInstBinds1 inst_tyvars avail_insts method_ids mbind
     let tag       = panic "processInstBinds1:getTagFromClassOpName"{-getTagFromClassOpName op-}
 	method_id = method_ids !! (tag-1)
 
-	TcId method_bndr = method_id
-	method_ty = idType method_bndr
+	method_ty = tcIdType method_id
 	(method_tyvars, method_theta, method_tau) = splitSigmaTy method_ty
     in
     newDicts origin method_theta		`thenNF_Tc` \ (method_dicts,method_dict_ids) ->
diff --git a/ghc/compiler/typecheck/TcInstUtil.lhs b/ghc/compiler/typecheck/TcInstUtil.lhs
index a0e452c5db..9d5a403d9d 100644
--- a/ghc/compiler/typecheck/TcInstUtil.lhs
+++ b/ghc/compiler/typecheck/TcInstUtil.lhs
@@ -30,7 +30,7 @@ import CoreSyn		( GenCoreExpr(..), mkValLam, mkTyApp )
 import Id		( GenId, mkDictFunId, mkConstMethodId, mkSysLocal )
 import MatchEnv		( nullMEnv, insertMEnv )
 import Maybes		( MaybeErr(..), mkLookupFunDef )
-import Outputable	( getSrcLoc )
+import Name		( getSrcLoc )
 import PprType		( GenClass, GenType, GenTyVar )
 import Pretty
 import SpecEnv		( SpecEnv(..), nullSpecEnv, addOneToSpecEnv )
diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs
index 39122d3524..1645d0e358 100644
--- a/ghc/compiler/typecheck/TcModule.lhs
+++ b/ghc/compiler/typecheck/TcModule.lhs
@@ -39,7 +39,7 @@ import Bag		( listToBag )
 import Class		( GenClass )
 import Id		( GenId, isDataCon, isMethodSelId, idType )
 import Maybes		( catMaybes )
-import Outputable	( isExported, isLocallyDefined )
+import Name		( isExported, isLocallyDefined )
 import PrelInfo		( unitTy, mkPrimIoTy )
 import Pretty
 import RnUtils		( GlobalNameMappers(..), GlobalNameMapper(..) )
diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs
index 5614273ccf..b23cf3782a 100644
--- a/ghc/compiler/typecheck/TcMonad.lhs
+++ b/ghc/compiler/typecheck/TcMonad.lhs
@@ -50,7 +50,7 @@ import SST
 import Bag		( Bag, emptyBag, isEmptyBag,
 			  foldBag, unitBag, unionBags, snocBag )
 import FiniteMap	( FiniteMap, emptyFM )
-import Outputable	( Outputable(..), NamedThing(..), ExportFlag )
+--import Outputable	( Outputable(..), NamedThing(..), ExportFlag )
 import ErrUtils		( Error(..) )
 import Maybes		( MaybeErr(..) )
 --import Name		( Name )
diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs
index 23d73af096..16b0ca28bc 100644
--- a/ghc/compiler/typecheck/TcPat.lhs
+++ b/ghc/compiler/typecheck/TcPat.lhs
@@ -22,8 +22,8 @@ import Inst		( Inst, OverloadedLit(..), InstOrigin(..),
 			  newMethod, newOverloadedLit
 			)
 import TcEnv		( tcLookupGlobalValue, tcLookupGlobalValueByKey, 
-			  tcLookupLocalValueOK, tcGlobalOcc )
-import TcType 		( TcType(..), TcMaybe, tcInstType, newTyVarTy, newTyVarTys )
+			  tcLookupLocalValueOK )
+import TcType 		( TcType(..), TcMaybe, tcInstType, newTyVarTy, newTyVarTys, tcInstId )
 import Unify 		( unifyTauTy, unifyTauTyList, unifyTauTyLists )
 
 import Bag		( Bag )
@@ -181,9 +181,9 @@ tcPat pat_in@(ConOpPatIn pat1 op pat2) -- & in binary-op form...
 
 \begin{code}
 tcPat pat_in@(RecPatIn name rpats)
-  = tcGlobalOcc name		`thenNF_Tc` \ (con_id, _, con_rho) ->
+  = tcLookupGlobalValue name		`thenNF_Tc` \ con_id ->
+    tcInstId con_id			`thenNF_Tc` \ (_, _, con_tau) ->
     let
-	(_, con_tau) = splitRhoTy con_rho
 	     -- Ignore the con_theta; overloaded constructors only
 	     -- behave differently when called, not when used for
 	     -- matching.
@@ -200,7 +200,8 @@ tcPat pat_in@(RecPatIn name rpats)
 
   where
     do_bind expected_record_ty (field_label, rhs_pat, pun_flag)
-      = tcGlobalOcc field_label		`thenNF_Tc` \ (sel_id, _, tau) ->
+      = tcLookupGlobalValue field_label		`thenNF_Tc` \ sel_id ->
+	tcInstId sel_id				`thenNF_Tc` \ (_, _, tau) ->
 
 		-- Record selectors all have type
 		-- 	forall a1..an.  T a1 .. an -> tau
@@ -316,13 +317,12 @@ unifies the actual args against the expected ones.
 matchConArgTys :: RnName -> [TcType s] -> TcM s (Id, TcType s)
 
 matchConArgTys con arg_tys
-  = tcGlobalOcc con		`thenNF_Tc` \ (con_id, _, con_rho) ->
-    let
-	(con_theta, con_tau) = splitRhoTy con_rho
+  = tcLookupGlobalValue con		`thenNF_Tc` \ con_id ->
+    tcInstId con_id			`thenNF_Tc` \ (_, _, con_tau) ->
 	     -- Ignore the con_theta; overloaded constructors only
 	     -- behave differently when called, not when used for
 	     -- matching.
-
+    let
 	(con_args, con_result) = splitFunTy con_tau
 	con_arity  = length con_args
 	no_of_args = length arg_tys
diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs
index 7962527daa..ff30d6f70d 100644
--- a/ghc/compiler/typecheck/TcSimplify.lhs
+++ b/ghc/compiler/typecheck/TcSimplify.lhs
@@ -34,7 +34,7 @@ import Class		( isNumericClass, isStandardClass, isCcallishClass,
 			  isSuperClassOf, getSuperDictSelId )
 import Id		( GenId )
 import Maybes		( expectJust, firstJust, catMaybes, seqMaybe, maybeToBool, Maybe(..) )
-import Outputable	( Outputable(..) )
+import Outputable	( Outputable(..){-instance * []-} )
 import PprType		( GenType, GenTyVar )
 import Pretty
 import SrcLoc		( mkUnknownSrcLoc )
diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index 56fa41cb82..06b8d04243 100644
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -27,19 +27,19 @@ import TcEnv		( tcExtendTyConEnv, tcExtendClassEnv,
 			  tcExtendGlobalValEnv, 
 			  tcTyVarScope, tcGetEnv )
 import TcKind		( TcKind, newKindVars )
-import TcTyDecls	( tcTyDecl, tcRecordSelectors )
+import TcTyDecls	( tcTyDecl, mkDataBinds )
 
 import Bag	
 import Class		( Class(..), getClassSelIds )
 import Digraph		( findSCCs, SCC(..) )
-import Outputable	( getSrcLoc )
+import Name		( getSrcLoc )
 import PprStyle
 import Pretty
 import UniqSet		( UniqSet(..), emptyUniqSet,
 			  unitUniqSet, unionUniqSets, 
 			  unionManyUniqSets, uniqSetToList ) 
 import SrcLoc		( SrcLoc )
-import TyCon		( TyCon, tyConDataCons )
+import TyCon		( TyCon, tyConDataCons, isDataTyCon )
 import Unique		( Unique )
 import Util		( panic, pprTrace )
 
@@ -121,7 +121,7 @@ tcGroup inst_mapper decls
 
 
 	-- Create any necessary record selector Ids and their bindings
-    mapAndUnzipTc tcRecordSelectors tycons	`thenTc` \ (sel_ids_s, binds) ->
+    mapAndUnzipTc mkDataBinds (filter isDataTyCon tycons)	`thenTc` \ (data_ids_s, binds) ->
 	
 	-- Extend the global value environment with 
 	--	a) constructors
@@ -129,8 +129,7 @@ tcGroup inst_mapper decls
 	--	c) class op selectors
 
     tcSetEnv final_env						$
-    tcExtendGlobalValEnv (concat (map tyConDataCons tycons))	$
-    tcExtendGlobalValEnv (concat sel_ids_s)			$
+    tcExtendGlobalValEnv (concat data_ids_s)			$
     tcExtendGlobalValEnv (concat (map getClassSelIds classes))  $
     tcGetEnv			`thenNF_Tc` \ really_final_env ->
 
diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs
index 8c03384c5a..e8595fd7e9 100644
--- a/ghc/compiler/typecheck/TcTyDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyDecls.lhs
@@ -9,43 +9,55 @@
 module TcTyDecls (
 	tcTyDecl,
 	tcConDecl,
-	tcRecordSelectors
+	mkDataBinds
     ) where
 
 import Ubiq{-uitous-}
 
 import HsSyn		( TyDecl(..), ConDecl(..), BangType(..), HsExpr(..), 
 			  Match(..), GRHSsAndBinds(..), GRHS(..), OutPat(..), 
-			  HsBinds(..), HsLit, Stmt, Qual, ArithSeqInfo, PolyType, 
+			  HsBinds(..), HsLit, Stmt, Qual, ArithSeqInfo,
+			  PolyType, Fake, InPat,
 			  Bind(..), MonoBinds(..), Sig, 
 			  MonoType )
 import RnHsSyn		( RenamedTyDecl(..), RenamedConDecl(..),
 			  RnName{-instance Outputable-}
 			)
-import TcHsSyn		( TcHsBinds(..), TcIdOcc(..), mkHsTyLam )
+import TcHsSyn		( mkHsTyLam, tcIdType, zonkId, TcHsBinds(..), TcIdOcc(..) )
 
+import Inst		( newDicts, InstOrigin(..), Inst )
 import TcMonoType	( tcMonoTypeKind, tcMonoType, tcContext )
-import TcType		( tcInstTyVars, tcInstType )
+import TcType		( tcInstTyVars, tcInstType, tcInstId )
 import TcEnv		( tcLookupTyCon, tcLookupTyVar, tcLookupClass,
-			  newLocalId
+			  tcLookupClassByKey,
+			  newLocalId, newLocalIds
 			)
 import TcMonad
 import TcKind		( TcKind, unifyKind, mkTcArrowKind, mkTcTypeKind )
 
+import Class		( GenClass{-instance Eq-} )
 import Id		( mkDataCon, dataConSig, mkRecordSelId,
-			  dataConFieldLabels, StrictnessMark(..)
+			  dataConFieldLabels, dataConStrictMarks,
+			  StrictnessMark(..),
+			  GenId{-instance NamedThing-}
 			)
 import FieldLabel
 import Kind		( Kind, mkArrowKind, mkBoxedTypeKind )
 import SpecEnv		( SpecEnv(..), nullSpecEnv )
-import Name		( Name{-instance Ord3-} )
+import Name		( nameSrcLoc, isLocallyDefinedName, getSrcLoc,
+			  Name{-instance Ord3-}
+			)
 import Pretty
-import TyCon		( TyCon, NewOrData(..), mkSynTyCon, mkDataTyCon, tyConDataCons )
-import Type		( getTypeKind, getTyVar, tyVarsOfTypes, eqTy, applyTyCon,
-			  mkForAllTys, mkFunTy )
-import TyVar		( getTyVarKind, elementOfTyVarSet )
+import TyCon		( TyCon, NewOrData(..), mkSynTyCon, mkDataTyCon, isDataTyCon, 
+			  tyConDataCons )
+import Type		( getTypeKind, getTyVar, tyVarsOfTypes, eqTy,
+			  applyTyCon, mkTyVarTys, mkForAllTys, mkFunTy,
+			  splitFunTy, mkTyVarTy, getTyVar_maybe
+			)
+import TyVar		( getTyVarKind, elementOfTyVarSet, GenTyVar{-instance Eq-} )
+import Unique		( Unique {- instance Eq -}, dataClassKey )
 import UniqSet		( emptyUniqSet, mkUniqSet, uniqSetToList, unionManyUniqSets, UniqSet(..) )
-import Util		( panic, equivClasses )
+import Util		( equivClasses, zipEqual, panic, assertPanic )
 \end{code}
 
 \begin{code}
@@ -145,14 +157,21 @@ tc_deriv name
     returnNF_Tc clas
 \end{code}
 
-Generating selector bindings for record delarations
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Generating constructor/selector bindings for data declarations
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 \begin{code}
-tcRecordSelectors :: TyCon -> TcM s ([Id], TcHsBinds s)
-tcRecordSelectors tycon
-  = mapAndUnzipTc (tcRecordSelector tycon) groups	`thenTc` \ (ids, binds) ->
-    returnTc (ids, SingleBind (NonRecBind (foldr AndMonoBinds EmptyMonoBinds binds)))
+mkDataBinds :: TyCon -> TcM s ([Id], TcHsBinds s)
+mkDataBinds tycon
+  = ASSERT( isDataTyCon tycon )
+    mapAndUnzipTc mkConstructor data_cons		`thenTc` \ (con_ids, con_binds) ->	
+    mapAndUnzipTc (mkRecordSelector tycon) groups	`thenTc` \ (sel_ids, sel_binds) ->
+    returnTc (con_ids ++ sel_ids, 
+	      SingleBind $ NonRecBind $
+	      foldr AndMonoBinds 
+		    (foldr AndMonoBinds EmptyMonoBinds con_binds)
+		    con_binds
+    )
   where
     data_cons = tyConDataCons tycon
     fields = [ (con, field) | con   <- data_cons,
@@ -165,6 +184,86 @@ tcRecordSelectors tycon
 	= fieldLabelName field1 `cmp` fieldLabelName field2
 \end{code}
 
+We're going to build a constructor that looks like:
+
+	data (Data a, C b) =>  T a b = T1 !a !Int b
+
+	T1 = /\ a b -> 
+	     \d1::Data a, d2::C b ->
+	     \p q r -> case p of { p ->
+		       case q of { q ->
+		       HsCon [a,b,c] [p,q,r]}}
+
+Notice that
+
+* d2 is thrown away --- a context in a data decl is used to make sure
+  one *could* construct dictionaries at the site the constructor
+  is used, but the dictionary isn't actually used.
+
+* We have to check that we can construct Data dictionaries for
+  the types a and Int.  Once we've done that we can throw d1 away too.
+
+* We use (case p of ...) to evaluate p, rather than "seq" because
+  all that matters is that the arguments are evaluated.  "seq" is 
+  very careful to preserve evaluation order, which we don't need
+  to be here.
+
+\begin{code}
+mkConstructor con_id
+  | not (isLocallyDefinedName (getName con_id))
+  = returnTc (con_id, EmptyMonoBinds)
+
+  | otherwise	-- It is locally defined
+  = tcInstId con_id			`thenNF_Tc` \ (tyvars, theta, tau) ->
+    newDicts DataDeclOrigin theta	`thenNF_Tc` \ (_, dicts) ->
+    let
+	(arg_tys, result_ty) = splitFunTy tau
+	n_args = length arg_tys
+    in
+    newLocalIds (take n_args (repeat SLIT("con"))) arg_tys	`thenNF_Tc` {- \ pre_zonk_args ->
+    mapNF_Tc zonkId pre_zonk_args   `thenNF_Tc` -} \ args ->
+
+	-- Check that all the types of all the strict
+	-- arguments are in Data.  This is trivially true of everything except
+	-- type variables, for which we must check the context.
+    let
+	strict_marks = dataConStrictMarks con_id
+	strict_args  = [arg | (arg, MarkedStrict) <- args `zipEqual` strict_marks]
+
+	data_tyvars = -- The tyvars in the constructor's context that are arguments 
+		      -- to the Data class
+	              [getTyVar "mkConstructor" ty
+		      | (clas,ty) <- theta, 
+			uniqueOf clas == dataClassKey]
+
+	check_data arg = case getTyVar_maybe (tcIdType arg) of
+			   Nothing    -> returnTc ()	-- Not a tyvar, so OK
+			   Just tyvar -> checkTc (tyvar `elem` data_tyvars) (missingDataErr tyvar)
+    in
+    mapTc check_data strict_args			`thenTc_`
+
+	-- Build the data constructor
+    let
+	con_rhs = mkHsTyLam tyvars $
+		  DictLam dicts $
+		  mk_pat_match args $
+		  mk_case strict_args $
+		  HsCon con_id arg_tys (map HsVar args)
+
+	mk_pat_match []         body = body
+	mk_pat_match (arg:args) body = HsLam (PatMatch (VarPat arg) (SimpleMatch (mk_pat_match args body)))
+
+	mk_case [] body = body
+	mk_case (arg:args) body = HsCase (HsVar arg) 
+					 [PatMatch (VarPat arg) (SimpleMatch (mk_case args body))]
+					 src_loc
+
+	src_loc = nameSrcLoc (getName con_id)
+    in
+
+    returnTc (con_id, VarMonoBind (RealId con_id) con_rhs)		 
+\end{code}
+
 We're going to build a record selector that looks like this:
 
 	data T a b c = T1 { op :: a, ...}
@@ -179,15 +278,14 @@ Note that the selector Id itself is used as the field
 label; it has to be an Id, you see!
 
 \begin{code}
-tcRecordSelector tycon fields@((first_con, first_field_label) : other_fields)
-  = panic "tcRecordSelector: don't typecheck"
-{-
+mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields)
   = let
 	field_ty   = fieldLabelType first_field_label
 	field_name = fieldLabelName first_field_label
-	other_tys  = [fieldLabelType fl | (_, fl) <- fields]
+	other_tys  = [fieldLabelType fl | (_, fl) <- other_fields]
 	(tyvars, _, _, _) = dataConSig first_con
-	-- tyvars of first_con may be free in first_ty
+        data_ty  = applyTyCon tycon (mkTyVarTys tyvars)
+	-- tyvars of first_con may be free in field_ty
     in
    
 	-- Check that all the fields in the group have the same type
@@ -200,41 +298,38 @@ tcRecordSelector tycon fields@((first_con, first_field_label) : other_fields)
     tcInstTyVars tyvars			`thenNF_Tc` \ (tyvars', tyvar_tys, tenv) ->
     tcInstType tenv field_ty		`thenNF_Tc` \ field_ty' ->
     let
-      data_ty'     = applyTyCon tycon tyvar_tys
+      data_ty' = applyTyCon tycon tyvar_tys
     in
     newLocalId SLIT("x") field_ty'	`thenNF_Tc` \ field_id ->
     newLocalId SLIT("r") data_ty'	`thenNF_Tc` \ record_id ->
 
 	-- Now build the selector
     let
-      tycon_src_loc = getSrcLoc tycon
-
-      selector_ty  = mkForAllTys tyvars' $
-		     mkFunTy data_ty' $
-		     field_ty'
+      selector_ty :: Type
+      selector_ty  = mkForAllTys tyvars $	
+		     mkFunTy data_ty $
+		     field_ty
       
+      selector_id :: Id
       selector_id = mkRecordSelId first_field_label selector_ty
 
 	-- HsSyn is dreadfully verbose for defining the selector!
       selector_rhs = mkHsTyLam tyvars' $
 		     HsLam $
 		     PatMatch (VarPat record_id) $
-		     GRHSMatch $
-		     GRHSsAndBindsOut [OtherwiseGRHS selector_body tycon_src_loc] 
-				      EmptyBinds field_ty'
+		     SimpleMatch $
+		     selector_body
 
-      selector_body = HsCase (HsVar record_id) (map mk_match fields) tycon_src_loc
+      selector_body = HsCase (HsVar record_id) (map mk_match fields) (getSrcLoc tycon)
 
       mk_match (con_id, field_label) 
-    	= PatMatch (RecPat con_id data_ty' [(selector_id, VarPat field_id, False)]) $
-	  GRHSMatch $
-    	  GRHSsAndBindsOut [OtherwiseGRHS (HsVar field_id) 
-					  (getSrcLoc (fieldLabelName field_label))] 
-			   EmptyBinds
-			   field_ty'
+    	= PatMatch (RecPat con_id data_ty' [(RealId selector_id, VarPat field_id, False)]) $
+	  SimpleMatch $
+    	  HsVar field_id
     in
-    returnTc (selector_id, VarMonoBind selector_id selector_rhs)
--}
+    returnTc (selector_id, if isLocallyDefinedName (getName tycon)
+			   then VarMonoBind (RealId selector_id) selector_rhs
+			   else EmptyMonoBinds)
 \end{code}
 
 Constructors
@@ -340,4 +435,7 @@ tyNewCtxt tycon_name sty
 
 fieldTypeMisMatch field_name sty
   = ppSep [ppStr "Declared types differ for field", ppr sty field_name]
+
+missingDataErr tyvar sty
+  = ppStr "Missing `data' (???)" -- ToDo: improve
 \end{code}
diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs
index f3f04524d8..8426310f01 100644
--- a/ghc/compiler/typecheck/TcType.lhs
+++ b/ghc/compiler/typecheck/TcType.lhs
@@ -20,7 +20,7 @@ module TcType (
 
   tcInstTyVars,    -- TyVar -> NF_TcM s (TcTyVar s)
   tcInstSigTyVars, 
-  tcInstType, tcInstTcType, tcInstTheta,
+  tcInstType, tcInstTcType, tcInstTheta, tcInstId,
 
     zonkTcTyVars,	-- TcTyVarSet s -> NF_TcM s (TcTyVarSet s)
     zonkTcType,		-- TcType s -> NF_TcM s (TcType s)
@@ -32,17 +32,21 @@ module TcType (
 
 
 -- friends:
-import Type	( Type(..), ThetaType(..), GenType(..), tyVarsOfTypes, getTyVar_maybe )
+import Type	( Type(..), ThetaType(..), GenType(..),
+		  tyVarsOfTypes, getTyVar_maybe,
+		  splitForAllTy, splitRhoTy
+		)
 import TyVar	( TyVar(..), GenTyVar(..), TyVarSet(..), GenTyVarSet(..), 
 		  tyVarSetToList
 		)
 
 -- others:
-import Kind	( Kind )
-import Usage	( Usage(..), GenUsage, UVar(..), duffUsage )
 import Class	( GenClass )
+import Id	( idType )
+import Kind	( Kind )
 import TcKind	( TcKind )
 import TcMonad
+import Usage	( Usage(..), GenUsage, UVar(..), duffUsage )
 
 import Ubiq
 import Unique		( Unique )
@@ -193,7 +197,24 @@ tcInstTheta tenv theta
     go (clas,ty) = tcInstType tenv ty 	`thenNF_Tc` \ tc_ty ->
 		   returnNF_Tc (clas, tc_ty)
 
---???tcSpecTy :: Type -> NF_TcM s (
+-- A useful function that takes an occurrence of a global thing
+-- and instantiates its type with fresh type variables
+tcInstId :: Id
+	 -> NF_TcM s ([TcTyVar s], 	-- It's instantiated type
+		      TcThetaType s,	--
+		      TcType s)		--
+
+tcInstId id
+  = let
+      (tyvars, rho) = splitForAllTy (idType id)
+    in
+    tcInstTyVars tyvars		`thenNF_Tc` \ (tyvars', arg_tys, tenv) ->
+    tcInstType tenv rho		`thenNF_Tc` \ rho' ->
+    let
+	(theta', tau') = splitRhoTy rho'
+    in
+    returnNF_Tc (tyvars', theta', tau')
+
 
 tcInstTcType ::  [(TcTyVar s,TcType s)] -> TcType s -> NF_TcM s (TcType s)
 tcInstTcType tenv ty_to_inst
diff --git a/ghc/compiler/types/Class.lhs b/ghc/compiler/types/Class.lhs
index 12b4231089..7174e8eec0 100644
--- a/ghc/compiler/types/Class.lhs
+++ b/ghc/compiler/types/Class.lhs
@@ -37,9 +37,9 @@ import TyVar		( TyVar(..), GenTyVar )
 import Usage		( GenUsage, Usage(..), UVar(..) )
 
 import Maybes		( assocMaybe, Maybe )
-import Name		( Name )
+--import Name		( Name )
 import Unique		-- Keys for built-in classes
-import Outputable	( Outputable(..), NamedThing(..), ExportFlag )
+--import Outputable	( Outputable(..), NamedThing(..), ExportFlag )
 import Pretty		( Pretty(..), PrettyRep )
 import PprStyle		( PprStyle )
 import SrcLoc		( SrcLoc )
diff --git a/ghc/compiler/types/Kind.lhs b/ghc/compiler/types/Kind.lhs
index 945c66b3b7..9fe3df3dfc 100644
--- a/ghc/compiler/types/Kind.lhs
+++ b/ghc/compiler/types/Kind.lhs
@@ -19,7 +19,7 @@ module Kind (
 import Ubiq{-uitous-}
 
 import Util		( panic )
-import Outputable	( Outputable(..) )
+--import Outputable	( Outputable(..) )
 import Pretty
 \end{code}
 
diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs
index 506c4d2284..5ba046388a 100644
--- a/ghc/compiler/types/PprType.lhs
+++ b/ghc/compiler/types/PprType.lhs
@@ -38,10 +38,10 @@ import Kind		( Kind(..) )
 import CStrings		( identToC )
 import CmdLineOpts	( opt_OmitInterfacePragmas )
 import Maybes		( maybeToBool )
-import Name		( Name )
-import Outputable	( isAvarop, isPreludeDefined, getOrigName,
-			  ifPprShowAll, interpp'SP
+import Name		( isAvarop, isPreludeDefined, getOrigName,
+			  Name{-instance Outputable-}
 			)
+import Outputable	( ifPprShowAll, interpp'SP )
 import PprStyle		( PprStyle(..), codeStyle, showUserishTypes )
 import Pretty
 import TysWiredIn	( listTyCon )
diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs
index 4e03f96974..87dfc622d6 100644
--- a/ghc/compiler/types/TyCon.lhs
+++ b/ghc/compiler/types/TyCon.lhs
@@ -53,7 +53,6 @@ import PrelMods		( pRELUDE_BUILTIN )
 import Maybes
 import Name		( Name, RdrName(..), appendRdr, nameUnique )
 import Unique		( Unique, funTyConKey, mkTupleTyConUnique )
-import Outputable
 import Pretty		( Pretty(..), PrettyRep )
 import PprStyle		( PprStyle )
 import SrcLoc		( SrcLoc, mkBuiltinSrcLoc )
diff --git a/ghc/compiler/types/TyLoop.lhi b/ghc/compiler/types/TyLoop.lhi
index 36506e621a..d36e74e1cb 100644
--- a/ghc/compiler/types/TyLoop.lhi
+++ b/ghc/compiler/types/TyLoop.lhi
@@ -9,7 +9,7 @@ import Unique ( Unique )
 
 import FieldLabel ( FieldLabel )
 import Id      ( Id, GenId, StrictnessMark, mkTupleCon, mkDataCon,
-		 dataConSig, getInstantiatedDataConSig )
+		 dataConSig, dataConArgTys )
 import PprType ( specMaybeTysSuffix )
 import Name    ( Name )
 import TyCon   ( TyCon )
@@ -36,7 +36,7 @@ specMaybeTysSuffix :: [Maybe Type] -> _PackedString
 instance Eq (GenClass a b)
 
 -- Needed in Type
-getInstantiatedDataConSig :: Id -> [Type] -> ([Type],[Type],Type)
+dataConArgTys :: Id -> [Type] -> [Type]
 
 -- Needed in TysWiredIn
 data StrictnessMark = MarkedStrict | NotMarkedStrict
diff --git a/ghc/compiler/types/TyVar.lhs b/ghc/compiler/types/TyVar.lhs
index 0a9675e25f..1b700f6269 100644
--- a/ghc/compiler/types/TyVar.lhs
+++ b/ghc/compiler/types/TyVar.lhs
@@ -38,7 +38,7 @@ import Maybes		( Maybe(..) )
 import Name		( mkLocalName, Name, RdrName(..) )
 import Pretty		( Pretty(..), PrettyRep, ppBeside, ppPStr )
 import PprStyle		( PprStyle )
-import Outputable	( Outputable(..), NamedThing(..), ExportFlag(..) )
+--import Outputable	( Outputable(..), NamedThing(..), ExportFlag(..) )
 import SrcLoc		( mkUnknownSrcLoc, SrcLoc )
 import Unique		( showUnique, mkAlphaTyVarUnique, Unique )
 import Util		( panic, Ord3(..) )
diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
index d84a1da679..0d25048aa1 100644
--- a/ghc/compiler/types/Type.lhs
+++ b/ghc/compiler/types/Type.lhs
@@ -377,8 +377,8 @@ maybeBoxedPrimType :: Type -> Maybe (Id, Type)
 maybeBoxedPrimType ty
   = case (maybeAppDataTyCon ty) of		-- Data type,
       Just (tycon, tys_applied, [data_con]) 	-- with exactly one constructor
-        -> case (getInstantiatedDataConSig data_con tys_applied) of
-	     (_, [data_con_arg_ty], _)	    	-- Applied to exactly one type,
+        -> case (dataConArgTys data_con tys_applied) of
+	     [data_con_arg_ty]		    	-- Applied to exactly one type,
 	        | isPrimType data_con_arg_ty 	-- which is primitive
 	        -> Just (data_con, data_con_arg_ty)
 	     other_cases -> Nothing
diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs
index 3d123847af..aeb06ebbae 100644
--- a/ghc/compiler/utils/Outputable.lhs
+++ b/ghc/compiler/utils/Outputable.lhs
@@ -10,33 +10,17 @@ Defines classes for pretty-printing and forcing, both forms of
 #include "HsVersions.h"
 
 module Outputable (
-	-- NAMED-THING-ERY
-	NamedThing(..),		-- class
-	ExportFlag(..),
-
-	getItsUnique, getOrigName, getOccName, getExportFlag,
-	getSrcLoc, isLocallyDefined, isPreludeDefined, isExported,
-	getLocalName, getOrigNameRdr, ltLexical,
-
-	-- PRINTERY AND FORCERY
 	Outputable(..), 	-- class
 
 	interppSP, interpp'SP,
 	ifnotPprForUser,
 	ifPprDebug,
 	ifPprShowAll, ifnotPprShowAll,
-	ifPprInterface,
-
-	isOpLexeme, pprOp, pprNonOp,
-	isConop, isAconop, isAvarid, isAvarop
+	ifPprInterface
     ) where
 
 import Ubiq{-uitous-}
 
-import Name		( nameUnique, nameOrigName, nameOccName,
-			  nameExportFlag, nameSrcLoc,
-			  isLocallyDefinedName, isPreludeDefinedName
-			)
 import PprStyle		( PprStyle(..) )
 import Pretty
 import Util		( cmpPString )
@@ -44,99 +28,6 @@ import Util		( cmpPString )
 
 %************************************************************************
 %*									*
-\subsection[NamedThing-class]{The @NamedThing@ class}
-%*									*
-%************************************************************************
-
-\begin{code}
-class NamedThing a where
-    getName :: a -> Name
-
-getItsUnique	    :: NamedThing a => a -> Unique
-getOrigName	    :: NamedThing a => a -> (Module, FAST_STRING)
-getOccName	    :: NamedThing a => a -> RdrName
-getExportFlag	    :: NamedThing a => a -> ExportFlag
-getSrcLoc	    :: NamedThing a => a -> SrcLoc
-isLocallyDefined    :: NamedThing a => a -> Bool
-isPreludeDefined    :: NamedThing a => a -> Bool
-
-getItsUnique	    = nameUnique   	   . getName
-getOrigName	    = nameOrigName 	   . getName
-getOccName	    = nameOccName  	   . getName
-getExportFlag	    = nameExportFlag	   . getName
-getSrcLoc	    = nameSrcLoc	   . getName
-isLocallyDefined    = isLocallyDefinedName . getName
-isPreludeDefined    = isPreludeDefinedName . getName
-
-isExported a
-  = case (getExportFlag a) of
-      NotExported -> False
-      _		  -> True
-
-getLocalName :: (NamedThing a) => a -> FAST_STRING
-getLocalName = snd . getOrigName
-
-getOrigNameRdr :: (NamedThing a) => a -> RdrName
-getOrigNameRdr n | isPreludeDefined n = Unqual str
-		 | otherwise          = Qual mod str
-  where
-    (mod,str) = getOrigName n
-
-#ifdef USE_ATTACK_PRAGMAS
-{-# SPECIALIZE isExported :: Class -> Bool #-}
-{-# SPECIALIZE isExported :: Id -> Bool #-}
-{-# SPECIALIZE isExported :: TyCon -> Bool #-}
-#endif
-\end{code}
-
-@ltLexical@ is used for sorting things into lexicographical order, so
-as to canonicalize interfaces.  [Regular @(<)@ should be used for fast
-comparison.]
-
-\begin{code}
-a `ltLexical` b
-  = BIND isLocallyDefined a	_TO_ a_local ->
-    BIND isLocallyDefined b	_TO_ b_local ->
-    BIND getOrigName a		_TO_ (a_mod, a_name) ->
-    BIND getOrigName b		_TO_ (b_mod, b_name) ->
-    if a_local || b_local then
-       a_name < b_name	-- can't compare module names
-    else
-       case _CMP_STRING_ a_mod b_mod of
-	 LT_  -> True
-	 EQ_  -> a_name < b_name
-	 GT__ -> False
-    BEND BEND BEND BEND
-
-#ifdef USE_ATTACK_PRAGMAS
-{-# SPECIALIZE ltLexical :: Class -> Class -> Bool #-}
-{-# SPECIALIZE ltLexical :: Id -> Id -> Bool #-}
-{-# SPECIALIZE ltLexical :: TyCon -> TyCon -> Bool #-}
-#endif
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[ExportFlag-datatype]{The @ExportFlag@ datatype}
-%*									*
-%************************************************************************
-
-The export flag @ExportAll@ means `export all there is', so there are
-times when it is attached to a class or data type which has no
-ops/constructors (if the class/type was imported abstractly).  In
-fact, @ExportAll@ is attached to everything except to classes/types
-which are being {\em exported} abstractly, regardless of how they were
-imported.
-
-\begin{code}
-data ExportFlag
-  = ExportAll		-- export with all constructors/methods
-  | ExportAbs		-- export abstractly
-  | NotExported
-\end{code}
-
-%************************************************************************
-%*									*
 \subsection[Outputable-class]{The @Outputable@ class}
 %*									*
 %************************************************************************
@@ -180,81 +71,6 @@ ifnotPprForUser	  sty p = case sty of PprForUser -> ppNil ; _ -> p
 ifnotPprShowAll	  sty p = case sty of PprShowAll -> ppNil ; _ -> p
 \end{code}
 
-These functions test strings to see if they fit the lexical categories
-defined in the Haskell report. 
-Normally applied as in e.g. @isConop (getLocalName foo)@
-
-\begin{code}
-isConop, isAconop, isAvarid, isAvarop :: FAST_STRING -> Bool
-
-isConop cs
-  | _NULL_ cs	= False
-  | c == '_'	= isConop (_TAIL_ cs)		-- allow for leading _'s
-  | otherwise	= isUpper c || c == ':' 
-		  || c == '[' || c == '('	-- [] () and (,,) come is as Conop strings !!!
-		  || isUpperISO c
-  where					
-    c = _HEAD_ cs
-
-isAconop cs
-  | _NULL_ cs	= False
-  | otherwise	= c == ':'
-  where
-    c = _HEAD_ cs
-
-isAvarid cs
-  | _NULL_ cs	 = False
-  | c == '_'	 = isAvarid (_TAIL_ cs)	-- allow for leading _'s
-  | isLower c	 = True
-  | isLowerISO c = True
-  | otherwise    = False
-  where
-    c = _HEAD_ cs
-
-isAvarop cs
-  | _NULL_ cs	 		    = False
-  | isLower c    		    = False
-  | isUpper c    		    = False
-  | c `elem` "!#$%&*+./<=>?@\\^|~-" = True
-  | isSymbolISO c		    = True
-  | otherwise			    = False
-  where
-    c = _HEAD_ cs
-
-isSymbolISO c = ord c `elem` (0xd7 : 0xf7 : [0xa1 .. 0xbf])
-isUpperISO  c = 0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c
-isLowerISO  c = 0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c
-\end{code}
-
-And one ``higher-level'' interface to those:
-
-\begin{code}
-isOpLexeme :: NamedThing a => a -> Bool
-
-isOpLexeme v
-  = let str = snd (getOrigName v) in isAvarop str || isAconop str
-
--- print `vars`, (op) correctly
-pprOp, pprNonOp :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty
-
-pprOp sty var
-  = if isOpLexeme var
-    then ppr sty var
-    else ppBesides [ppChar '`', ppr sty var, ppChar '`']
-
-pprNonOp sty var
-  = if isOpLexeme var
-    then ppBesides [ppLparen, ppr sty var, ppRparen]
-    else ppr sty var
-
-#ifdef USE_ATTACK_PRAGMAS
-{-# SPECIALIZE isOpLexeme :: Id -> Bool #-}
-{-# SPECIALIZE pprNonOp :: PprStyle -> Id -> Pretty #-}
-{-# SPECIALIZE pprNonOp :: PprStyle -> TyCon -> Pretty #-}
-{-# SPECIALIZE pprOp :: PprStyle -> Id -> Pretty #-}
-#endif
-\end{code}
-
 \begin{code}
 instance Outputable Bool where
     ppr sty True = ppPStr SLIT("True")
diff --git a/ghc/compiler/utils/Ubiq.lhi b/ghc/compiler/utils/Ubiq.lhi
index 2b02a6aef4..922c0c67bc 100644
--- a/ghc/compiler/utils/Ubiq.lhi
+++ b/ghc/compiler/utils/Ubiq.lhi
@@ -30,8 +30,8 @@ import Kind		( Kind )
 import Literal		( Literal )
 import Maybes		( MaybeErr )
 import MatchEnv 	( MatchEnv )
-import Name		( Module(..), RdrName, Name )
-import Outputable	( ExportFlag, NamedThing(..), Outputable(..) )
+import Name		( Module(..), RdrName, Name, ExportFlag, NamedThing(..) )
+import Outputable	( Outputable(..) )
 import PprStyle		( PprStyle )
 import PragmaInfo	( PragmaInfo )
 import Pretty		( PrettyRep )
@@ -44,9 +44,9 @@ import TcType		( TcMaybe )
 import TyCon		( TyCon, Arity(..) )
 import TyVar		( GenTyVar, TyVar(..) )
 import Type		( GenType, Type(..) )
-import UniqFM		( UniqFM )
+import UniqFM		( UniqFM, Uniquable(..) )
 import UniqSupply	( UniqSupply )
-import Unique		( Unique, Uniquable(..) )
+import Unique		( Unique )
 import Usage		( GenUsage, Usage(..) )
 import Util		( Ord3(..) )
 
diff --git a/ghc/compiler/utils/UniqFM.lhs b/ghc/compiler/utils/UniqFM.lhs
index f23ef1f8f7..eb3cffbc9a 100644
--- a/ghc/compiler/utils/UniqFM.lhs
+++ b/ghc/compiler/utils/UniqFM.lhs
@@ -21,6 +21,7 @@ Basically, the things need to be in class @Uniquable@, and we use the
 
 module UniqFM (
 	UniqFM,   -- abstract type
+	Uniquable(..), -- class to go with it
 
 	emptyUFM,
 	unitUFM,
@@ -54,12 +55,12 @@ module UniqFM (
     ) where
 
 #if defined(COMPILING_GHC)
-CHK_Ubiq() -- debugging consistency check
+import Ubiq{-uitous-}
 #endif
 
-import Unique		( Unique, Uniquable(..), u2i, mkUniqueGrimily )
+import Unique		( Unique, u2i, mkUniqueGrimily )
 import Util
-import Outputable	( Outputable(..), ExportFlag )
+--import Outputable	( Outputable(..), ExportFlag )
 import Pretty		( Pretty(..), PrettyRep )
 import PprStyle		( PprStyle )
 import SrcLoc		( SrcLoc )
@@ -261,6 +262,9 @@ data UniqFM ele
 	    (UniqFM ele)
 	    (UniqFM ele)
 
+class Uniquable a where
+    uniqueOf :: a -> Unique
+
 -- for debugging only :-)
 {-
 instance Text (UniqFM a) where
diff --git a/ghc/compiler/utils/UniqSet.lhs b/ghc/compiler/utils/UniqSet.lhs
index 67db337745..9df9fc852a 100644
--- a/ghc/compiler/utils/UniqSet.lhs
+++ b/ghc/compiler/utils/UniqSet.lhs
@@ -20,12 +20,12 @@ module UniqSet (
 	isEmptyUniqSet
     ) where
 
-CHK_Ubiq() -- debugging consistency check
+import Ubiq{-uitous-}
 
 import Maybes		( maybeToBool, Maybe )
 import UniqFM
-import Unique		( Uniquable(..), Unique )
-import Outputable	( Outputable(..), ExportFlag )
+import Unique		( Unique )
+--import Outputable	( Outputable(..), ExportFlag )
 import SrcLoc		( SrcLoc )
 import Pretty		( Pretty(..), PrettyRep )
 import PprStyle		( PprStyle )
@@ -44,7 +44,7 @@ import Util		( Ord3(..) )
 %*									*
 %************************************************************************
 
-We use @UniqFM@, with a (@getItsUnique@-able) @Unique@ as ``key''
+We use @UniqFM@, with a (@uniqueOf@-able) @Unique@ as ``key''
 and the thing itself as the ``value'' (for later retrieval).
 
 \begin{code}