From: simonpj <unknown>
Date: Fri, 11 Oct 2002 14:46:09 +0000 (+0000)
Subject: [project @ 2002-10-11 14:46:02 by simonpj]
X-Git-Tag: Approx_11550_changesets_converted~1564
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=cbb5beb0ecef58ae6e47fa62e144a0855644f50a;p=ghc-hetmet.git

[project @ 2002-10-11 14:46:02 by simonpj]
------------------------------------------
	Implement reification for Template Haskell
	------------------------------------------

This is entirely un-tested, but I don't think it'll break non-TH stuff.

Implements
	reifyDecl T :: Dec	-- Data type T
	reifyDecl C :: Dec	-- Class C
	reifyType f :: Typ	-- Function f

I hope.
---

diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs
index c17a292..a3808de 100644
--- a/ghc/compiler/deSugar/DsExpr.lhs
+++ b/ghc/compiler/deSugar/DsExpr.lhs
@@ -20,7 +20,7 @@ import DsMonad
 
 #ifdef GHCI
 	-- Template Haskell stuff iff bootstrapped
-import DsMeta		( dsBracket )
+import DsMeta		( dsBracket, dsReify )
 #endif
 
 import HsSyn		( failureFreePat,
@@ -550,6 +550,7 @@ Here is where we desugar the Template Haskell brackets and escapes
 
 #ifdef GHCI	/* Only if bootstrapping */
 dsExpr (HsBracketOut x ps) = dsBracket x ps
+dsExpr (HsReify r)	   = dsReify r
 dsExpr (HsSplice n e _)    = pprPanic "dsExpr:splice" (ppr e)
 #endif
 
diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs
index 8571e1e..3d2450b 100644
--- a/ghc/compiler/deSugar/DsMeta.hs
+++ b/ghc/compiler/deSugar/DsMeta.hs
@@ -11,9 +11,10 @@
 -----------------------------------------------------------------------------
 
 
-module DsMeta( dsBracket, 
+module DsMeta( dsBracket, dsReify,
 	       templateHaskellNames, qTyConName, 
-	       liftName, exprTyConName, declTyConName ) where
+	       liftName, exprTyConName, declTyConName,
+	       decTyConName, typTyConName ) where
 
 #include "HsVersions.h"
 
@@ -30,23 +31,26 @@ import HsSyn  	  ( Pat(..), HsExpr(..), Stmt(..), HsLit(..), HsOverLit(..),
                     HsStmtContext(ListComp,DoExpr), ArithSeqInfo(..),
 		    HsBinds(..), MonoBinds(..), HsConDetails(..),
 		    TyClDecl(..), HsGroup(..),
+		    HsReify(..), ReifyFlavour(..), 
 		    HsType(..), HsContext(..), HsPred(..), HsTyOp(..),
 	 	    HsTyVarBndr(..), Sig(..), ForeignDecl(..),
 		    InstDecl(..), ConDecl(..), BangType(..),
 		    PendingSplice, splitHsInstDeclTy,
 		    placeHolderType, tyClDeclNames,
 		    collectHsBinders, collectPatBinders, collectPatsBinders,
-		    hsTyVarName, hsConArgs, getBangType
+		    hsTyVarName, hsConArgs, getBangType,
+		    toHsType
 		  )
 
 import PrelNames  ( mETA_META_Name, varQual, tcQual )
+import MkIface	  ( ifaceTyThing )
 import Name       ( Name, nameOccName, nameModule )
 import OccName	  ( isDataOcc, isTvOcc, occNameUserString )
 import Module	  ( moduleUserString )
-import Id         ( Id )
+import Id         ( Id, idType )
 import NameEnv
 import NameSet
-import Type       ( Type, mkGenTyConApp )
+import Type       ( Type, TyThing(..), mkGenTyConApp )
 import TyCon	  ( DataConDetails(..) )
 import TysWiredIn ( stringTy )
 import CoreSyn
@@ -76,6 +80,22 @@ dsBracket brack splices
     do_brack (TypBr t)  = do { MkC t1  <- repTy t     ; return t1 }
     do_brack (DecBr ds) = do { MkC ds1 <- repTopDs ds ; return ds1 }
 
+-----------------------------------------------------------------------------
+dsReify :: HsReify Id -> DsM CoreExpr
+-- Returns a CoreExpr of type 	reifyType --> M.Typ
+--				reifyDecl --> M.Dec
+--				reifyFixty --> M.Fix
+dsReify (ReifyOut ReifyType (AnId id))
+  = do { MkC e <- repTy (toHsType (idType id)) ;
+	 return e }
+
+dsReify r@(ReifyOut ReifyDecl thing)
+  = do { mb_d <- repTyClD (ifaceTyThing thing) ;
+	 case mb_d of
+	   Just (MkC d) -> return d 
+	   Nothing	-> pprPanic "dsReify" (ppr r)
+	}
+
 {- -------------- Examples --------------------
 
   [| \x -> x |]
@@ -929,7 +949,8 @@ templateHaskellNames
 		constrName,
 		exprTyConName, declTyConName, pattTyConName, mtchTyConName, 
 		clseTyConName, stmtTyConName, consTyConName, typeTyConName,
-		qTyConName, expTyConName, matTyConName, clsTyConName ]
+		qTyConName, expTyConName, matTyConName, clsTyConName,
+		decTyConName, typTyConName ]
 
 
 
@@ -1012,6 +1033,8 @@ typeTyConName  = tcQual  mETA_META_Name FSLIT("Type")  	       typeTyConKey
 
 qTyConName     = tcQual  mETA_META_Name FSLIT("Q")  	       qTyConKey
 expTyConName   = tcQual  mETA_META_Name FSLIT("Exp")  	       expTyConKey
+decTyConName   = tcQual  mETA_META_Name FSLIT("Dec")  	       decTyConKey
+typTyConName   = tcQual  mETA_META_Name FSLIT("Typ")  	       typTyConKey
 matTyConName   = tcQual  mETA_META_Name FSLIT("Mat")  	       matTyConKey
 clsTyConName   = tcQual  mETA_META_Name FSLIT("Cls")  	       clsTyConKey
 
@@ -1030,6 +1053,9 @@ clseTyConKey = mkPreludeTyConUnique 108
 stmtTyConKey = mkPreludeTyConUnique 109
 consTyConKey = mkPreludeTyConUnique 110
 typeTyConKey = mkPreludeTyConUnique 111
+typTyConKey  = mkPreludeTyConUnique 112
+decTyConKey  = mkPreludeTyConUnique 113
+
 
 
 -- 	IdUniques available: 200-299
diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs
index 6936e2d..3344705 100644
--- a/ghc/compiler/deSugar/DsMonad.lhs
+++ b/ghc/compiler/deSugar/DsMonad.lhs
@@ -31,7 +31,6 @@ import TcHsSyn		( TypecheckedPat, TypecheckedMatchContext, TypecheckedHsExpr )
 import HscTypes		( TyThing(..) )
 import Bag		( emptyBag, snocBag, Bag )
 import TyCon		( TyCon )
-import ErrUtils 	( WarnMsg )
 import Id		( mkSysLocal, setIdUnique, Id )
 import Module		( Module )
 import Var		( TyVar, setTyVarUnique )
diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs
index 0ff1823..9afd12e 100644
--- a/ghc/compiler/hsSyn/HsExpr.lhs
+++ b/ghc/compiler/hsSyn/HsExpr.lhs
@@ -19,7 +19,7 @@ import HsImpExp		( isOperator, pprHsVar )
 -- others:
 import ForeignCall	( Safety )
 import PprType		( pprParendType )
-import Type		( Type )
+import Type		( Type, TyThing )
 import Var		( TyVar, Id )
 import Name		( Name )
 import DataCon		( DataCon )
@@ -173,6 +173,8 @@ data HsExpr id
   | HsSplice id (HsExpr id) SrcLoc	-- $z  or $(f 4)
 					-- The id is just a unique name to 
 					-- identify this splice point
+
+  | HsReify (HsReify id)		-- reifyType t, reifyDecl i, reifyFixity
 \end{code}
 
 
@@ -392,6 +394,7 @@ ppr_expr (HsType id) = ppr id
 ppr_expr (HsSplice n e _)    = char '$' <> brackets (ppr n) <> pprParendExpr e
 ppr_expr (HsBracket b _)     = pprHsBracket b
 ppr_expr (HsBracketOut e ps) = ppr e $$ ptext SLIT("where") <+> ppr ps
+ppr_expr (HsReify r)	     = ppr r
 
 -- add parallel array brackets around a document
 --
@@ -690,6 +693,20 @@ pprHsBracket (TypBr t) = thBrackets (char 't') (ppr t)
 
 thBrackets pp_kind pp_body = char '[' <> pp_kind <> char '|' <+> 
 			     pp_body <+> ptext SLIT("|]")
+
+data HsReify id = Reify    ReifyFlavour id	-- Pre typechecking
+		| ReifyOut ReifyFlavour TyThing	-- Post typechecking
+
+data ReifyFlavour = ReifyDecl | ReifyType | ReifyFixity
+
+instance Outputable id => Outputable (HsReify id) where
+   ppr (Reify flavour id) = ppr flavour <+> ppr id
+   ppr (ReifyOut flavour thing) = ppr flavour <+> ppr thing
+
+instance Outputable ReifyFlavour where
+   ppr ReifyDecl   = ptext SLIT("reifyDecl")
+   ppr ReifyType   = ptext SLIT("reifyType")
+   ppr ReifyFixity = ptext SLIT("reifyFixity")
 \end{code}
 
 %************************************************************************
diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs
index 58268d5..10b390d 100644
--- a/ghc/compiler/main/HscTypes.lhs
+++ b/ghc/compiler/main/HscTypes.lhs
@@ -81,6 +81,7 @@ import CoreSyn		( CoreBind )
 import Id		( Id )
 import Class		( Class, classSelIds )
 import TyCon		( TyCon, isNewTyCon, tyConGenIds, tyConSelIds, tyConDataCons_maybe )
+import Type		( TyThing(..), isTyClThing )
 import DataCon		( dataConWorkId, dataConWrapId )
 import Packages		( PackageName, preludePackage )
 import CmdLineOpts	( DynFlags )
@@ -406,26 +407,6 @@ icPrintUnqual ictxt = unQualInScope (ic_rn_gbl_env ictxt)
 %************************************************************************
 
 \begin{code}
-data TyThing = AnId   Id
-	     | ATyCon TyCon
-	     | AClass Class
-
-isTyClThing :: TyThing -> Bool
-isTyClThing (ATyCon _) = True
-isTyClThing (AClass _) = True
-isTyClThing (AnId   _) = False
-
-instance NamedThing TyThing where
-  getName (AnId id)   = getName id
-  getName (ATyCon tc) = getName tc
-  getName (AClass cl) = getName cl
-
-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
-
-
 typeEnvElts    :: TypeEnv -> [TyThing]
 typeEnvClasses :: TypeEnv -> [Class]
 typeEnvTyCons  :: TypeEnv -> [TyCon]
diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs
index 8675f1c..135b207 100644
--- a/ghc/compiler/parser/Lex.lhs
+++ b/ghc/compiler/parser/Lex.lhs
@@ -205,6 +205,9 @@ data Token
   | ITcloseQuote		-- |]
   | ITidEscape   FastString	-- $x
   | ITparenEscape		-- $( 
+  | ITreifyType
+  | ITreifyDecl
+  | ITreifyFixity
 
   | ITunknown String		-- Used when the lexer can't make sense of it
   | ITeof			-- end of file token
@@ -302,6 +305,9 @@ ghcExtensionKeywordsFM = listToUFM $
 	( "stdcall",    ITstdcallconv,	 bit ffiBit),
 	( "ccall",      ITccallconv,	 bit ffiBit),
 	( "dotnet",     ITdotnet,	 bit ffiBit),
+	( "reifyDecl",  ITreifyDecl,	 bit glaExtsBit),
+	( "reifyType",  ITreifyType,	 bit glaExtsBit),
+	( "reifyFixity",ITreifyFixity,	 bit glaExtsBit),
         ("_ccall_",	ITccall (False, False, PlayRisky),
 					 bit glaExtsBit),
         ("_ccall_GC_",	ITccall (False, False, PlaySafe False),
diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y
index 851deb7..cbddb21 100644
--- a/ghc/compiler/parser/Parser.y
+++ b/ghc/compiler/parser/Parser.y
@@ -1,6 +1,6 @@
 {-								-*-haskell-*-
 -----------------------------------------------------------------------------
-$Id: Parser.y,v 1.109 2002/10/11 08:48:13 simonpj Exp $
+$Id: Parser.y,v 1.110 2002/10/11 14:46:04 simonpj Exp $
 
 Haskell grammar.
 
@@ -236,8 +236,11 @@ Conflicts: 29 shift/reduce, [SDM 19/9/2002]
 '[t|'           { ITopenTypQuote  }      
 '[d|'           { ITopenDecQuote  }      
 '|]'            { ITcloseQuote    }
-ID_SPLICE       { ITidEscape $$   }           -- $x
-'$('	        { ITparenEscape   }           -- $( exp )
+ID_SPLICE       { ITidEscape $$   }     -- $x
+'$('	        { ITparenEscape   }     -- $( exp )
+REIFY_TYPE	{ ITreifyType }	
+REIFY_DECL	{ ITreifyDecl }	
+REIFY_FIXITY	{ ITreifyFixity }
 
 %monad { P } { thenP } { returnP }
 %lexer { lexer } { ITeof }
@@ -951,6 +954,7 @@ exp10 :: { RdrNameHsExpr }
 							then HsSCC $1 $2
 							else HsPar $2 }
 
+	| reifyexp				{ HsReify $1 }
 	| fexp					{ $1 }
 
 scc_annot :: { FastString }
@@ -965,6 +969,12 @@ fexp 	:: { RdrNameHsExpr }
 	: fexp aexp				{ (HsApp $1 $2) }
   	| aexp					{ $1 }
 
+reifyexp :: { HsReify RdrName }
+	: REIFY_DECL gtycon  			{ Reify ReifyDecl $2 }
+	| REIFY_DECL qvar			{ Reify ReifyDecl $2 }
+	| REIFY_TYPE qcname			{ Reify ReifyType $2 }
+	| REIFY_FIXITY qcname			{ Reify ReifyFixity $2 }
+
 aexps0 	:: { [RdrNameHsExpr] }
 	: aexps					{ reverse $1 }
 
diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index 798c568..36bd94b 100644
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -235,7 +235,6 @@ rnExpr (HsBracket br_body loc)
     returnM (HsBracket body' loc, fvs_e `addOneFV` qTyConName)
 	-- We use the Q tycon as a proxy to haul in all the smart
 	-- constructors; see the hack in RnIfaces
-#endif
 
 rnExpr (HsSplice n e loc)
   = addSrcLoc loc			$
@@ -244,6 +243,14 @@ rnExpr (HsSplice n e loc)
     rnExpr e 				`thenM` \ (e', fvs_e) ->
     returnM (HsSplice n' e' loc, fvs_e)    
 
+rnExpr (HsReify (Reify flavour name))
+  = checkGHCI (thErr "reify")		`thenM_`
+    lookupGlobalOccRn name		`thenM` \ name' ->
+	-- For now, we can only reify top-level things
+    returnM (HsReify (Reify flavour name'), mkFVs [name', qTyConName])
+	-- The qTyCon brutally pulls in all the meta stuff
+#endif
+
 rnExpr section@(SectionL expr op)
   = rnExpr expr	 				`thenM` \ (expr', fvs_expr) ->
     rnExpr op	 				`thenM` \ (op', fvs_op) ->
diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs
index 5877872..8f0b48c 100644
--- a/ghc/compiler/rename/RnNames.lhs
+++ b/ghc/compiler/rename/RnNames.lhs
@@ -15,11 +15,11 @@ import {-# SOURCE #-} RnHiFiles	( loadInterface )
 
 import CmdLineOpts	( DynFlag(..) )
 
-import HsSyn		( HsDecl(..), IE(..), ieName, ImportDecl(..),
+import HsSyn		( IE(..), ieName, ImportDecl(..),
 			  ForeignDecl(..), HsGroup(..),
 			  collectLocatedHsBinders, tyClDeclNames 
 			)
-import RdrHsSyn		( RdrNameIE, RdrNameImportDecl, RdrNameHsDecl )
+import RdrHsSyn		( RdrNameIE, RdrNameImportDecl )
 import RnEnv
 import TcRnMonad
 
diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index b38d28b..f424dbc 100644
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -10,12 +10,13 @@ module TcExpr ( tcExpr, tcExpr_id, tcMonoExpr ) where
 
 #ifdef GHCI 	/* Only if bootstrapped */
 import {-# SOURCE #-}	TcSplice( tcSpliceExpr, tcBracket )
-import TcEnv		( bracketOK )
+import HsSyn		( HsReify(..), ReifyFlavour(..) )
+import TcEnv		( bracketOK, tcMetaTy )
 import TcSimplify	( tcSimplifyBracket )
-import DsMeta		( liftName )
+import qualified DsMeta
 #endif
 
-import HsSyn		( HsExpr(..), HsLit(..), ArithSeqInfo(..), 
+import HsSyn		( HsExpr(..), HsLit(..), ArithSeqInfo(..),
 			  mkMonoBind, recBindFields
 			)
 import RnHsSyn		( RenamedHsExpr, RenamedRecordBinds )
@@ -32,7 +33,7 @@ import Inst		( InstOrigin(..),
 			)
 import TcBinds		( tcBindsAndThen )
 import TcEnv		( tcLookupClass, tcLookupGlobal_maybe, tcLookupIdLvl,
-			  tcLookupTyCon, tcLookupDataCon, tcLookupId,
+			  tcLookupTyCon, tcLookupDataCon, tcLookupId, tcLookupGlobal,
 			  wellStaged, metaLevel
 			)
 import TcMatches	( tcMatchesCase, tcMatchLambda, tcDoStmts )
@@ -647,6 +648,23 @@ tcMonoExpr (HsBracket brack loc) res_ty
     readMutVar pending_splices		`thenM` \ pendings ->
     returnM (HsBracketOut brack pendings)
     }
+
+tcMonoExpr (HsReify (Reify flavour name)) res_ty
+  = addErrCtxt (ptext SLIT("At the reification of") <+> ppr name)	$
+    tcLookupGlobal name		`thenM` \ thing ->
+	-- For now, we can only reify top-level things
+	-- The complication for non-top-level things is just that 
+	-- they might be a TcId, and need zonking etc.
+
+    tcMetaTy  tycon_name	`thenM` \ reify_ty ->
+    unifyTauTy res_ty reify_ty	`thenM_`
+
+    returnM (HsReify (ReifyOut flavour thing))
+  where
+    tycon_name = case flavour of
+		   ReifyDecl -> DsMeta.decTyConName
+		   ReifyType -> DsMeta.typTyConName
+		   ReifyFixity -> pprPanic "tcMonoExpr: cant do reifyFixity yet" (ppr name)
 #endif GHCI
 \end{code}
 
@@ -834,7 +852,7 @@ tcId name	-- Look up the Id and instantiate its type
 		    -- just going to flag an error for now
 
 	setLIEVar lie_var	(
-	newMethodFromName orig id_ty liftName	`thenM` \ lift ->
+	newMethodFromName orig id_ty DsMeta.liftName	`thenM` \ lift ->
 		-- Put the 'lift' constraint into the right LIE
 	
 	-- Update the pending splices
diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index 88b745d..494b0d6 100644
--- a/ghc/compiler/typecheck/TcHsSyn.lhs
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -454,6 +454,8 @@ zonkExpr env (HsBracketOut body bs)
     zonk_b (n,e) = zonkExpr env e	`thenM` \ e' ->
 		   returnM (n,e')
 
+zonkExpr env (HsReify r) = returnM (HsReify r)	-- Nothing to zonk; only top
+						-- level things can be reified (for now)
 zonkExpr env (HsSplice n e loc) = WARN( True, ppr e )	-- Should not happen
 			          returnM (HsSplice n e loc)
 
diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs
index 985cc46..37e33a9 100644
--- a/ghc/compiler/typecheck/TcMatches.lhs
+++ b/ghc/compiler/typecheck/TcMatches.lhs
@@ -34,7 +34,7 @@ import TcType		( TcType, TcTyVar, tyVarsOfType, tidyOpenTypes, tidyOpenType,
 			  mkArrowKind, mkAppTy )
 import TcBinds		( tcBindsAndThen )
 import TcUnify		( unifyPArrTy,subFunTy, unifyListTy, unifyTauTy,
-			  checkSigTyVarsWrt, tcSubExp, isIdCoercion, (<$>), unifyTauTyLists )
+			  checkSigTyVarsWrt, tcSubExp, isIdCoercion, (<$>) )
 import TcSimplify	( tcSimplifyCheck, bindInstsOfLocalFuns )
 import Name		( Name )
 import PrelNames	( monadNames, mfixName )
diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs
index 6755b0c..25486d4 100644
--- a/ghc/compiler/types/PprType.lhs
+++ b/ghc/compiler/types/PprType.lhs
@@ -19,7 +19,7 @@ module PprType(
 -- friends:
 -- (PprType can see all the representations it's trying to print)
 import TypeRep		( Type(..), TyNote(..), Kind  ) -- friend
-import Type		( SourceType(..) )
+import Type		( SourceType(..), TyThing(..) )
 import TcType		( ThetaType, PredType,
 			  tcSplitSigmaTy, isPredTy, isDictTy,
 			  tcSplitTyConApp_maybe, tcSplitFunTy_maybe
@@ -88,6 +88,11 @@ instance Outputable name => Outputable (IPName name) where
 
 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
 \end{code}
 
 
diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
index 6d90068..68a9275 100644
--- a/ghc/compiler/types/Type.lhs
+++ b/ghc/compiler/types/Type.lhs
@@ -9,6 +9,8 @@ module Type (
 	Type, PredType, ThetaType,
 	Kind, TyVarSubst, 
 
+	TyThing(..), isTyClThing,
+
 	superKind, superBoxity,				-- KX and BX respectively
 	liftedBoxity, unliftedBoxity, 			-- :: BX
 	openKindCon, 					-- :: KX
@@ -85,12 +87,12 @@ import {-# SOURCE #-}	PprType( pprType )	-- Only called in debug messages
 import {-# SOURCE #-}   Subst  ( substTyWith )
 
 -- friends:
-import Var	( TyVar, tyVarKind, tyVarName, setTyVarName )
+import Var	( Id, TyVar, tyVarKind, tyVarName, setTyVarName )
 import VarEnv
 import VarSet
 
 import Name	( NamedThing(..), mkInternalName, tidyOccName )
-import Class	( classTyCon )
+import Class	( Class, classTyCon )
 import TyCon	( TyCon, isRecursiveTyCon, isPrimTyCon,
 		  isUnboxedTupleTyCon, isUnLiftedTyCon,
 		  isFunTyCon, isNewTyCon, newTyConRep,
@@ -113,6 +115,29 @@ import Maybe		( isJust )
 
 %************************************************************************
 %*									*
+			TyThing
+%*									*
+%************************************************************************
+
+\begin{code}
+data TyThing = AnId   Id
+	     | ATyCon TyCon
+	     | AClass Class
+
+isTyClThing :: TyThing -> Bool
+isTyClThing (ATyCon _) = True
+isTyClThing (AClass _) = True
+isTyClThing (AnId   _) = False
+
+instance NamedThing TyThing where
+  getName (AnId id)   = getName id
+  getName (ATyCon tc) = getName tc
+  getName (AClass cl) = getName cl
+\end{code}
+
+
+%************************************************************************
+%*									*
 \subsection{Stuff to do with kinds.}
 %*									*
 %************************************************************************