[project @ 2004-03-18 14:06:18 by simonpj]

Arrange that deriving(Typeable) works for higher kinds

3 files changed, 111 insertions, 68 deletions

diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs
index f719c4e8fa..5e4fecea43 100644
--- a/ghc/compiler/prelude/PrelNames.lhs
+++ b/ghc/compiler/prelude/PrelNames.lhs
@@ -123,6 +123,7 @@ basicKnownKeyNames :: [Name]
 basicKnownKeyNames
  = genericTyConNames
  ++ monadNames
+ ++ typeableClassNames
  ++ [	-- Type constructors (synonyms especially)
 	ioTyConName, ioDataConName,
 	runIOName,
@@ -151,7 +152,6 @@ basicKnownKeyNames
 	realFracClassName,		-- numeric
 	realFloatClassName,		-- numeric
 	dataClassName, 
-	typeableClassName,
 
 	-- Numeric stuff
 	negateName, minusName, 
@@ -554,11 +554,24 @@ floatingClassName  = clsQual  pREL_FLOAT FSLIT("Floating") floatingClassKey
 realFloatClassName = clsQual  pREL_FLOAT FSLIT("RealFloat") realFloatClassKey
 
 -- Class Ix
-ixClassName	   = clsQual pREL_ARR FSLIT("Ix") ixClassKey
+ixClassName = clsQual pREL_ARR FSLIT("Ix") ixClassKey
 
--- Class Typeable and Data
+-- Class Typeable
 typeableClassName = clsQual tYPEABLE FSLIT("Typeable") typeableClassKey
-dataClassName     = clsQual gENERICS FSLIT("Data")     dataClassKey
+typeable1ClassName = clsQual tYPEABLE FSLIT("Typeable") typeable1ClassKey
+typeable2ClassName = clsQual tYPEABLE FSLIT("Typeable") typeable2ClassKey
+typeable3ClassName = clsQual tYPEABLE FSLIT("Typeable") typeable3ClassKey
+typeable4ClassName = clsQual tYPEABLE FSLIT("Typeable") typeable4ClassKey
+typeable5ClassName = clsQual tYPEABLE FSLIT("Typeable") typeable5ClassKey
+typeable6ClassName = clsQual tYPEABLE FSLIT("Typeable") typeable6ClassKey
+typeable7ClassName = clsQual tYPEABLE FSLIT("Typeable") typeable7ClassKey
+
+typeableClassNames = 	[ typeableClassName, typeable1ClassName, typeable2ClassName
+		 	, typeable3ClassName, typeable4ClassName, typeable5ClassName
+			, typeable6ClassName, typeable7ClassName ]
+
+-- Class Data
+dataClassName = clsQual gENERICS FSLIT("Data") dataClassKey
 
 -- Error module
 assertErrorName	  = varQual pREL_ERR FSLIT("assertError") assertErrorIdKey
@@ -705,7 +718,6 @@ methName cls occ uniq
 boundedClassKey		= mkPreludeClassUnique 1 
 enumClassKey		= mkPreludeClassUnique 2 
 eqClassKey		= mkPreludeClassUnique 3 
-typeableClassKey	= mkPreludeClassUnique 4
 floatingClassKey	= mkPreludeClassUnique 5 
 fractionalClassKey	= mkPreludeClassUnique 6 
 integralClassKey	= mkPreludeClassUnique 7 
@@ -719,7 +731,16 @@ realClassKey		= mkPreludeClassUnique 14
 realFloatClassKey	= mkPreludeClassUnique 15
 realFracClassKey	= mkPreludeClassUnique 16
 showClassKey		= mkPreludeClassUnique 17
-ixClassKey		= mkPreludeClassUnique 20
+ixClassKey		= mkPreludeClassUnique 18
+
+typeableClassKey	= mkPreludeClassUnique 20
+typeable1ClassKey	= mkPreludeClassUnique 21
+typeable2ClassKey	= mkPreludeClassUnique 22
+typeable3ClassKey	= mkPreludeClassUnique 23
+typeable4ClassKey	= mkPreludeClassUnique 24
+typeable5ClassKey	= mkPreludeClassUnique 25
+typeable6ClassKey	= mkPreludeClassUnique 26
+typeable7ClassKey	= mkPreludeClassUnique 27
 \end{code}
 
 %************************************************************************
diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs
index 0f104c60ac..8b46e4c64d 100644
--- a/ghc/compiler/typecheck/TcDeriv.lhs
+++ b/ghc/compiler/typecheck/TcDeriv.lhs
@@ -15,9 +15,9 @@ import CmdLineOpts	( DynFlag(..) )
 
 import Generics		( mkTyConGenericBinds )
 import TcRnMonad
-import TcEnv		( newDFunName, 
+import TcEnv		( newDFunName, pprInstInfoDetails, 
 			  InstInfo(..), InstBindings(..),
-			  pprInstInfoDetails, tcLookupTyCon, tcExtendTyVarEnv
+			  tcLookupClass, tcLookupTyCon, tcExtendTyVarEnv
 			)
 import TcGenDeriv	-- Deriv stuff
 import InstEnv		( simpleDFunClassTyCon, extendInstEnv )
@@ -53,7 +53,7 @@ import VarSet		( mkVarSet, subVarSet )
 import PrelNames
 import SrcLoc		( srcLocSpan, Located(..) )
 import Util		( zipWithEqual, sortLt, notNull )
-import ListSetOps	( removeDups,  assoc )
+import ListSetOps	( removeDups,  assocMaybe )
 import Outputable
 import Bag
 \end{code}
@@ -301,7 +301,6 @@ makeDerivEqns tycl_decls
     ------------------------------------------------------------------
     derive_these :: [(NewOrData, Name, LHsPred Name)]
 	-- Find the (nd, TyCon, Pred) pairs that must be `derived'
-	-- NB: only source-language decls have deriving, no imported ones do
     derive_these = [ (nd, tycon, pred) 
 		   | L _ (TyData { tcdND = nd, tcdLName = L _ tycon, 
 			          tcdDerivs = Just (L _ preds) }) <- tycl_decls,
@@ -327,34 +326,10 @@ makeDerivEqns tycl_decls
     ------------------------------------------------------------------
     mk_eqn_help gla_exts DataType tycon clas tys
       | Just err <- checkSideConditions gla_exts clas tycon tys
-      = bale_out (derivingThingErr clas tys tycon tyvars err)
+      = bale_out (derivingThingErr clas tys tycon (tyConTyVars tycon) err)
       | otherwise 
-      = new_dfun_name clas tycon	 `thenM` \ dfun_name ->
-	returnM (Just (dfun_name, clas, tycon, tyvars, constraints), Nothing)
-      where
-	tyvars      = tyConTyVars tycon
-	constraints = extra_constraints ++ ordinary_constraints
-		 -- "extra_constraints": see note [Data decl contexts] above
-	extra_constraints = tyConTheta tycon
-
-	ordinary_constraints
-	  | clas `hasKey` typeableClassKey	-- For the Typeable class, the constraints
-						-- don't involve the constructor ags, only 
-						-- the tycon tyvars
-						-- e.g.   data T a b = ...
-						-- we want
-						-- 	instance (Typeable a, Typable b)
-						--		 => Typeable (T a b) where
-	  = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars]
-	  | otherwise
-	  = [ mkClassPred clas [arg_ty] 
-	    | data_con <- tyConDataCons tycon,
-	      arg_ty   <- dataConOrigArgTys data_con,
-			-- Use the same type variables
-			-- as the type constructor,
-			-- hence no need to instantiate
-	      not (isUnLiftedType arg_ty)	-- No constraints for unlifted types?
-	    ]
+      = do { eqn <- mkDataTypeEqn tycon clas
+	   ; returnM (Just eqn, Nothing) }
 
     mk_eqn_help gla_exts NewType tycon clas tys
       | can_derive_via_isomorphism && (gla_exts || std_class_via_iso clas)
@@ -528,6 +503,42 @@ new_dfun_name clas tycon 	-- Just a simple wrapper
 	-- a suitable string; hence the empty type arg list
 
 ------------------------------------------------------------------
+mkDataTypeEqn :: TyCon -> Class -> TcM DerivEqn
+mkDataTypeEqn tycon clas
+  | clas `hasKey` typeableClassKey
+  =	-- The Typeable class is special in several ways
+	-- 	  data T a b = ... deriving( Typeable )
+	-- gives
+	--	  instance Typeable2 T where ...
+	-- 1. There are no constraints in the instance
+	-- 2. There are no type variables either
+	-- 2. The actual class we want to generate isn't necessarily
+	--	Typeable; it depends on the arity of the type
+    do	{ real_clas <- tcLookupClass (typeableClassNames !! tyConArity tycon)
+	; dfun_name <- new_dfun_name real_clas tycon
+  	; return (dfun_name, real_clas, tycon, [], []) }
+
+  | otherwise
+  = do	{ dfun_name <- new_dfun_name clas tycon
+  	; return (dfun_name, clas, tycon, tyvars, constraints) }
+  where
+    tyvars            = tyConTyVars tycon
+    constraints       = extra_constraints ++ ordinary_constraints
+    extra_constraints = tyConTheta tycon
+	 -- "extra_constraints": see note [Data decl contexts] above
+
+    ordinary_constraints
+      = [ mkClassPred clas [arg_ty] 
+        | data_con <- tyConDataCons tycon,
+          arg_ty   <- dataConOrigArgTys data_con,
+    		-- Use the same type variables
+    		-- as the type constructor,
+    		-- hence no need to instantiate
+          not (isUnLiftedType arg_ty)	-- No constraints for unlifted types?
+        ]
+
+
+------------------------------------------------------------------
 -- Check side conditions that dis-allow derivability for particular classes
 -- This is *apart* from the newtype-deriving mechanism
 
@@ -766,8 +777,7 @@ genInst dfun
 	(tyvars,_,clas,[ty]) 	= tcSplitDFunTy (idType dfun)
 	clas_nm			= className clas
 	tycon  	      	     	= tcTyConAppTyCon ty 
-    	(meth_binds, aux_binds) = assoc "gen_bind:bad derived class"
-	 			  gen_list (getUnique clas) fix_env tycon
+    	(meth_binds, aux_binds) = genDerivBinds clas fix_env tycon
     in
 	-- Bring the right type variables into 
 	-- scope, and rename the method binds
@@ -778,22 +788,31 @@ genInst dfun
     returnM (InstInfo { iDFunId = dfun, iBinds = VanillaInst rn_meth_binds [] }, 
 	     aux_binds)
 
-gen_list :: [(Unique, FixityEnv -> TyCon -> (LHsBinds RdrName, LHsBinds RdrName))]
-gen_list = [(eqClassKey,      no_aux_binds (ignore_fix_env gen_Eq_binds))
- 	   ,(ordClassKey,     no_aux_binds (ignore_fix_env gen_Ord_binds))
- 	   ,(enumClassKey,    no_aux_binds (ignore_fix_env gen_Enum_binds))
- 	   ,(boundedClassKey, no_aux_binds (ignore_fix_env gen_Bounded_binds))
- 	   ,(ixClassKey,      no_aux_binds (ignore_fix_env gen_Ix_binds))
-	   ,(typeableClassKey,no_aux_binds (ignore_fix_env gen_Typeable_binds))
- 	   ,(showClassKey,    no_aux_binds gen_Show_binds)
- 	   ,(readClassKey,    no_aux_binds gen_Read_binds)
-	   ,(dataClassKey,    gen_Data_binds)
- 	   ]
-
-  -- no_aux_binds is used for generators that don't 
-  -- need to produce any auxiliary bindings
-no_aux_binds f fix_env tc = (f fix_env tc, emptyBag)
-ignore_fix_env f fix_env tc = f tc
+genDerivBinds clas fix_env tycon
+  | className clas `elem` typeableClassNames
+  = (gen_Typeable_binds tycon, emptyBag)
+
+  | otherwise
+  = case assocMaybe gen_list (getUnique clas) of
+	Just gen_fn -> gen_fn fix_env tycon
+	Nothing	    -> pprPanic "genDerivBinds: bad derived class" (ppr clas)
+  where
+    gen_list :: [(Unique, FixityEnv -> TyCon -> (LHsBinds RdrName, LHsBinds RdrName))]
+    gen_list = [(eqClassKey,      no_aux_binds (ignore_fix_env gen_Eq_binds))
+ 	       ,(ordClassKey,     no_aux_binds (ignore_fix_env gen_Ord_binds))
+ 	       ,(enumClassKey,    no_aux_binds (ignore_fix_env gen_Enum_binds))
+ 	       ,(boundedClassKey, no_aux_binds (ignore_fix_env gen_Bounded_binds))
+ 	       ,(ixClassKey,      no_aux_binds (ignore_fix_env gen_Ix_binds))
+	       ,(typeableClassKey,no_aux_binds (ignore_fix_env gen_Typeable_binds))
+ 	       ,(showClassKey,    no_aux_binds gen_Show_binds)
+ 	       ,(readClassKey,    no_aux_binds gen_Read_binds)
+	       ,(dataClassKey,    gen_Data_binds)
+ 	       ]
+
+      -- no_aux_binds is used for generators that don't 
+      -- need to produce any auxiliary bindings
+    no_aux_binds f fix_env tc = (f fix_env tc, emptyBag)
+    ignore_fix_env f fix_env tc = f tc
 \end{code}
 
 
diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs
index d051db5b4d..9796387f21 100644
--- a/ghc/compiler/typecheck/TcGenDeriv.lhs
+++ b/ghc/compiler/typecheck/TcGenDeriv.lhs
@@ -50,7 +50,7 @@ import TysWiredIn
 import MkId		( eRROR_ID )
 import PrimOp		( PrimOp(..) )
 import SrcLoc		( Located(..), noLoc, srcLocSpan )
-import TyCon		( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon,
+import TyCon		( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon, tyConArity,
 			  maybeTyConSingleCon, tyConFamilySize, tyConTyVars, tyConName
 			)
 import TcType		( isUnLiftedType, tcEqType, Type )
@@ -993,27 +993,30 @@ From the data type
 
 we generate
 
-	instance (Typeable a, Typeable b) => Typeable (T a b) where
-		typeOf _ = mkTypeRep (mkTyConRep "T")
-				     [typeOf (undefined::a),
-				      typeOf (undefined::b)]
+	instance Typeable2 T where
+		typeOf2 _ = mkAppTy (mkTyConRep "T") []
 
-Notice the use of lexically scoped type variables.
+We are passed the Typeable2 class as well as T
 
 \begin{code}
 gen_Typeable_binds :: TyCon -> LHsBinds RdrName
 gen_Typeable_binds tycon
   = unitBag $
-	mk_easy_FunBind tycon_loc typeOf_RDR [wildPat] emptyBag
-		(nlHsApps mkTypeRep_RDR [tycon_rep, arg_reps])
+	mk_easy_FunBind tycon_loc 
+		(mk_typeOf_RDR tycon) 	-- Name of appropriate type0f function
+		[wildPat] emptyBag
+		(nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
   where
     tycon_loc = getSrcSpan tycon
-    tyvars    = tyConTyVars tycon
     tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
-    arg_reps  = nlList (map mk tyvars)
-    mk tyvar  = nlHsApp (nlHsVar typeOf_RDR) 
-		      (noLoc (ExprWithTySig (nlHsVar undefined_RDR)
-				     	    (nlHsTyVar (getRdrName tyvar))))
+
+mk_typeOf_RDR :: TyCon -> RdrName
+-- Use the arity of the TyCon to make the right typeOfn function
+mk_typeOf_RDR tycon = varQual_RDR tYPEABLE_Name (mkFastString ("typeOf" ++ suffix))
+		where
+		  arity = tyConArity tycon
+		  suffix | arity == 0 = ""
+			 | otherwise  = show arity
 \end{code}