From: simonpj <unknown>
Date: Thu, 30 Oct 2003 16:02:07 +0000 (+0000)
Subject: [project @ 2003-10-30 16:01:49 by simonpj]
X-Git-Tag: Approx_11550_changesets_converted~303
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=57573e7e61032482d6be16ed4ac86c2b4115fbfa;p=ghc-hetmet.git

[project @ 2003-10-30 16:01:49 by simonpj]
This commit does a long-overdue tidy-up

* Remove PprType (gets rid of one more bunch of hi-boot files)

* Put pretty-printing for types in TypeRep

* Make a specialised pretty-printer for Types, rather than
  converting to IfaceTypes and printing those
---

diff --git a/ghc/compiler/basicTypes/DataCon.hi-boot-5 b/ghc/compiler/basicTypes/DataCon.hi-boot-5
index 07a8c68..f5a8a2d 100644
--- a/ghc/compiler/basicTypes/DataCon.hi-boot-5
+++ b/ghc/compiler/basicTypes/DataCon.hi-boot-5
@@ -1,4 +1,5 @@
 __interface DataCon 1 0 where
-__export DataCon DataCon isExistentialDataCon ;
+__export DataCon DataCon isExistentialDataCon dataConName ;
 1 data DataCon ;
 1 isExistentialDataCon :: DataCon -> PrelBase.Bool ;
+1 dataConName :: DataCon -> Name.Name ;
diff --git a/ghc/compiler/basicTypes/DataCon.hi-boot-6 b/ghc/compiler/basicTypes/DataCon.hi-boot-6
index fa29c6b..3fd253b 100644
--- a/ghc/compiler/basicTypes/DataCon.hi-boot-6
+++ b/ghc/compiler/basicTypes/DataCon.hi-boot-6
@@ -1,4 +1,5 @@
 module DataCon where
 
 data DataCon
+dataConName :: DataCon -> Name.Name
 isExistentialDataCon :: DataCon -> GHC.Base.Bool
diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs
index b9dcca2..41622c2 100644
--- a/ghc/compiler/basicTypes/DataCon.lhs
+++ b/ghc/compiler/basicTypes/DataCon.lhs
@@ -25,12 +25,11 @@ module DataCon (
 #include "HsVersions.h"
 
 import {-# SOURCE #-} Subst( substTyWith )
-import {-# SOURCE #-} PprType( pprType )
 
 import Type		( Type, ThetaType, 
 			  mkForAllTys, mkFunTys, mkTyConApp,
 			  mkTyVarTys, splitTyConApp_maybe, 
-			  mkPredTys, isStrictPred
+			  mkPredTys, isStrictPred, pprType
 			)
 import TyCon		( TyCon, tyConDataCons, tyConDataCons, isProductTyCon,
 			  isTupleTyCon, isUnboxedTupleTyCon )
diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs
index 3a68b58..dc8ee65 100644
--- a/ghc/compiler/basicTypes/Name.lhs
+++ b/ghc/compiler/basicTypes/Name.lhs
@@ -311,13 +311,13 @@ pprName name@(Name {n_sort = sort, n_uniq = uniq, n_occ = occ})
 pprExternal sty name uniq mod occ mb_p is_wired
   | codeStyle sty        = ppr (moduleName mod) <> char '_' <> pprOccName occ
   | debugStyle sty       = sep [ppr (moduleName mod) <> dot <> pprOccName occ,
-				hsep [text "{-", 
-				      if is_wired then ptext SLIT("(w)") else empty,
-				      pprUnique uniq,
-				      case mb_p of
-					Nothing -> empty
-					Just n  -> brackets (ppr n),
-				      text "-}"]]
+				hsep [text "{-" 
+				     , if is_wired then ptext SLIT("(w)") else empty
+				     , pprUnique uniq
+-- (overkill)			     , case mb_p of
+--				 	 Nothing -> empty
+--					 Just n  -> brackets (ppr n)
+				     , text "-}"]]
   | unqualStyle sty name = pprOccName occ
   | otherwise		 = ppr (moduleName mod) <> dot <> pprOccName occ
 
diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs
index ee6dfd4..b3b9afc 100644
--- a/ghc/compiler/codeGen/CgClosure.lhs
+++ b/ghc/compiler/codeGen/CgClosure.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: CgClosure.lhs,v 1.60 2003/05/14 09:13:53 simonmar Exp $
+% $Id: CgClosure.lhs,v 1.61 2003/10/30 16:01:52 simonpj Exp $
 %
 \section[CgClosure]{Code generation for closures}
 
@@ -39,7 +39,6 @@ import Name		( Name, isInternalName )
 import Module		( Module, pprModule )
 import ListSetOps	( minusList )
 import PrimRep		( PrimRep(..), getPrimRepSize )
-import PprType          ( showTypeCategory )
 import Util		( isIn, splitAtList )
 import CmdLineOpts	( opt_SccProfilingOn )
 import Outputable
@@ -47,6 +46,12 @@ import FastString
 
 import Name             ( nameOccName )
 import OccName          ( occNameFS )
+
+-- Turgid imports for showTypeCategory
+import PrelNames
+import TcType		( Type, isDictTy, tcSplitTyConApp_maybe, tcSplitFunTy_maybe )
+import TyCon		( isPrimTyCon, isTupleTyCon, isEnumerationTyCon, maybeTyConSingleCon )
+import Maybe
 \end{code}
 
 %********************************************************
@@ -674,3 +679,55 @@ chooseDynCostCentres ccs args fvs body
     in
     (use_cc, blame_cc)
 \end{code}
+
+
+\begin{code}
+showTypeCategory :: Type -> Char
+  {-
+	{C,I,F,D}   char, int, float, double
+	T	    tuple
+	S	    other single-constructor type
+	{c,i,f,d}   unboxed ditto
+	t	    *unpacked* tuple
+	s	    *unpacked" single-cons...
+
+	v	    void#
+	a	    primitive array
+
+	E	    enumeration type
+	+	    dictionary, unless it's a ...
+	L	    List
+	>	    function
+	M	    other (multi-constructor) data-con type
+	.	    other type
+	-	    reserved for others to mark as "uninteresting"
+    -}
+showTypeCategory ty
+  = if isDictTy ty
+    then '+'
+    else
+      case tcSplitTyConApp_maybe ty of
+	Nothing -> if isJust (tcSplitFunTy_maybe ty)
+		   then '>'
+		   else '.'
+
+	Just (tycon, _) ->
+          let utc = getUnique tycon in
+	  if	  utc == charDataConKey    then 'C'
+	  else if utc == intDataConKey     then 'I'
+	  else if utc == floatDataConKey   then 'F'
+	  else if utc == doubleDataConKey  then 'D'
+	  else if utc == smallIntegerDataConKey ||
+		  utc == largeIntegerDataConKey   then 'J'
+	  else if utc == charPrimTyConKey  then 'c'
+	  else if (utc == intPrimTyConKey || utc == wordPrimTyConKey
+		|| utc == addrPrimTyConKey)		   then 'i'
+	  else if utc  == floatPrimTyConKey		   then 'f'
+	  else if utc  == doublePrimTyConKey		   then 'd'
+	  else if isPrimTyCon tycon {- array, we hope -}   then 'A'	-- Bogus
+	  else if isEnumerationTyCon tycon		   then 'E'
+	  else if isTupleTyCon tycon			   then 'T'
+	  else if isJust (maybeTyConSingleCon tycon)       then 'S'
+	  else if utc == listTyConKey			   then 'L'
+	  else 'M' -- oh, well...
+\end{code}
diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs
index 89678d5..4641b63 100644
--- a/ghc/compiler/codeGen/ClosureInfo.lhs
+++ b/ghc/compiler/codeGen/ClosureInfo.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: ClosureInfo.lhs,v 1.59 2003/10/09 11:58:46 simonpj Exp $
+% $Id: ClosureInfo.lhs,v 1.60 2003/10/30 16:01:52 simonpj Exp $
 %
 \section[ClosureInfo]{Data structures which describe closures}
 
@@ -72,14 +72,14 @@ import Id		( Id, idType, idArity, idName, idPrimRep )
 import DataCon		( DataCon, dataConTag, fIRST_TAG, dataConTyCon,
 			  isNullaryDataCon, dataConName
 			)
-import Name		( Name, nameUnique, getOccName, getName )
+import Name		( Name, nameUnique, getOccName, getName, getOccString )
 import OccName		( occNameUserString )
-import PprType		( getTyDescription )
 import PrimRep
 import SMRep		-- all of it
 import Type		( isUnLiftedType, Type, repType, splitTyConApp_maybe )
+import TcType		( tcSplitSigmaTy )
 import TyCon		( isFunTyCon )
-import BasicTypes	( TopLevelFlag(..), isNotTopLevel, isTopLevel )
+import BasicTypes	( TopLevelFlag(..), isNotTopLevel, isTopLevel, ipNameName )
 import Util		( mapAccumL, listLengthCmp, lengthIs )
 import FastString
 import Outputable
@@ -1056,6 +1056,27 @@ closureTypeDescr (ClosureInfo { closureType = ty })
   = getTyDescription ty
 closureTypeDescr (ConInfo { closureCon = data_con })
   = occNameUserString (getOccName (dataConTyCon data_con))
+
+getTyDescription :: Type -> String
+getTyDescription ty
+  = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) ->
+    case tau_ty of
+      TyVarTy _	       	     -> "*"
+      AppTy fun _      	     -> getTyDescription fun
+      FunTy _ res      	     -> '-' : '>' : fun_result res
+      NewTcApp tycon _ 	     -> getOccString tycon
+      TyConApp tycon _ 	     -> getOccString tycon
+      NoteTy (FTVNote _) ty  -> getTyDescription ty
+      NoteTy (SynNote ty1) _ -> getTyDescription ty1
+      PredTy sty	     -> getPredTyDescription sty
+      ForAllTy _ ty          -> getTyDescription ty
+    }
+  where
+    fun_result (FunTy _ res) = '>' : fun_result res
+    fun_result other	     = getTyDescription other
+
+getPredTyDescription (ClassP cl tys) = getOccString cl
+getPredTyDescription (IParam ip ty)  = getOccString (ipNameName ip)
 \end{code}
 
 %************************************************************************
diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs
index b98b18f..541231a 100644
--- a/ghc/compiler/coreSyn/PprCore.lhs
+++ b/ghc/compiler/coreSyn/PprCore.lhs
@@ -27,7 +27,7 @@ import Id		( Id, idType, isDataConWorkId_maybe, idLBVarInfo, idArity,
 			  globalIdDetails, isGlobalId, isExportedId, 
 			  isSpecPragmaId, idNewDemandInfo
 			)
-import Var		( isTyVar )
+import Var		( TyVar, isTyVar, tyVarKind )
 import IdInfo		( IdInfo, megaSeqIdInfo, 
 			  arityInfo, ppArityInfo, 
 			  specInfo, pprNewStrictness,
@@ -40,7 +40,7 @@ import IdInfo		( IdInfo, megaSeqIdInfo,
 			)
 import DataCon		( dataConTyCon )
 import TyCon		( tupleTyConBoxity, isTupleTyCon )
-import PprType		( pprParendType, pprType, pprTyVarBndr )
+import Type		( pprParendType, pprType, pprParendKind )
 import BasicTypes	( tupleParens )
 import Util             ( lengthIs )
 import Outputable
@@ -294,6 +294,17 @@ pprTypedBinder binder
 	-- printing interfaces, because we get \ x::(a->b) y::(c->d) -> ...
 	--	[Jun 2002: interfaces are now binary, so this doesn't matter]
 
+pprTyVarBndr :: TyVar -> SDoc
+pprTyVarBndr tyvar
+  = getPprStyle $ \ sty ->
+    if debugStyle sty then
+        hsep [ppr tyvar, dcolon, pprParendKind kind]
+		-- See comments with ppDcolon in PprCore.lhs
+    else
+        ppr tyvar
+  where
+    kind = tyVarKind tyvar
+
 -- pprIdBndr does *not* print the type
 -- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
 pprIdBndr id = ppr id <+> 
diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs
index e643772..4ae835f 100644
--- a/ghc/compiler/deSugar/DsCCall.lhs
+++ b/ghc/compiler/deSugar/DsCCall.lhs
@@ -178,7 +178,7 @@ unboxArg arg
   -- Data types with a single constructor, which has a single, primitive-typed arg
   -- This deals with Int, Float etc; also Ptr, ForeignPtr
   | is_product_type && data_con_arity == 1 
-  = ASSERT2(isUnLiftedType data_con_arg_ty1, crudePprType arg_ty)
+  = ASSERT2(isUnLiftedType data_con_arg_ty1, pprType arg_ty)
 			-- Typechecker ensures this
     newSysLocalDs arg_ty		`thenDs` \ case_bndr ->
     newSysLocalDs data_con_arg_ty1	`thenDs` \ prim_arg ->
diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs
index 7d94541..1b8657a 100644
--- a/ghc/compiler/ghci/ByteCodeGen.lhs
+++ b/ghc/compiler/ghci/ByteCodeGen.lhs
@@ -34,7 +34,7 @@ import DataCon		( DataCon, dataConTag, fIRST_TAG, dataConTyCon,
 import TyCon		( tyConFamilySize, isDataTyCon, tyConDataCons,
 			  isUnboxedTupleTyCon )
 import Class		( Class, classTyCon )
-import Type		( Type, repType, splitFunTys, dropForAlls )
+import Type		( Type, repType, splitFunTys, dropForAlls, pprType )
 import Util
 import DataCon		( dataConRepArity )
 import Var		( isTyVar )
@@ -48,7 +48,6 @@ import ErrUtils		( showPass, dumpIfSet_dyn )
 import Unique		( mkPseudoUnique3 )
 import FastString	( FastString(..), unpackFS )
 import Panic		( GhcException(..) )
-import PprType		( pprType )
 import SMRep		( arrWordsHdrSize, arrPtrsHdrSize, StgWord )
 import Bitmap		( intsToReverseBitmap, mkBitmap )
 import OrdList
diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs
index bc17aed..879b3ec 100644
--- a/ghc/compiler/hsSyn/HsExpr.lhs
+++ b/ghc/compiler/hsSyn/HsExpr.lhs
@@ -17,8 +17,7 @@ import HsTypes		( HsType, PostTcType, SyntaxName, placeHolderType )
 import HsImpExp		( isOperator, pprHsVar )
 
 -- others:
-import PprType		( pprParendType )
-import Type		( Type )
+import Type		( Type, pprParendType )
 import Var		( TyVar, Id )
 import Name		( Name )
 import DataCon		( DataCon )
diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs
index d3661cb..85a5682 100644
--- a/ghc/compiler/hsSyn/HsTypes.lhs
+++ b/ghc/compiler/hsSyn/HsTypes.lhs
@@ -26,10 +26,9 @@ module HsTypes (
 #include "HsVersions.h"
 
 import TcType		( Type, Kind, liftedTypeKind, eqKind )
-import TypeRep		( Type )
+import Type		( {- instance Outputable Kind -}, pprParendKind, pprKind )
 import Name		( Name, mkInternalName )
 import OccName		( mkVarOcc )
-import PprType		( {- instance Outputable Kind -}, pprParendKind, pprKind )
 import BasicTypes	( IPName, Boxity, tupleParens )
 import PrelNames	( unboundKey )
 import SrcLoc		( noSrcLoc )
diff --git a/ghc/compiler/iface/IfaceType.lhs b/ghc/compiler/iface/IfaceType.lhs
index a4cf183..47f0478 100644
--- a/ghc/compiler/iface/IfaceType.lhs
+++ b/ghc/compiler/iface/IfaceType.lhs
@@ -27,7 +27,7 @@ module IfaceType (
 #include "HsVersions.h"
 
 import Type		( openTypeKind, liftedTypeKind, unliftedTypeKind,
-			  splitFunTy_maybe, eqKind )
+			  splitFunTy_maybe, eqKind, pprType )
 import TypeRep		( Type(..), TyNote(..), PredType(..), Kind, ThetaType )
 import TyCon		( TyCon, isTupleTyCon, tyConArity, tupleTyConBoxity )
 import Var		( isId, tyVarKind, idType )
@@ -38,10 +38,6 @@ import Module		( ModuleName )
 import BasicTypes	( IPName(..), Arity, Version, mapIPName, tupleParens, Boxity )
 import Outputable
 import FastString
-
-#ifdef DEBUG
-import TypeRep( crudePprType )
-#endif
 \end{code}
 
 	
@@ -342,7 +338,7 @@ toIfaceKind k
   | Just (arg,res) <- splitFunTy_maybe k 
   = IfaceFunKind (toIfaceKind arg) (toIfaceKind res)
 #ifdef DEBUG
-  | otherwise = pprTrace "toIfaceKind" (crudePprType k) IfaceOpenTypeKind
+  | otherwise = pprTrace "toIfaceKind" (pprType k) IfaceOpenTypeKind
 #endif
 
 ---------------------
diff --git a/ghc/compiler/iface/TcIface.lhs b/ghc/compiler/iface/TcIface.lhs
index 8f60c8a..c8c27e9 100644
--- a/ghc/compiler/iface/TcIface.lhs
+++ b/ghc/compiler/iface/TcIface.lhs
@@ -22,7 +22,7 @@ import BuildTyCl	( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass )
 import TcRnMonad
 import Type		( Kind, openTypeKind, liftedTypeKind, 
 			  unliftedTypeKind, mkArrowKind, splitTyConApp, 
-			  mkTyVarTys, mkGenTyConApp, mkTyVarTys, ThetaType )
+			  mkTyVarTys, mkGenTyConApp, mkTyVarTys, ThetaType, pprClassPred )
 import TypeRep		( Type(..), PredType(..) )
 import TyCon		( TyCon, tyConName )
 import HscTypes		( ExternalPackageState(..), PackageInstEnv, PackageRuleBase,
@@ -32,7 +32,6 @@ import HscTypes		( ExternalPackageState(..), PackageInstEnv, PackageRuleBase,
 			  DeclPool, RulePool, Pool(..), Gated, addRuleToPool )
 import InstEnv		( extendInstEnv )
 import CoreSyn
-import PprType		( pprClassPred )
 import PprCore		( pprIdRules )
 import Rules		( extendRuleBaseList )
 import CoreUtils	( exprType )
diff --git a/ghc/compiler/ilxGen/IlxGen.lhs b/ghc/compiler/ilxGen/IlxGen.lhs
index 2c0ea39..8d6c915 100644
--- a/ghc/compiler/ilxGen/IlxGen.lhs
+++ b/ghc/compiler/ilxGen/IlxGen.lhs
@@ -16,7 +16,7 @@ import TyCon	( TyCon,  tyConPrimRep, isUnboxedTupleTyCon, tyConDataCons,
 		  tyConTyVars, isDataTyCon, isAlgTyCon, tyConArity
 		)
 import Type	( liftedTypeKind, openTypeKind, unliftedTypeKind,
-		  isUnLiftedType, isTyVarTy, mkTyVarTy, predTypeRep,
+		  isUnLiftedType, isTyVarTy, mkTyVarTy, predTypeRep, pprType,
 		  splitForAllTys, splitFunTys, applyTy, applyTys, eqKind, tyVarsOfTypes
 		)
 import TypeRep	( Type(..) )
@@ -43,7 +43,6 @@ import Outputable
 import Char		( ord )
 import List		( partition, elem, insertBy,any  )
 import UniqSet
-import PprType		( pprType )	-- Only called in debug messages
 
 import TysPrim  ( foreignObjPrimTyCon, weakPrimTyCon, byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
 
diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index ad51a49..8b2058d 100644
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -63,7 +63,8 @@ import TcType	( Type, TcType, TcThetaType, TcTyVarSet,
 		  isClassPred, isTyVarClassPred, isLinearPred, 
 		  getClassPredTys, getClassPredTys_maybe, mkPredName,
 		  isInheritablePred, isIPPred, matchTys,
-		  tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy
+		  tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy, 
+		  pprPred, pprParendType, pprThetaArrow, pprClassPred
 		)
 import HscTypes	( ExternalPackageState(..) )
 import CoreFVs	( idFreeTyVars )
@@ -72,7 +73,6 @@ import Id	( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId, setIdUnique
 import PrelInfo	( isStandardClass, isNoDictClass )
 import Name	( Name, mkMethodOcc, getOccName, getSrcLoc, isHomePackageName, isInternalName )
 import NameSet	( addOneToNameSet )
-import PprType	( pprPred, pprParendType, pprThetaArrow, pprClassPred )	
 import Subst	( substTy, substTyWith, substTheta, mkTyVarSubst )
 import Literal	( inIntRange )
 import Var	( TyVar )
diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index e18982f..3971330 100644
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -14,7 +14,6 @@ module TcClassDcl ( tcClassSigs, tcClassDecl2,
 
 import HsSyn		( TyClDecl(..), Sig(..), MonoBinds(..), HsType(..), 
 			  HsExpr(..), HsLit(..), Pat(WildPat), HsTyVarBndr(..),
-			  HsExplicitForAll(..),
 			  mkSimpleMatch, andMonoBinds, andMonoBindList, 
 			  isPragSig, placeHolderType, mkExplicitHsForAllTy
 			)
@@ -29,7 +28,8 @@ import TcHsSyn		( TcMonoBinds )
 
 import Inst		( Inst, InstOrigin(..), instToId, newDicts, newMethod )
 import TcEnv		( tcLookupClass, tcExtendLocalValEnv2, tcExtendTyVarEnv2,
-			  InstInfo(..), pprInstInfo, simpleInstInfoTyCon, simpleInstInfoTy,
+			  InstInfo(..), pprInstInfoDetails,
+			  simpleInstInfoTyCon, simpleInstInfoTy,
 			  InstBindings(..), newDFunName
 			)
 import TcBinds		( tcMonoBinds, tcSpecSigs )
@@ -535,29 +535,28 @@ mkDefMethRhs origin clas inst_tys sel_id loc NoDefMeth
     wild_pats	 = [WildPat placeHolderType | ty <- arg_tys]
 
 mkDefMethRhs origin clas inst_tys sel_id loc GenDefMeth 
-  =  	-- A generic default method
-	-- If the method is defined generically, we can only do the job if the
+  = 	-- A generic default method
+    	-- If the method is defined generically, we can only do the job if the
 	-- instance declaration is for a single-parameter type class with
 	-- a type constructor applied to type arguments in the instance decl
 	-- 	(checkTc, so False provokes the error)
-     ASSERT( isInstDecl origin )	-- We never get here from a class decl
-
-     checkTc (isJust maybe_tycon)
-	     (badGenericInstance sel_id (notSimple inst_tys))		`thenM_`
-     checkTc (tyConHasGenerics tycon)
-	     (badGenericInstance sel_id (notGeneric tycon))		`thenM_`
-
-     ioToTcRn (dumpIfSet opt_PprStyle_Debug "Generic RHS" stuff)	`thenM_`
-
-	-- Rename it before returning it
-     rnExpr rhs			`thenM` \ (rn_rhs, _) ->
-     returnM rn_rhs
+    ASSERT( isInstDecl origin )	-- We never get here from a class decl
+    do	{ checkTc (isJust maybe_tycon)
+	 	  (badGenericInstance sel_id (notSimple inst_tys))
+	; checkTc (tyConHasGenerics tycon)
+	   	  (badGenericInstance sel_id (notGeneric tycon))
+
+	; dflags <- getDOpts
+	; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body" 
+		   (vcat [ppr clas <+> ppr inst_tys,
+			  nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
+
+		-- Rename it before returning it
+	; (rn_rhs, _) <- rnExpr rhs
+	; returnM rn_rhs }
   where
     rhs = mkGenericRhs sel_id clas_tyvar tycon
 
-    stuff = vcat [ppr clas <+> ppr inst_tys,
-		  nest 4 (ppr sel_id <+> equals <+> ppr rhs)]
-
 	  -- The tycon is only used in the generic case, and in that
 	  -- case we require that the instance decl is for a single-parameter
 	  -- type class with type variable arguments:
@@ -629,7 +628,7 @@ getGenericInstances class_decls
 	-- Otherwise print it out
 	{ dflags <- getDOpts
 	; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Generic instances" 
-	 	   (vcat (map pprInstInfo gen_inst_info)))	
+	 	   (vcat (map pprInstInfoDetails gen_inst_info)))	
 	; returnM gen_inst_info }}
 
 get_generics decl@(ClassDecl {tcdName = class_name, tcdMeths = def_methods, tcdLoc = loc})
@@ -670,7 +669,6 @@ get_generics decl@(ClassDecl {tcdName = class_name, tcdMeths = def_methods, tcdL
     checkTc (null missing) (missingGenericInstances missing)	`thenM_`
 
     returnM inst_infos
-
   where
     generic_binds :: [(HsType Name, RenamedMonoBinds)]
     generic_binds = getGenericBinds def_methods
diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs
index dbe552e..911da5c 100644
--- a/ghc/compiler/typecheck/TcDeriv.lhs
+++ b/ghc/compiler/typecheck/TcDeriv.lhs
@@ -232,11 +232,7 @@ tcDeriving tycl_decls
   where
     ddump_deriving :: [InstInfo] -> RenamedHsBinds -> SDoc
     ddump_deriving inst_infos extra_binds
-      = vcat (map ppr_info inst_infos) $$ ppr extra_binds
-
-    ppr_info inst_info = pprInstInfo inst_info $$ 
-			 nest 4 (pprInstInfoDetails inst_info)
-	-- pprInstInfo doesn't print much: only the type
+      = vcat (map pprInstInfoDetails inst_infos) $$ ppr extra_binds
 
 -----------------------------------------
 deriveOrdinaryStuff []	-- Short cut
diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs
index 21fecdd..54c4eee 100644
--- a/ghc/compiler/typecheck/TcEnv.lhs
+++ b/ghc/compiler/typecheck/TcEnv.lhs
@@ -572,8 +572,10 @@ data InstBindings
 
 pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info))]
 
-pprInstInfoDetails (InstInfo { iBinds = VanillaInst b _ }) = ppr b
-pprInstInfoDetails (InstInfo { iBinds = NewTypeDerived _}) = text "Derived from the representation type"
+pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info))
+  where
+    details (VanillaInst b _)  = ppr b
+    details (NewTypeDerived _) = text "Derived from the representation type"
 
 simpleInstInfoTy :: InstInfo -> Type
 simpleInstInfoTy info = case tcSplitDFunTy (idType (iDFunId info)) of
diff --git a/ghc/compiler/typecheck/TcHsType.lhs b/ghc/compiler/typecheck/TcHsType.lhs
index b1f9e97..0861e8c 100644
--- a/ghc/compiler/typecheck/TcHsType.lhs
+++ b/ghc/compiler/typecheck/TcHsType.lhs
@@ -43,9 +43,8 @@ import TcType		( Type, PredType(..), ThetaType, TyVarDetails(..),
 		 	  mkForAllTys, mkFunTys, tcEqType, isPredTy,
 			  mkSigmaTy, mkPredTy, mkGenTyConApp, mkTyConApp, mkAppTys, 
 			  liftedTypeKind, unliftedTypeKind, eqKind,
-			  tcSplitFunTy_maybe, tcSplitForAllTys, tcSplitSigmaTy
-			)
-import PprType		( pprKind, pprThetaArrow )
+			  tcSplitFunTy_maybe, tcSplitForAllTys, tcSplitSigmaTy, 
+			  pprKind, pprThetaArrow )
 import qualified Type	( splitFunTys )
 import Inst		( Inst, InstOrigin(..), newMethod, instToId )
 
diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index f3e350a..35795ab 100644
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -23,8 +23,7 @@ import TcMType		( tcInstType, checkValidTheta, checkValidInstHead, instTypeErr,
 			  checkAmbiguity, SourceTyCtxt(..) )
 import TcType		( mkClassPred, tcSplitForAllTys, tyVarsOfType,
 			  tcSplitSigmaTy, getClassPredTys, tcSplitPredTy_maybe, mkTyVarTys,
-			  TyVarDetails(..), tcSplitDFunTy
-			)
+			  TyVarDetails(..), tcSplitDFunTy, pprClassPred )
 import Inst		( InstOrigin(..), tcInstClassOp, newDicts, instToId, 
 			  showLIE, tcExtendLocalInstEnv )
 import TcDeriv		( tcDeriving )
@@ -32,7 +31,6 @@ import TcEnv		( tcExtendGlobalValEnv, tcExtendTyVarEnv2,
  			  InstInfo(..), InstBindings(..), 
 			  newDFunName, tcExtendLocalValEnv
 			)
-import PprType		( pprClassPred )
 import TcHsType		( kcHsSigType, tcHsKindedType )
 import TcUnify		( checkSigTyVars )
 import TcSimplify	( tcSimplifyCheck, tcSimplifyTop )
diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs
index b2c86cc..c1c7bce 100644
--- a/ghc/compiler/typecheck/TcMType.lhs
+++ b/ghc/compiler/typecheck/TcMType.lhs
@@ -61,9 +61,8 @@ import TcType		( TcType, TcThetaType, TcTauType, TcPredType,
 			  liftedTypeKind, defaultKind, superKind,
 			  superBoxity, liftedBoxity, typeKind,
 			  tyVarsOfType, tyVarsOfTypes, 
-			  eqKind, isTypeKind, 
-			)
-import PprType		( pprThetaArrow )
+			  eqKind, isTypeKind, pprThetaArrow, 
+			  pprPred, pprTheta, pprClassPred )
 import Subst		( Subst, mkTopTyVarSubst, substTy )
 import Class		( Class, classArity, className )
 import TyCon		( TyCon, isSynTyCon, isUnboxedTupleTyCon, 
@@ -74,7 +73,6 @@ import Var		( TyVar, tyVarKind, tyVarName, isTyVar,
 -- others:
 import TcRnMonad          -- TcType, amongst others
 import FunDeps		( grow )
-import PprType		( pprPred, pprTheta, pprClassPred )
 import Name		( Name, setNameUnique, mkSystemTvNameEncoded )
 import VarSet
 import CmdLineOpts	( dopt, DynFlag(..) )
diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs
index 59d790f..da49d2e 100644
--- a/ghc/compiler/typecheck/TcRnDriver.lhs
+++ b/ghc/compiler/typecheck/TcRnDriver.lhs
@@ -637,6 +637,8 @@ tc_rn_src_decls ds
 	-- Rename the splice expression, and get its supporting decls
 	(rn_splice_expr, splice_fvs) <- addSrcLoc splice_loc $
 				 	rnExpr splice_expr ;
+	failIfErrsM ;	-- Don't typecheck if renaming failed
+
 	-- Execute the splice
 	spliced_decls <- tcSpliceDecls rn_splice_expr ;
 
diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index a2849de..33c9cbd 100644
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -32,8 +32,7 @@ import TcUnify		( unifyKind )
 import TcType		( TcKind, ThetaType, TcType,
 			  mkArrowKind, liftedTypeKind, 
 			  tcSplitSigmaTy, tcEqType )
-import Type		( splitTyConApp_maybe )
-import PprType		( pprThetaArrow, pprParendType )
+import Type		( splitTyConApp_maybe, pprThetaArrow, pprParendType )
 import FieldLabel	( fieldLabelName, fieldLabelType )
 import Generics		( validGenericMethodType, canDoGenerics )
 import Class		( Class, className, classTyCon, DefMeth(..), classBigSig )
diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs
index 46a7892..11d6858 100644
--- a/ghc/compiler/typecheck/TcTyDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyDecls.lhs
@@ -25,7 +25,7 @@ import RnHsSyn		( extractHsTyNames )
 import Type		( predTypeRep )
 import BuildTyCl	( newTyConRhs )
 import HscTypes		( TyThing(..) )
-import TyCon            ( TyCon, ArgVrcs, tyConArity, tyConDataCons_maybe, tyConDataCons, tyConTyVars,
+import TyCon            ( TyCon, ArgVrcs, tyConArity, tyConDataCons, tyConTyVars,
                           getSynTyConDefn, isSynTyCon, isAlgTyCon, isHiBootTyCon,
 			  tyConName, isNewTyCon, isProductTyCon, tyConArgVrcs )
 import Class		( classTyCon )
@@ -36,7 +36,6 @@ import Name		( Name, isTyVarName )
 import NameEnv
 import NameSet
 import Digraph 		( SCC(..), stronglyConnComp, stronglyConnCompR )
-import Maybe		( isNothing )
 import BasicTypes	( RecFlag(..) )
 import Outputable
 \end{code}
diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs
index 45f662b..eaa3238 100644
--- a/ghc/compiler/typecheck/TcType.lhs
+++ b/ghc/compiler/typecheck/TcType.lhs
@@ -102,14 +102,15 @@ module TcType (
   tidyTyVarBndr, tidyOpenTyVar, tidyOpenTyVars,
   typeKind, eqKind,
 
-  tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta
-  ) where
+  tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
 
-#include "HsVersions.h"
+  pprKind, pprParendKind,
+  pprType, pprParendType,
+  pprPred, pprTheta, pprThetaArrow, pprClassPred
 
+  ) where
 
-import {-# SOURCE #-} PprType( pprType )
--- PprType imports TcType so that it can print intelligently
+#include "HsVersions.h"
 
 -- friends:
 import TypeRep		( Type(..), TyNote(..), funTyCon )  -- friend
@@ -133,7 +134,10 @@ import Type		(	-- Re-exports
 			  tidyTyVarBndr, tidyOpenTyVar,
 			  tidyOpenTyVars, eqKind, 
 			  hasMoreBoxityInfo, liftedBoxity,
-			  superBoxity, typeKind, superKind, repType
+			  superBoxity, typeKind, superKind, repType,
+			  pprKind, pprParendKind,
+			  pprType, pprParendType,
+			  pprPred, pprTheta, pprThetaArrow, pprClassPred
 			)
 import TyCon		( TyCon, isUnLiftedTyCon, tyConUnique )
 import Class		( Class )
diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs
index 9feb547..3d70bcb 100644
--- a/ghc/compiler/typecheck/TcUnify.lhs
+++ b/ghc/compiler/typecheck/TcUnify.lhs
@@ -43,8 +43,7 @@ import TcType		( TcKind, TcType, TcSigmaType, TcRhoType, TcTyVar, TcTauType,
 			  isSkolemTyVar, isUserTyVar, 
 			  tidyOpenType, tidyOpenTypes, tidyOpenTyVar, tidyOpenTyVars,
 			  eqKind, openTypeKind, liftedTypeKind, isTypeKind, mkArrowKind,
-			  hasMoreBoxityInfo, allDistinctTyVars
-			)
+			  hasMoreBoxityInfo, allDistinctTyVars, pprType )
 import Inst		( newDicts, instToId, tcInstCall )
 import TcMType		( getTcTyVar, putTcTyVar, tcInstType, newKindVar,
 			  newTyVarTy, newTyVarTys, newOpenTypeKind,
@@ -53,7 +52,6 @@ import TcSimplify	( tcSimplifyCheck )
 import TysWiredIn	( listTyCon, parrTyCon, tupleTyCon )
 import TcEnv		( tcGetGlobalTyVars, findGlobals )
 import TyCon		( TyCon, tyConArity, isTupleTyCon, tupleTyConBoxity )
-import PprType		( pprType )
 import Id		( Id, mkSysLocal )
 import Var		( Var, varName, tyVarKind )
 import VarSet		( emptyVarSet, unitVarSet, unionVarSet, elemVarSet, varSetElems )
diff --git a/ghc/compiler/types/FunDeps.lhs b/ghc/compiler/types/FunDeps.lhs
index e3023ae..743a34c 100644
--- a/ghc/compiler/types/FunDeps.lhs
+++ b/ghc/compiler/types/FunDeps.lhs
@@ -21,7 +21,6 @@ import TcType		( Type, ThetaType, PredType(..),
 			  predTyUnique, mkClassPred, tyVarsOfTypes, tyVarsOfPred,
 			  unifyTyListsX, unifyExtendTysX, tcEqType
 			)
-import PprType		(  )
 import VarSet
 import VarEnv
 import Outputable
diff --git a/ghc/compiler/types/PprType.hi-boot b/ghc/compiler/types/PprType.hi-boot
deleted file mode 100644
index ee67e73..0000000
--- a/ghc/compiler/types/PprType.hi-boot
+++ /dev/null
@@ -1,7 +0,0 @@
-_interface_ PprType 1
-_exports_
-PprType pprType pprPred;
-_declarations_
-1 pprType _:_ TypeRep.Type -> Outputable.SDoc ;;
-1 pprPred _:_ Type.PredType -> Outputable.SDoc ;;
-
diff --git a/ghc/compiler/types/PprType.hi-boot-5 b/ghc/compiler/types/PprType.hi-boot-5
deleted file mode 100644
index 75ea5c9..0000000
--- a/ghc/compiler/types/PprType.hi-boot-5
+++ /dev/null
@@ -1,5 +0,0 @@
-__interface PprType 1 0 where
-__export PprType pprType pprPred ;
-1 pprType :: TypeRep.Type -> Outputable.SDoc ;
-1 pprPred :: Type.PredType -> Outputable.SDoc ;
-
diff --git a/ghc/compiler/types/PprType.hi-boot-6 b/ghc/compiler/types/PprType.hi-boot-6
deleted file mode 100644
index 554b6dd..0000000
--- a/ghc/compiler/types/PprType.hi-boot-6
+++ /dev/null
@@ -1,5 +0,0 @@
-module PprType where
-
-pprType :: TypeRep.Type -> Outputable.SDoc
-pprPred :: Type.PredType -> Outputable.SDoc
-
diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs
deleted file mode 100644
index a5a523c..0000000
--- a/ghc/compiler/types/PprType.lhs
+++ /dev/null
@@ -1,215 +0,0 @@
-%
-% (c) The AQUA Project, Glasgow University, 1996-1998
-%
-\section[PprType]{Printing Types, TyVars, Classes, TyCons}
-
-\begin{code}
-module PprType(
-	pprKind, pprParendKind,
-	pprType, pprParendType,
-	pprPred, pprTheta, pprThetaArrow, pprClassPred,
-	pprTyVarBndr, pprTyVarBndrs,
-
-	-- Junk
-	getTyDescription, showTypeCategory
- ) where
-
-#include "HsVersions.h"
-
--- friends:
--- (PprType can see all the representations it's trying to print)
-import TypeRep		( Type(..), TyNote(..), PredType(..), TyThing(..), Kind, superKind  ) -- friend
-import Type		( typeKind, eqKind )
-import IfaceType	( toIfaceType, toIfacePred, pprParendIfaceType,
-		 	  toIfaceKind, pprParendIfaceKind,
-			  getIfaceExt ) 
-
-import TcType		( ThetaType, PredType, 
-			  tcSplitSigmaTy, isDictTy,
-			  tcSplitTyConApp_maybe, tcSplitFunTy_maybe
-			) 
-import Var		( TyVar, tyVarKind )
-import Class		( Class )
-import TyCon		( isPrimTyCon, isTupleTyCon, maybeTyConSingleCon, isEnumerationTyCon )
-
--- others:
-import Maybes		( maybeToBool )
-import Name		( NamedThing(..), getOccString )
-import Outputable
-import BasicTypes	( IPName(..), ipNameName )
-import PrelNames		-- quite a few *Keys
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection{The external interface}
-%*									*
-%************************************************************************
-
-@pprType@ is the standard @Type@ printer; the overloaded @ppr@ function is
-defined to use this.  @pprParendType@ is the same, except it puts
-parens around the type, except for the atomic cases.  @pprParendType@
-works just by setting the initial context precedence very high.
-
-\begin{code}
-pprType, pprParendType :: Type -> SDoc
--- To save duplicating type-printing machinery, 
--- we print a type by converting to an IfaceType and printing that
-pprType       ty = getIfaceExt $ \ ext ->
-		   ppr (toIfaceType ext ty)
-pprParendType ty = getIfaceExt $ \ ext ->
-		   pprParendIfaceType (toIfaceType ext ty)
-
-pprKind, pprParendKind :: Kind -> SDoc
-pprKind       k = ppr (toIfaceKind k)
-pprParendKind k = pprParendIfaceKind (toIfaceKind k)
-
-pprPred :: PredType -> SDoc
-pprPred pred = getIfaceExt $ \ ext ->
-	       ppr (toIfacePred ext pred)
-
-pprClassPred :: Class -> [Type] -> SDoc
-pprClassPred clas tys = ppr clas <+> sep (map pprParendType tys)
-
-pprTheta :: ThetaType -> SDoc
-pprTheta theta = parens (sep (punctuate comma (map pprPred theta)))
-
-pprThetaArrow :: ThetaType -> SDoc
-pprThetaArrow theta 
-  | null theta = empty
-  | otherwise  = parens (sep (punctuate comma (map pprPred theta))) <+> ptext SLIT("=>")
-
-instance Outputable Type where
-    ppr ty | typeKind ty `eqKind` superKind = pprKind ty
-	   | otherwise		            = pprType ty
-
-instance Outputable PredType where
-    ppr = pprPred
-
-instance Outputable name => OutputableBndr (IPName name) where
-    pprBndr _ n = ppr n	-- Simple for now
-
-instance Outputable TyThing where
-  ppr (AnId   id)   = ptext SLIT("AnId")     <+> ppr id
-  ppr (ATyCon tc)   = ptext SLIT("ATyCon")   <+> ppr tc
-  ppr (AClass cl)   = ptext SLIT("AClass")   <+> ppr cl
-  ppr (ADataCon dc) = ptext SLIT("ADataCon") <+> ppr dc
-
-instance NamedThing TyThing where	-- Can't put this with the type
-  getName (AnId id)     = getName id	-- decl, because the DataCon instance
-  getName (ATyCon tc)   = getName tc	-- isn't visible there
-  getName (AClass cl)   = getName cl
-  getName (ADataCon dc) = getName dc
-\end{code}
-
-
-
-%************************************************************************
-%*									*
-\subsection[TyVar]{@TyVar@}
-%*									*
-%************************************************************************
-
-We print type-variable binders with their kinds in interface files,
-and when in debug mode.
-
-\begin{code}
-pprTyVarBndr :: TyVar -> SDoc
-pprTyVarBndr tyvar
-  = getPprStyle $ \ sty ->
-    if debugStyle sty then
-        hsep [ppr tyvar, dcolon, pprParendKind kind]
-		-- See comments with ppDcolon in PprCore.lhs
-    else
-        ppr tyvar
-  where
-    kind = tyVarKind tyvar
-
-pprTyVarBndrs tyvars = hsep (map pprTyVarBndr tyvars)
-\end{code}
-
-
-%************************************************************************
-%*									*
-\subsection{Mumbo jumbo}
-%*									*
-%************************************************************************
-
-Grab a name for the type. This is used to determine the type
-description for profiling.
-
-\begin{code}
-getTyDescription :: Type -> String
-
-getTyDescription ty
-  = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) ->
-    case tau_ty of
-      TyVarTy _	       	     -> "*"
-      AppTy fun _      	     -> getTyDescription fun
-      FunTy _ res      	     -> '-' : '>' : fun_result res
-      NewTcApp tycon _ 	     -> getOccString tycon
-      TyConApp tycon _ 	     -> getOccString tycon
-      NoteTy (FTVNote _) ty  -> getTyDescription ty
-      NoteTy (SynNote ty1) _ -> getTyDescription ty1
-      PredTy sty	     -> getPredTyDescription sty
-      ForAllTy _ ty          -> getTyDescription ty
-    }
-  where
-    fun_result (FunTy _ res) = '>' : fun_result res
-    fun_result other	     = getTyDescription other
-
-getPredTyDescription (ClassP cl tys) = getOccString cl
-getPredTyDescription (IParam ip ty)  = getOccString (ipNameName ip)
-\end{code}
-
-
-\begin{code}
-showTypeCategory :: Type -> Char
-  {-
-	{C,I,F,D}   char, int, float, double
-	T	    tuple
-	S	    other single-constructor type
-	{c,i,f,d}   unboxed ditto
-	t	    *unpacked* tuple
-	s	    *unpacked" single-cons...
-
-	v	    void#
-	a	    primitive array
-
-	E	    enumeration type
-	+	    dictionary, unless it's a ...
-	L	    List
-	>	    function
-	M	    other (multi-constructor) data-con type
-	.	    other type
-	-	    reserved for others to mark as "uninteresting"
-    -}
-showTypeCategory ty
-  = if isDictTy ty
-    then '+'
-    else
-      case tcSplitTyConApp_maybe ty of
-	Nothing -> if maybeToBool (tcSplitFunTy_maybe ty)
-		   then '>'
-		   else '.'
-
-	Just (tycon, _) ->
-          let utc = getUnique tycon in
-	  if	  utc == charDataConKey    then 'C'
-	  else if utc == intDataConKey     then 'I'
-	  else if utc == floatDataConKey   then 'F'
-	  else if utc == doubleDataConKey  then 'D'
-	  else if utc == smallIntegerDataConKey ||
-		  utc == largeIntegerDataConKey   then 'J'
-	  else if utc == charPrimTyConKey  then 'c'
-	  else if (utc == intPrimTyConKey || utc == wordPrimTyConKey
-		|| utc == addrPrimTyConKey)		   then 'i'
-	  else if utc  == floatPrimTyConKey		   then 'f'
-	  else if utc  == doublePrimTyConKey		   then 'd'
-	  else if isPrimTyCon tycon {- array, we hope -}   then 'A'	-- Bogus
-	  else if isEnumerationTyCon tycon		   then 'E'
-	  else if isTupleTyCon tycon			   then 'T'
-	  else if maybeToBool (maybeTyConSingleCon tycon)  then 'S'
-	  else if utc == listTyConKey			   then 'L'
-	  else 'M' -- oh, well...
-\end{code}
diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
index 9720470..9de68e2 100644
--- a/ghc/compiler/types/Type.lhs
+++ b/ghc/compiler/types/Type.lhs
@@ -65,8 +65,12 @@ module Type (
 	eqType, eqKind, 
 
 	-- Seq
-	seqType, seqTypes
+	seqType, seqTypes,
 
+	-- Pretty-printing
+	pprKind, pprParendKind,
+	pprType, pprParendType,
+	pprPred, pprTheta, pprThetaArrow, pprClassPred
     ) where
 
 #include "HsVersions.h"
@@ -265,7 +269,7 @@ splitFunTy (FunTy arg res)   = (arg, res)
 splitFunTy (NoteTy _ ty)     = splitFunTy ty
 splitFunTy (PredTy p)        = splitFunTy (predTypeRep p)
 splitFunTy (NewTcApp tc tys) = splitFunTy (newTypeRep tc tys)
-splitFunTy other	     = pprPanic "splitFunTy" (crudePprType other)
+splitFunTy other	     = pprPanic "splitFunTy" (ppr other)
 
 splitFunTy_maybe :: Type -> Maybe (Type, Type)
 splitFunTy_maybe (FunTy arg res)   = Just (arg, res)
@@ -291,21 +295,21 @@ zipFunTys orig_xs orig_ty = split [] orig_xs orig_ty orig_ty
     split acc xs     nty (NoteTy _ ty)     = split acc           xs nty ty
     split acc xs     nty (PredTy p)        = split acc           xs nty (predTypeRep p)
     split acc xs     nty (NewTcApp tc tys) = split acc           xs nty (newTypeRep tc tys)
-    split acc (x:xs) nty ty                = pprPanic "zipFunTys" (ppr orig_xs <+> crudePprType orig_ty)
+    split acc (x:xs) nty ty                = pprPanic "zipFunTys" (ppr orig_xs <+> ppr orig_ty)
     
 funResultTy :: Type -> Type
 funResultTy (FunTy arg res)   = res
 funResultTy (NoteTy _ ty)     = funResultTy ty
 funResultTy (PredTy p)        = funResultTy (predTypeRep p)
 funResultTy (NewTcApp tc tys) = funResultTy (newTypeRep tc tys)
-funResultTy ty		      = pprPanic "funResultTy" (crudePprType ty)
+funResultTy ty		      = pprPanic "funResultTy" (ppr ty)
 
 funArgTy :: Type -> Type
 funArgTy (FunTy arg res)   = arg
 funArgTy (NoteTy _ ty)     = funArgTy ty
 funArgTy (PredTy p)        = funArgTy (predTypeRep p)
 funArgTy (NewTcApp tc tys) = funArgTy (newTypeRep tc tys)
-funArgTy ty		   = pprPanic "funArgTy" (crudePprType ty)
+funArgTy ty		   = pprPanic "funArgTy" (ppr ty)
 \end{code}
 
 
@@ -350,7 +354,7 @@ tyConAppArgs ty = snd (splitTyConApp ty)
 splitTyConApp :: Type -> (TyCon, [Type])
 splitTyConApp ty = case splitTyConApp_maybe ty of
 			Just stuff -> stuff
-			Nothing	   -> pprPanic "splitTyConApp" (crudePprType ty)
+			Nothing	   -> pprPanic "splitTyConApp" (ppr ty)
 
 splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
 splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
@@ -434,7 +438,7 @@ typePrimRep ty = case repType ty of
 		   FunTy _ _	 -> PtrRep
 		   AppTy _ _	 -> PtrRep	-- ??
 		   TyVarTy _	 -> PtrRep
-		   other	 -> pprPanic "typePrimRep" (crudePprType ty)
+		   other	 -> pprPanic "typePrimRep" (ppr ty)
 \end{code}
 
 
@@ -516,7 +520,7 @@ applyTys orig_fun_ty arg_tys
   = substTyWith (take n_args tvs) arg_tys 
 		(mkForAllTys (drop n_args tvs) rho_ty)
   | otherwise		-- Too many type args
-  = ASSERT2( n_tvs > 0, crudePprType orig_fun_ty )	-- Zero case gives infnite loop!
+  = ASSERT2( n_tvs > 0, ppr orig_fun_ty )	-- Zero case gives infnite loop!
     applyTys (substTyWith tvs (take n_tvs arg_tys) rho_ty)
 	     (drop n_tvs arg_tys)
   where
diff --git a/ghc/compiler/types/TypeRep.lhs b/ghc/compiler/types/TypeRep.lhs
index dce606f..1cb51c4 100644
--- a/ghc/compiler/types/TypeRep.lhs
+++ b/ghc/compiler/types/TypeRep.lhs
@@ -17,31 +17,37 @@ module TypeRep (
 	openKindCon, 					-- :: KX
 	typeCon,					-- :: BX -> KX
 	liftedTypeKind, unliftedTypeKind, openTypeKind,	-- :: KX
+	isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind,
 	mkArrowKind, mkArrowKinds,			-- :: KX -> KX -> KX
 
 	funTyCon,
 
-	crudePprType		-- Prints type representations for debugging
+	-- Pretty-printing
+	pprKind, pprParendKind,
+	pprType, pprParendType,
+	pprPred, pprTheta, pprThetaArrow, pprClassPred
     ) where
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-} DataCon( DataCon )
+import {-# SOURCE #-} DataCon( DataCon, dataConName )
 
 -- friends:
 import Var	  ( Id, TyVar, tyVarKind )
 import VarEnv     ( TyVarEnv )
 import VarSet     ( TyVarSet )
-import Name	  ( Name, mkWiredInName, mkInternalName )
+import Name	  ( Name, NamedThing(..), mkWiredInName, mkInternalName )
 import OccName	  ( mkOccFS, mkKindOccFS, tcName )
-import BasicTypes ( IPName )
-import TyCon	  ( TyCon, KindCon, mkFunTyCon, mkKindCon, mkSuperKindCon, isNewTyCon )
+import BasicTypes ( IPName, tupleParens )
+import TyCon	  ( TyCon, KindCon, mkFunTyCon, mkKindCon, mkSuperKindCon, isNewTyCon,
+		    tyConArity, tupleTyConBoxity, isTupleTyCon, tyConName )
 import Class	  ( Class )
 
 -- others
 import PrelNames	( gHC_PRIM, kindConKey, boxityConKey, liftedConKey, 
 			  unliftedConKey, typeConKey, anyBoxConKey, 
-			  funTyConKey
+			  funTyConKey, listTyConKey, parrTyConKey,
+			  hasKey
 			)
 import SrcLoc		( noSrcLoc )
 import Outputable
@@ -342,6 +348,17 @@ openKindCon     = mkKindCon openKindConName superKind
 openTypeKind    = TyConApp openKindCon []
 \end{code}
 
+\begin{code}
+isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind :: Kind -> Bool
+isLiftedTypeKind (TyConApp tc [TyConApp bc []])   = tyConName tc == typeConName && 
+						    tyConName bc == liftedConName
+isUnliftedTypeKind (TyConApp tc [TyConApp bc []]) = tyConName tc == typeConName && 
+						    tyConName bc == unliftedConName
+isOpenTypeKind (TyConApp tc []) = tyConName tc == openKindConName
+
+isSuperKind (TyConApp tc []) = tyConName tc == superKindName
+\end{code}
+
 ------------------------------------------
 Define arrow kinds
 
@@ -369,6 +386,18 @@ data TyThing = AnId     Id
 	     | ADataCon DataCon
 	     | ATyCon   TyCon
 	     | AClass   Class
+
+instance Outputable TyThing where
+  ppr (AnId   id)   = ptext SLIT("AnId")     <+> ppr id
+  ppr (ATyCon tc)   = ptext SLIT("ATyCon")   <+> ppr tc
+  ppr (AClass cl)   = ptext SLIT("AClass")   <+> ppr cl
+  ppr (ADataCon dc) = ptext SLIT("ADataCon") <+> ppr (dataConName dc)
+
+instance NamedThing TyThing where	-- Can't put this with the type
+  getName (AnId id)     = getName id	-- decl, because the DataCon instance
+  getName (ATyCon tc)   = getName tc	-- isn't visible there
+  getName (AClass cl)   = getName cl
+  getName (ADataCon dc) = dataConName dc
 \end{code}
 
 
@@ -398,34 +427,130 @@ funTyConName = mkWiredInName gHC_PRIM
 \end{code}
 
 
-
 %************************************************************************
 %*									*
-		Crude printing
-	For debug purposes, we may want to print a type directly
+\subsection{The external interface}
 %*									*
 %************************************************************************
 
+@pprType@ is the standard @Type@ printer; the overloaded @ppr@ function is
+defined to use this.  @pprParendType@ is the same, except it puts
+parens around the type, except for the atomic cases.  @pprParendType@
+works just by setting the initial context precedence very high.
+
 \begin{code}
-crudePprType :: Type -> SDoc
-crudePprType (TyVarTy tv)      = ppr tv
-crudePprType (AppTy t1 t2)     = crudePprType t1 <+> (parens (crudePprType t2))
-crudePprType (FunTy t1 t2)     = crudePprType t1 <+> (parens (crudePprType t2))
-crudePprType (TyConApp tc tys) = ppr_tc_app (ppr tc <> pp_nt tc) tys
-crudePprType (NewTcApp tc tys) = ptext SLIT("<nt>") <+> ppr_tc_app (ppr tc <> pp_nt tc) tys
-crudePprType (ForAllTy tv ty)  = sep [ptext SLIT("forall") <+> 
-				        parens (ppr tv <+> crudePprType (tyVarKind tv)) <> dot,
-				      crudePprType ty]
-crudePprType (PredTy st)  	        = braces (crudePprPredTy st)
-crudePprType (NoteTy (SynNote ty1) ty2) = crudePprType ty1
-crudePprType (NoteTy other ty)          = crudePprType ty
-
-crudePprPredTy (ClassP cls tys) = ppr_tc_app (ppr cls) tys
-crudePprPredTy (IParam ip ty)   = ppr ip <> dcolon <> crudePprType ty
-
-ppr_tc_app :: SDoc -> [Type] -> SDoc
-ppr_tc_app tc tys = tc <+> sep (map (parens . crudePprType) tys)
-
-pp_nt tc | isNewTyCon tc = ptext SLIT("(nt)")
-	 | otherwise     = empty
-\end{code}
\ No newline at end of file
+data Prec = TopPrec 	-- No parens
+	  | FunPrec 	-- Function args; no parens for tycon apps
+	  | TyConPrec 	-- Tycon args; no parens for atomic
+	  deriving( Eq, Ord )
+
+maybeParen :: Prec -> Prec -> SDoc -> SDoc
+maybeParen ctxt_prec inner_prec pretty
+  | ctxt_prec < inner_prec = pretty
+  | otherwise		   = parens pretty
+
+------------------
+pprType, pprParendType :: Type -> SDoc
+pprType       ty = ppr_type TopPrec   ty
+pprParendType ty = ppr_type TyConPrec ty
+
+------------------
+pprKind, pprParendKind :: Kind -> SDoc
+pprKind       k = ppr_kind TopPrec k
+pprParendKind k = ppr_kind TyConPrec k
+
+------------------
+pprPred :: PredType -> SDoc
+pprPred (ClassP cls tys) = pprClassPred cls tys
+pprPred (IParam ip ty)   = ppr ip <> dcolon <> pprType ty
+
+pprClassPred :: Class -> [Type] -> SDoc
+pprClassPred clas tys = ppr clas <+> sep (map pprParendType tys)
+
+pprTheta :: ThetaType -> SDoc
+pprTheta theta = parens (sep (punctuate comma (map pprPred theta)))
+
+pprThetaArrow :: ThetaType -> SDoc
+pprThetaArrow theta 
+  | null theta = empty
+  | otherwise  = parens (sep (punctuate comma (map pprPred theta))) <+> ptext SLIT("=>")
+
+------------------
+instance Outputable Type where
+    ppr ty = pprType ty
+
+instance Outputable PredType where
+    ppr = pprPred
+
+instance Outputable name => OutputableBndr (IPName name) where
+    pprBndr _ n = ppr n	-- Simple for now
+
+------------------
+	-- OK, here's the main printer
+
+ppr_type :: Prec -> Type -> SDoc
+ppr_type p (TyVarTy tv)      	      = ppr tv
+ppr_type p (PredTy pred)     	      = braces (ppr pred)
+ppr_type p (NoteTy (SynNote ty1) ty2) = ppr_type p ty1
+ppr_type p (NoteTy other         ty2) = ppr_type p ty2
+
+ppr_type p (TyConApp tc tys) = ppr_tc_app p tc tys
+ppr_type p (NewTcApp tc tys) = ifPprDebug (ptext SLIT("<nt>")) <> 
+			       ppr_tc_app p tc tys
+
+ppr_type p (AppTy t1 t2) = maybeParen p TyConPrec $
+			   pprType t1 <+> ppr_type TyConPrec t2
+
+ppr_type p (FunTy ty1 ty2)
+  = -- We don't want to lose synonyms, so we mustn't use splitFunTys here.
+    maybeParen p FunPrec $
+    sep (ppr_type FunPrec ty1 : ppr_fun_tail ty2)
+  where
+    ppr_fun_tail (FunTy ty1 ty2) = (arrow <+> ppr_type FunPrec ty1) : ppr_fun_tail ty2
+    ppr_fun_tail other_ty        = [arrow <+> pprType other_ty]
+
+ppr_type p ty@(ForAllTy _ _)  
+  = maybeParen p FunPrec $
+    sep [pprForAll tvs, pprThetaArrow ctxt, pprType tau]
+  where
+    (tvs,  rho) = split1 [] ty
+    (ctxt, tau) = split2 [] rho
+
+    split1 tvs (ForAllTy tv ty) = split1 (tv:tvs) ty
+    split1 tvs ty		= (reverse tvs, ty)
+ 
+    split2 ps (PredTy p `FunTy` ty) = split2 (p:ps) ty
+    split2 ps ty		    = (reverse ps, ty)
+
+ppr_tc_app :: Prec -> TyCon -> [Type] -> SDoc
+ppr_tc_app p tc [ty] 
+  | tc `hasKey` listTyConKey = brackets (pprType ty)
+  | tc `hasKey` parrTyConKey = ptext SLIT("[:") <> pprType ty <> ptext SLIT(":]")
+ppr_tc_app p tc tys
+  | isTupleTyCon tc && tyConArity tc == length tys
+  = tupleParens (tupleTyConBoxity tc) (sep (punctuate comma (map pprType tys)))
+  | otherwise
+  = maybeParen p TyConPrec $
+    ppr tc <+> sep (map (ppr_type TyConPrec) tys)
+
+-------------------
+pprForAll tvs = ptext SLIT("forall") <+> sep (map pprTvBndr tvs) <> dot
+
+pprTvBndr tv | isLiftedTypeKind kind = ppr tv
+	     | otherwise	     = parens (ppr tv <+> dcolon <+> pprKind kind)
+	     where
+	       kind = tyVarKind tv
+
+
+-------------------
+ppr_kind :: Prec -> Kind -> SDoc
+ppr_kind p k
+  | isOpenTypeKind k     = ptext SLIT("?")
+  | isLiftedTypeKind k   = ptext SLIT("*")
+  | isUnliftedTypeKind k = ptext SLIT("#")
+ppr_kind p (TyVarTy tv)  = ppr tv
+ppr_kind p (FunTy k1 k2) = maybeParen p FunPrec $
+			 	  sep [ ppr_kind FunPrec k1, arrow <+> pprKind k2]
+ppr_kind p other = ptext SLIT("STRANGE KIND:") <+> ppr_type p other
+\end{code}
+