From: simonpj Date: Thu, 18 Mar 2004 14:06:19 +0000 (+0000) Subject: [project @ 2004-03-18 14:06:18 by simonpj] X-Git-Tag: Initial_conversion_from_CVS_complete~1954 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=679bbdad7c922a029cc37fb3d74c67ce6fe973c3;p=ghc-hetmet.git [project @ 2004-03-18 14:06:18 by simonpj] Arrange that deriving(Typeable) works for higher kinds --- diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs index f719c4e..5e4fece 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 0f104c6..8b46e4c 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 d051db5..9796387 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}