[commit: ghc] new-typeable: More cleaning up (65be510)

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 <[email protected]>
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]