Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : new-typeable
http://hackage.haskell.org/trac/ghc/changeset/65be510611e3cfa1d7f48606a62845c50cd74da9 >--------------------------------------------------------------- commit 65be510611e3cfa1d7f48606a62845c50cd74da9 Author: Jose Pedro Magalhaes <j...@cs.ox.ac.uk> Date: Wed Oct 3 13:53:03 2012 +0100 More cleaning up >--------------------------------------------------------------- compiler/hsSyn/HsExpr.lhs-boot | 17 ++++++++++++----- compiler/hsSyn/HsPat.lhs-boot | 8 ++++++-- compiler/typecheck/TcDeriv.lhs | 35 ++++++++++------------------------- 3 files changed, 28 insertions(+), 32 deletions(-) diff --git a/compiler/hsSyn/HsExpr.lhs-boot b/compiler/hsSyn/HsExpr.lhs-boot index 86032f5..7b4b427 100644 --- a/compiler/hsSyn/HsExpr.lhs-boot +++ b/compiler/hsSyn/HsExpr.lhs-boot @@ -1,5 +1,5 @@ \begin{code} -{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE CPP, KindSignatures #-} module HsExpr where import SrcLoc ( Located ) @@ -8,19 +8,26 @@ import {-# SOURCE #-} HsPat ( LPat ) import Data.Data --- IA0_NOTE: We need kind annotations because of kind polymorphism data HsExpr (i :: *) data HsSplice (i :: *) data MatchGroup (a :: *) data GRHSs (a :: *) +#if __GLASGOW_HASKELL__ > 706 +instance Typeable HsSplice +instance Typeable HsExpr +instance Typeable MatchGroup +instance Typeable GRHSs +#else instance Typeable1 HsSplice -instance Data i => Data (HsSplice i) instance Typeable1 HsExpr -instance Data i => Data (HsExpr i) instance Typeable1 MatchGroup -instance Data i => Data (MatchGroup i) instance Typeable1 GRHSs +#endif + +instance Data i => Data (HsSplice i) +instance Data i => Data (HsExpr i) +instance Data i => Data (MatchGroup i) instance Data i => Data (GRHSs i) type LHsExpr a = Located (HsExpr a) diff --git a/compiler/hsSyn/HsPat.lhs-boot b/compiler/hsSyn/HsPat.lhs-boot index 2899103..85664af 100644 --- a/compiler/hsSyn/HsPat.lhs-boot +++ b/compiler/hsSyn/HsPat.lhs-boot @@ -1,15 +1,19 @@ \begin{code} -{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE CPP, KindSignatures #-} module HsPat where import SrcLoc( Located ) import Data.Data --- IA0_NOTE: We need kind annotation because of kind polymorphism. data Pat (i :: *) type LPat i = Located (Pat i) +#if __GLASGOW_HASKELL__ > 706 +instance Typeable Pat +#else instance Typeable1 Pat +#endif + instance Data i => Data (Pat i) \end{code} diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 87d344e..eb58e18 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -676,7 +676,7 @@ mkEqnHelp orig tvs cls cls_tys tc_app mtheta = do { dflags <- getDynFlags ; case checkTypeableConditions (dflags, tycon, tc_args) of Just err -> bale_out err - Nothing -> mk_typeable_eqn orig tvs cls cls_tys tycon tc_args mtheta } + Nothing -> mk_typeable_eqn orig tvs cls tycon tc_args mtheta } | isDataFamilyTyCon tycon , length tc_args /= tyConArity tycon @@ -789,23 +789,24 @@ mk_old_typeable_eqn orig tvs cls tycon tc_args mtheta , ds_tc = tycon, ds_tc_args = [] , ds_theta = mtheta `orElse` [], ds_newtype = False }) } -mk_typeable_eqn :: CtOrigin -> [TyVar] -> Class -> [Type] +mk_typeable_eqn :: CtOrigin -> [TyVar] -> Class -> TyCon -> [TcType] -> DerivContext -> TcM EarlyDerivSpec -mk_typeable_eqn orig tvs cls cls_tys tycon tc_args mtheta - -- JPM: update this comment +mk_typeable_eqn orig tvs cls tycon tc_args mtheta + -- The kind-polymorphic Typeable class is less special; namely, there is no + -- need to select the class with the right kind anymore, as we only have one. | isNothing mtheta -- deriving on a data type decl - = mk_typeable_eqn orig tvs cls cls_tys tycon [] (Just []) + = mk_typeable_eqn orig tvs cls tycon [] (Just []) | otherwise -- standalone deriving = do { checkTc (null tc_args) (ptext (sLit "Derived typeable instance must be of form (Typeable") - <> int (tyConArity tycon) <+> ppr tycon <> rparen) + <+> ppr tycon <> rparen) ; dfun_name <- new_dfun_name cls tycon ; loc <- getSrcSpanM ; return (Right $ DS { ds_loc = loc, ds_orig = orig, ds_name = dfun_name, ds_tvs = [] - , ds_cls = cls, ds_tys = cls_tys ++ [mkTyConApp tycon []] + , ds_cls = cls, ds_tys = tyConKind tycon : [mkTyConApp tycon []] , ds_tc = tycon, ds_tc_args = [] , ds_theta = mtheta `orElse` [], ds_newtype = False }) } @@ -935,7 +936,7 @@ checkSideConditions dflags mtheta cls cls_tys rep_tc rep_tc_args ty_args_why = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "is not a class") checkTypeableConditions, checkOldTypeableConditions :: Condition -checkTypeableConditions = checkFlag Opt_DeriveDataTypeable `andCond` cond_typeableOK +checkTypeableConditions = checkFlag Opt_DeriveDataTypeable checkOldTypeableConditions = checkFlag Opt_DeriveDataTypeable `andCond` cond_oldTypeableOK nonStdErr :: Class -> SDoc @@ -1066,7 +1067,7 @@ cond_isProduct (_, rep_tc, _) ptext (sLit "must have precisely one constructor") cond_oldTypeableOK :: Condition --- OK for Typeable class +-- OK for kind-monomorphic Typeable class -- Currently: (a) args all of kind * -- (b) 7 or fewer args cond_oldTypeableOK (_, tc, _) @@ -1080,22 +1081,6 @@ cond_oldTypeableOK (_, tc, _) bad_kind = quotes (pprSourceTyCon tc) <+> ptext (sLit "must only have arguments of kind `*'") -cond_typeableOK :: Condition --- JPM: update --- OK for Typeable class --- Currently: (a) args all of kind * --- (b) 7 or fewer args -cond_typeableOK (_, tc, _) - | tyConArity tc > 7 = Just too_many - | not (all (isSubOpenTypeKind . tyVarKind) (tyConTyVars tc)) - = Just bad_kind - | otherwise = Nothing - where - too_many = quotes (pprSourceTyCon tc) <+> - ptext (sLit "must have 7 or fewer arguments") - bad_kind = quotes (pprSourceTyCon tc) <+> - ptext (sLit "must only have arguments of kind `*'") - functorLikeClassKeys :: [Unique] functorLikeClassKeys = [functorClassKey, foldableClassKey, traversableClassKey] _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
