Implement poly-kinded Typeable

This patch makes the Data.Typeable.Typeable class work with arguments of any
kind. In particular, this removes the Typeable1..7 class hierarchy, greatly
simplyfing the whole Typeable story. Also added is the AutoDeriveTypeable
language extension, which will automatically derive Typeable for all types and
classes declared in that module. Since there is now no good reason to give
handwritten instances of the Typeable class, those are ignored (for backwards
compatibility), and a warning is emitted.

The old, kind-* Typeable class is now called OldTypeable, and lives in the
Data.OldTypeable module. It is deprecated, and should be removed in some future
version of GHC.

7 files changed, 235 insertions, 69 deletions

diff --git a/compiler/hsSyn/HsExpr.lhs-boot b/compiler/hsSyn/HsExpr.lhs-boot
index a04fa3095b..7cddf2f810 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,22 +8,29 @@ import {-# SOURCE #-} HsPat  ( LPat )
 
 import Data.Data
 
--- IA0_NOTE: We need kind annotations because of kind polymorphism
 data HsExpr (i :: *)
 data HsCmd  (i :: *)
 data HsSplice (i :: *)
 data MatchGroup (a :: *) (body :: *)
 data GRHSs (a :: *) (body :: *)
 
+#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 HsCmd
-instance Data i => Data (HsCmd i)
 instance Typeable2 MatchGroup
-instance (Data i, Data body) => Data (MatchGroup i body)
 instance Typeable2 GRHSs
+#endif
+
+instance Data i => Data (HsSplice i)
+instance Data i => Data (HsExpr i)
+instance Data i => Data (HsCmd i)
+instance (Data i, Data body) => Data (MatchGroup i body)
 instance (Data i, Data body) => Data (GRHSs i body)
 
 instance OutputableBndr id => Outputable (HsExpr id)
diff --git a/compiler/hsSyn/HsPat.lhs-boot b/compiler/hsSyn/HsPat.lhs-boot
index 28991030ad..85664afe3a 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/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 52eed21a73..9bfef011e2 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -428,6 +428,7 @@ data WarningFlag =
    | Opt_WarnUnsupportedCallingConventions
    | Opt_WarnUnsupportedLlvmVersion
    | Opt_WarnInlineRuleShadowing
+   | Opt_WarnTypeableInstances
    deriving (Eq, Show, Enum)
 
 data Language = Haskell98 | Haskell2010
@@ -495,6 +496,7 @@ data ExtensionFlag
  
    | Opt_StandaloneDeriving
    | Opt_DeriveDataTypeable
+   | Opt_AutoDeriveTypeable       -- Automatic derivation of Typeable
    | Opt_DeriveFunctor
    | Opt_DeriveTraversable
    | Opt_DeriveFoldable
@@ -2400,7 +2402,8 @@ fWarningFlags = [
   ( "warn-pointless-pragmas",           Opt_WarnPointlessPragmas, nop ),
   ( "warn-unsupported-calling-conventions", Opt_WarnUnsupportedCallingConventions, nop ),
   ( "warn-inline-rule-shadowing",       Opt_WarnInlineRuleShadowing, nop ),
-  ( "warn-unsupported-llvm-version",    Opt_WarnUnsupportedLlvmVersion, nop ) ]
+  ( "warn-unsupported-llvm-version",    Opt_WarnUnsupportedLlvmVersion, nop ),
+  ( "warn-typeable-instances",          Opt_WarnTypeableInstances, nop ) ]
 
 -- | These @-\<blah\>@ flags can all be reversed with @-no-\<blah\>@
 negatableFlags :: [FlagSpec GeneralFlag]
@@ -2631,6 +2634,7 @@ xFlags = [
   ( "UnboxedTuples",                    Opt_UnboxedTuples, nop ),
   ( "StandaloneDeriving",               Opt_StandaloneDeriving, nop ),
   ( "DeriveDataTypeable",               Opt_DeriveDataTypeable, nop ),
+  ( "AutoDeriveTypeable",               Opt_AutoDeriveTypeable, nop ),
   ( "DeriveFunctor",                    Opt_DeriveFunctor, nop ),
   ( "DeriveTraversable",                Opt_DeriveTraversable, nop ),
   ( "DeriveFoldable",                   Opt_DeriveFoldable, nop ),
@@ -2788,7 +2792,9 @@ standardWarnings
         Opt_WarnUnsupportedCallingConventions,
         Opt_WarnUnsupportedLlvmVersion,
         Opt_WarnInlineRuleShadowing,
-        Opt_WarnDuplicateConstraints
+        Opt_WarnDuplicateConstraints,
+        Opt_WarnInlineRuleShadowing,
+        Opt_WarnTypeableInstances
       ]
 
 minusWOpts :: [WarningFlag]
diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index 03a95dee8f..d296beeaaf 100644
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -155,7 +155,7 @@ sharing a unique will be used.
 basicKnownKeyNames :: [Name]
 basicKnownKeyNames
  = genericTyConNames
- ++ typeableClassNames
+ ++ oldTypeableClassNames
  ++ [   -- Type constructors (synonyms especially)
         ioTyConName, ioDataConName,
         runMainIOName,
@@ -186,6 +186,7 @@ basicKnownKeyNames
         applicativeClassName,
         foldableClassName,
         traversableClassName,
+        typeableClassName,              -- derivable
 
         -- Numeric stuff
         negateName, minusName, geName, eqName,
@@ -350,7 +351,8 @@ gHC_PRIM, gHC_TYPES, gHC_GENERICS,
     gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE, dATA_MONOID,
     gHC_CONC, gHC_IO, gHC_IO_Exception,
     gHC_ST, gHC_ARR, gHC_STABLE, gHC_PTR, gHC_ERR, gHC_REAL,
-    gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC, tYPEABLE, tYPEABLE_INTERNAL, gENERICS,
+    gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC,
+    tYPEABLE, tYPEABLE_INTERNAL, oLDTYPEABLE, oLDTYPEABLE_INTERNAL, gENERICS,
     dOTNET, rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, mONAD_ZIP,
     aRROW, cONTROL_APPLICATIVE, gHC_DESUGAR, rANDOM, gHC_EXTS,
     cONTROL_EXCEPTION_BASE, gHC_TYPELITS, gHC_IP :: Module
@@ -391,6 +393,8 @@ sYSTEM_IO       = mkBaseModule (fsLit "System.IO")
 dYNAMIC         = mkBaseModule (fsLit "Data.Dynamic")
 tYPEABLE        = mkBaseModule (fsLit "Data.Typeable")
 tYPEABLE_INTERNAL = mkBaseModule (fsLit "Data.Typeable.Internal")
+oLDTYPEABLE     = mkBaseModule (fsLit "Data.OldTypeable")
+oLDTYPEABLE_INTERNAL = mkBaseModule (fsLit "Data.OldTypeable.Internal")
 gENERICS        = mkBaseModule (fsLit "Data.Data")
 dOTNET          = mkBaseModule (fsLit "GHC.Dotnet")
 rEAD_PREC       = mkBaseModule (fsLit "Text.ParserCombinators.ReadPrec")
@@ -617,10 +621,14 @@ showString_RDR          = varQual_RDR gHC_SHOW (fsLit "showString")
 showSpace_RDR           = varQual_RDR gHC_SHOW (fsLit "showSpace")
 showParen_RDR           = varQual_RDR gHC_SHOW (fsLit "showParen")
 
-typeOf_RDR, mkTyCon_RDR, mkTyConApp_RDR :: RdrName
-typeOf_RDR     = varQual_RDR tYPEABLE_INTERNAL (fsLit "typeOf")
-mkTyCon_RDR    = varQual_RDR tYPEABLE_INTERNAL (fsLit "mkTyCon")
-mkTyConApp_RDR = varQual_RDR tYPEABLE_INTERNAL (fsLit "mkTyConApp")
+typeRep_RDR, mkTyCon_RDR, mkTyConApp_RDR,
+    oldTypeOf_RDR, oldMkTyCon_RDR, oldMkTyConApp_RDR :: RdrName
+typeRep_RDR       = varQual_RDR tYPEABLE_INTERNAL    (fsLit "typeRep")
+mkTyCon_RDR       = varQual_RDR tYPEABLE_INTERNAL    (fsLit "mkTyCon")
+mkTyConApp_RDR    = varQual_RDR tYPEABLE_INTERNAL    (fsLit "mkTyConApp")
+oldTypeOf_RDR     = varQual_RDR oLDTYPEABLE_INTERNAL (fsLit "typeOf")
+oldMkTyCon_RDR    = varQual_RDR oLDTYPEABLE_INTERNAL (fsLit "mkTyCon")
+oldMkTyConApp_RDR = varQual_RDR oLDTYPEABLE_INTERNAL (fsLit "mkTyConApp")
 
 undefined_RDR :: RdrName
 undefined_RDR = varQual_RDR gHC_ERR (fsLit "undefined")
@@ -950,22 +958,24 @@ ixClassName :: Name
 ixClassName = clsQual gHC_ARR (fsLit "Ix") ixClassKey
 
 -- Class Typeable
-typeableClassName, typeable1ClassName, typeable2ClassName,
-    typeable3ClassName, typeable4ClassName, typeable5ClassName,
-    typeable6ClassName, typeable7ClassName :: Name
-typeableClassName  = clsQual tYPEABLE_INTERNAL (fsLit "Typeable") typeableClassKey
-typeable1ClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable1") typeable1ClassKey
-typeable2ClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable2") typeable2ClassKey
-typeable3ClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable3") typeable3ClassKey
-typeable4ClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable4") typeable4ClassKey
-typeable5ClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable5") typeable5ClassKey
-typeable6ClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable6") typeable6ClassKey
-typeable7ClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable7") typeable7ClassKey
-
-typeableClassNames :: [Name]
-typeableClassNames =    [ typeableClassName, typeable1ClassName, typeable2ClassName
-                        , typeable3ClassName, typeable4ClassName, typeable5ClassName
-                        , typeable6ClassName, typeable7ClassName ]
+typeableClassName,
+    oldTypeableClassName, oldTypeable1ClassName, oldTypeable2ClassName,
+    oldTypeable3ClassName, oldTypeable4ClassName, oldTypeable5ClassName,
+    oldTypeable6ClassName, oldTypeable7ClassName :: Name
+typeableClassName  = clsQual tYPEABLE_INTERNAL (fsLit "Typeable")  typeableClassKey
+oldTypeableClassName  = clsQual oLDTYPEABLE_INTERNAL (fsLit "Typeable")  oldTypeableClassKey
+oldTypeable1ClassName = clsQual oLDTYPEABLE_INTERNAL (fsLit "Typeable1") oldTypeable1ClassKey
+oldTypeable2ClassName = clsQual oLDTYPEABLE_INTERNAL (fsLit "Typeable2") oldTypeable2ClassKey
+oldTypeable3ClassName = clsQual oLDTYPEABLE_INTERNAL (fsLit "Typeable3") oldTypeable3ClassKey
+oldTypeable4ClassName = clsQual oLDTYPEABLE_INTERNAL (fsLit "Typeable4") oldTypeable4ClassKey
+oldTypeable5ClassName = clsQual oLDTYPEABLE_INTERNAL (fsLit "Typeable5") oldTypeable5ClassKey
+oldTypeable6ClassName = clsQual oLDTYPEABLE_INTERNAL (fsLit "Typeable6") oldTypeable6ClassKey
+oldTypeable7ClassName = clsQual oLDTYPEABLE_INTERNAL (fsLit "Typeable7") oldTypeable7ClassKey
+
+oldTypeableClassNames :: [Name]
+oldTypeableClassNames = [ oldTypeableClassName, oldTypeable1ClassName, oldTypeable2ClassName
+                        , oldTypeable3ClassName, oldTypeable4ClassName, oldTypeable5ClassName
+                        , oldTypeable6ClassName, oldTypeable7ClassName ]
 
 -- Class Data
 dataClassName :: Name
@@ -1231,6 +1241,18 @@ ghciIoClassKey = mkPreludeClassUnique 44
 
 ipClassNameKey :: Unique
 ipClassNameKey = mkPreludeClassUnique 45
+
+oldTypeableClassKey, oldTypeable1ClassKey, oldTypeable2ClassKey,
+    oldTypeable3ClassKey, oldTypeable4ClassKey, oldTypeable5ClassKey,
+    oldTypeable6ClassKey, oldTypeable7ClassKey :: Unique
+oldTypeableClassKey        = mkPreludeClassUnique 46
+oldTypeable1ClassKey       = mkPreludeClassUnique 47
+oldTypeable2ClassKey       = mkPreludeClassUnique 48
+oldTypeable3ClassKey       = mkPreludeClassUnique 49
+oldTypeable4ClassKey       = mkPreludeClassUnique 50
+oldTypeable5ClassKey       = mkPreludeClassUnique 51
+oldTypeable6ClassKey       = mkPreludeClassUnique 52
+oldTypeable7ClassKey       = mkPreludeClassUnique 53
 \end{code}
 
 %************************************************************************
diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index f84efd9ef0..7374e62d1a 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -312,7 +312,15 @@ tcDeriving tycl_decls inst_decls deriv_decls
                 -- And make the necessary "equations".
           is_boot <- tcIsHsBoot
         ; traceTc "tcDeriving" (ppr is_boot)
-        ; early_specs <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
+
+        -- If -XAutoDeriveTypeable is on, add Typeable instances for each
+        -- datatype and class defined in this module
+        ; isAutoDeriveTypeable <- xoptM Opt_AutoDeriveTypeable
+        ; let deriv_decls' = deriv_decls ++ if isAutoDeriveTypeable
+                                              then deriveTypeable tycl_decls
+                                              else []
+
+        ; early_specs <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls'
 
         -- for each type, determine the auxliary declarations that are common
         -- to multiple derivations involving that type (e.g. Generic and
@@ -367,6 +375,12 @@ tcDeriving tycl_decls inst_decls deriv_decls
 
     hangP s x = text "" $$ hang (ptext (sLit s)) 2 x
 
+    deriveTypeable :: [LTyClDecl Name] -> [LDerivDecl Name]
+    deriveTypeable tys =
+      [ L l (DerivDecl (L l (HsAppTy (noLoc (HsTyVar typeableClassName))
+                                     (L l (HsTyVar (tcdName t))))))
+      | L l t <- tys ]
+
 -- Prints the representable type family instance
 pprRepTy :: FamInst Unbranched -> SDoc
 pprRepTy fi@(FamInst { fi_branches = FirstBranch (FamInstBranch { fib_lhs = lhs
@@ -567,6 +581,13 @@ deriveTyData tvs tc tc_args (L loc deriv_pred)
                 -- The "deriv_pred" is a LHsType to take account of the fact that for
                 -- newtype deriving we allow deriving (forall a. C [a]).
 
+                -- Typeable is special
+        ; if className cls == typeableClassName
+          then mkEqnHelp DerivOrigin
+                  (varSetElemsKvsFirst (mkVarSet tvs `extendVarSetList` deriv_tvs))
+                  cls cls_tys (mkTyConApp tc tc_args) Nothing
+          else do {
+
         -- Given data T a b c = ... deriving( C d ),
         -- we want to drop type variables from T so that (C d (T a)) is well-kinded
         ; let cls_tyvars     = classTyVars cls
@@ -604,7 +625,7 @@ deriveTyData tvs tc tc_args (L loc deriv_pred)
         ; checkTc (not (isFamilyTyCon tc) || n_args_to_drop == 0)
                   (typeFamilyPapErr tc cls cls_tys inst_ty)
 
-        ; mkEqnHelp DerivOrigin (varSetElemsKvsFirst univ_tvs) cls cls_tys inst_ty Nothing }
+        ; mkEqnHelp DerivOrigin (varSetElemsKvsFirst univ_tvs) cls cls_tys inst_ty Nothing } }
 \end{code}
 
 Note [Deriving, type families, and partial applications]
@@ -657,7 +678,13 @@ mkEqnHelp orig tvs cls cls_tys tc_app mtheta
      bale_out msg = failWithTc (derivingThingErr False cls cls_tys tc_app msg)
 
      mk_alg_eqn tycon tc_args
-      | className cls `elem` typeableClassNames
+      | className cls `elem` oldTypeableClassNames
+      = do { dflags <- getDynFlags
+           ; case checkOldTypeableConditions (dflags, tycon, tc_args) of
+               Just err -> bale_out err
+               Nothing  -> mk_old_typeable_eqn orig tvs cls tycon tc_args mtheta }
+
+      | className cls == typeableClassName
       = do { dflags <- getDynFlags
            ; case checkTypeableConditions (dflags, tycon, tc_args) of
                Just err -> bale_out err
@@ -743,10 +770,10 @@ mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
     inst_tys = [mkTyConApp tycon tc_args]
 
 ----------------------
-mk_typeable_eqn :: CtOrigin -> [TyVar] -> Class
-                -> TyCon -> [TcType] -> DerivContext
-                -> TcM EarlyDerivSpec
-mk_typeable_eqn orig tvs cls tycon tc_args mtheta
+mk_old_typeable_eqn :: CtOrigin -> [TyVar] -> Class
+                    -> TyCon -> [TcType] -> DerivContext
+                    -> TcM EarlyDerivSpec
+mk_old_typeable_eqn orig tvs cls tycon tc_args mtheta
         -- The Typeable class is special in several ways
         --        data T a b = ... deriving( Typeable )
         -- gives
@@ -757,13 +784,13 @@ mk_typeable_eqn orig tvs cls tycon tc_args mtheta
         -- 3. The actual class we want to generate isn't necessarily
         --      Typeable; it depends on the arity of the type
   | isNothing mtheta    -- deriving on a data type decl
-  = do  { checkTc (cls `hasKey` typeableClassKey)
+  = do  { checkTc (cls `hasKey` oldTypeableClassKey)
                   (ptext (sLit "Use deriving( Typeable ) on a data type declaration"))
-        ; real_cls <- tcLookupClass (typeableClassNames `getNth` tyConArity tycon)
+        ; real_cls <- tcLookupClass (oldTypeableClassNames `getNth` tyConArity tycon)
                       -- See Note [Getting base classes]
-        ; mk_typeable_eqn orig tvs real_cls tycon [] (Just []) }
+        ; mk_old_typeable_eqn orig tvs real_cls tycon [] (Just []) }
 
-  | otherwise           -- standaone deriving
+  | otherwise           -- standalone deriving
   = do  { checkTc (null tc_args)
                   (ptext (sLit "Derived typeable instance must be of form (Typeable")
                         <> int (tyConArity tycon) <+> ppr tycon <> rparen)
@@ -775,6 +802,27 @@ mk_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
+                -> TyCon -> [TcType] -> DerivContext
+                -> TcM EarlyDerivSpec
+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 tycon [] (Just [])
+
+  | otherwise -- standalone deriving
+  = do  { checkTc (null tc_args)
+                  (ptext (sLit "Derived typeable instance must be of form (Typeable")
+                        <+> 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 = tyConKind tycon : [mkTyConApp tycon []]
+                     , ds_tc = tycon, ds_tc_args = []
+                     , ds_theta = mtheta `orElse` [], ds_newtype = False })  }
+
 ----------------------
 inferConstraints :: Class -> [TcType]
                  -> TyCon -> [TcType]
@@ -900,8 +948,9 @@ checkSideConditions dflags mtheta cls cls_tys rep_tc rep_tc_args
   where
     ty_args_why = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "is not a class")
 
-checkTypeableConditions :: Condition
-checkTypeableConditions = checkFlag Opt_DeriveDataTypeable `andCond` cond_typeableOK
+checkTypeableConditions, checkOldTypeableConditions :: Condition
+checkTypeableConditions    = checkFlag Opt_DeriveDataTypeable
+checkOldTypeableConditions = checkFlag Opt_DeriveDataTypeable `andCond` cond_oldTypeableOK
 
 nonStdErr :: Class -> SDoc
 nonStdErr cls = quotes (ppr cls) <+> ptext (sLit "is not a derivable class")
@@ -1030,11 +1079,11 @@ cond_isProduct (_, rep_tc, _)
     why = quotes (pprSourceTyCon rep_tc) <+>
           ptext (sLit "must have precisely one constructor")
 
-cond_typeableOK :: Condition
--- OK for Typeable class
+cond_oldTypeableOK :: Condition
+-- OK for kind-monomorphic Typeable class
 -- Currently: (a) args all of kind *
 --            (b) 7 or fewer args
-cond_typeableOK (_, tc, _)
+cond_oldTypeableOK (_, tc, _)
   | tyConArity tc > 7 = Just too_many
   | not (all (isSubOpenTypeKind . tyVarKind) (tyConTyVars tc))
                       = Just bad_kind
@@ -1120,10 +1169,11 @@ non_iso_class :: Class -> Bool
 -- even with -XGeneralizedNewtypeDeriving
 non_iso_class cls
   = classKey cls `elem` ([ readClassKey, showClassKey, dataClassKey
-                         , genClassKey, gen1ClassKey] ++ typeableClassKeys)
+                         , genClassKey, gen1ClassKey, typeableClassKey]
+                         ++ oldTypeableClassKeys)
 
-typeableClassKeys :: [Unique]
-typeableClassKeys = map getUnique typeableClassNames
+oldTypeableClassKeys :: [Unique]
+oldTypeableClassKeys = map getUnique oldTypeableClassNames
 
 new_dfun_name :: Class -> TyCon -> TcM Name
 new_dfun_name clas tycon        -- Just a simple wrapper
@@ -1681,7 +1731,11 @@ genDerivStuff :: SrcSpan -> FixityEnv -> Class -> Name -> TyCon
               -> Maybe CommonAuxiliary
               -> TcM (LHsBinds RdrName, BagDerivStuff)
 genDerivStuff loc fix_env clas name tycon comaux_maybe
-  | className clas `elem` typeableClassNames
+  | className clas `elem` oldTypeableClassNames
+  = do dflags <- getDynFlags
+       return (gen_old_Typeable_binds dflags loc tycon, emptyBag)
+
+  | className clas == typeableClassName
   = do dflags <- getDynFlags
        return (gen_Typeable_binds dflags loc tycon, emptyBag)
 
diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs
index 917f52392a..b45177e231 100644
--- a/compiler/typecheck/TcGenDeriv.lhs
+++ b/compiler/typecheck/TcGenDeriv.lhs
@@ -24,7 +24,7 @@ module TcGenDeriv (
         gen_Read_binds,
         gen_Show_binds,
         gen_Data_binds,
-        gen_Typeable_binds,
+        gen_old_Typeable_binds, gen_Typeable_binds,
         gen_Functor_binds,
         FFoldType(..), functorLikeTraverse,
         deepSubtypesContaining, foldDataConArgs,
@@ -1178,7 +1178,7 @@ getPrecedence get_fixity nm
 
 %************************************************************************
 %*                                                                      *
-\subsection{Typeable}
+\subsection{Typeable (old)}
 %*                                                                      *
 %************************************************************************
 
@@ -1195,13 +1195,13 @@ we generate
 We are passed the Typeable2 class as well as T
 
 \begin{code}
-gen_Typeable_binds :: DynFlags -> SrcSpan -> TyCon -> LHsBinds RdrName
-gen_Typeable_binds dflags loc tycon
+gen_old_Typeable_binds :: DynFlags -> SrcSpan -> TyCon -> LHsBinds RdrName
+gen_old_Typeable_binds dflags loc tycon
   = unitBag $
         mk_easy_FunBind loc
-                (mk_typeOf_RDR tycon)   -- Name of appropriate type0f function
+                (old_mk_typeOf_RDR tycon)   -- Name of appropriate type0f function
                 [nlWildPat]
-                (nlHsApps mkTyConApp_RDR [tycon_rep, nlList []])
+                (nlHsApps oldMkTyConApp_RDR [tycon_rep, nlList []])
   where
     tycon_name = tyConName tycon
     modl       = nameModule tycon_name
@@ -1211,7 +1211,7 @@ gen_Typeable_binds dflags loc tycon
     pkg_fs     = packageIdFS pkg
     name_fs    = occNameFS (nameOccName tycon_name)
 
-    tycon_rep = nlHsApps mkTyCon_RDR
+    tycon_rep = nlHsApps oldMkTyCon_RDR
                     (map nlHsLit [int64 high,
                                   int64 low,
                                   HsString pkg_fs,
@@ -1226,9 +1226,9 @@ gen_Typeable_binds dflags loc tycon
       | otherwise             = HsWordPrim . fromIntegral
 
 
-mk_typeOf_RDR :: TyCon -> RdrName
+old_mk_typeOf_RDR :: TyCon -> RdrName
 -- Use the arity of the TyCon to make the right typeOfn function
-mk_typeOf_RDR tycon = varQual_RDR tYPEABLE_INTERNAL (mkFastString ("typeOf" ++ suffix))
+old_mk_typeOf_RDR tycon = varQual_RDR oLDTYPEABLE_INTERNAL (mkFastString ("typeOf" ++ suffix))
                 where
                   arity = tyConArity tycon
                   suffix | arity == 0 = ""
@@ -1236,6 +1236,54 @@ mk_typeOf_RDR tycon = varQual_RDR tYPEABLE_INTERNAL (mkFastString ("typeOf" ++ s
 \end{code}
 
 
+%************************************************************************
+%*                                                                      *
+\subsection{Typeable (new)}
+%*                                                                      *
+%************************************************************************
+
+From the data type
+
+        data T a b = ....
+
+we generate
+
+        instance Typeable2 T where
+                typeOf2 _ = mkTyConApp (mkTyCon <hash-high> <hash-low>
+                                                <pkg> <module> "T") []
+
+We are passed the Typeable2 class as well as T
+
+\begin{code}
+gen_Typeable_binds :: DynFlags -> SrcSpan -> TyCon -> LHsBinds RdrName
+gen_Typeable_binds dflags loc tycon
+  = unitBag $ mk_easy_FunBind loc typeRep_RDR [nlWildPat]
+              (nlHsApps mkTyConApp_RDR [tycon_rep, nlList []])
+  where
+    tycon_name = tyConName tycon
+    modl       = nameModule tycon_name
+    pkg        = modulePackageId modl
+
+    modl_fs    = moduleNameFS (moduleName modl)
+    pkg_fs     = packageIdFS pkg
+    name_fs    = occNameFS (nameOccName tycon_name)
+
+    tycon_rep = nlHsApps mkTyCon_RDR
+                    (map nlHsLit [int64 high,
+                                  int64 low,
+                                  HsString pkg_fs,
+                                  HsString modl_fs,
+                                  HsString name_fs])
+
+    hashThis = unwords $ map unpackFS [pkg_fs, modl_fs, name_fs]
+    Fingerprint high low = fingerprintString hashThis
+
+    int64
+      | wORD_SIZE dflags == 4 = HsWord64Prim . fromIntegral
+      | otherwise             = HsWordPrim . fromIntegral
+\end{code}
+
+
 
 %************************************************************************
 %*                                                                      *
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 16a656e32d..09a62d0959 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -56,13 +56,14 @@ import VarSet     ( mkVarSet, subVarSet, varSetElems )
 import Pair
 import CoreUnfold ( mkDFunUnfolding )
 import CoreSyn    ( Expr(Var), CoreExpr )
-import PrelNames  ( typeableClassNames )
+import PrelNames  ( tYPEABLE_INTERNAL, typeableClassName, oldTypeableClassNames )
 
 import Bag
 import BasicTypes
 import DynFlags
 import ErrUtils
 import FastString
+import HscTypes ( isHsBoot )
 import Id
 import MkId
 import Name
@@ -382,13 +383,17 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
             -- round)
 
             -- Do class and family instance declarations
+       ; env <- getGblEnv
        ; stuff <- mapAndRecoverM tcLocalInstDecl inst_decls
        ; let (local_infos_s, fam_insts_s) = unzip stuff
-             local_infos = concat local_infos_s
-             fam_insts   = concat fam_insts_s
-       ; addClsInsts local_infos $
-         addFamInsts fam_insts   $ 
+             fam_insts    = concat fam_insts_s
+             local_infos' = concat local_infos_s
+             -- Handwritten instances of the poly-kinded Typeable class are
+             -- forbidden, so we handle those separately
+             (typeable_instances, local_infos) = splitTypeable env local_infos'
 
+       ; addClsInsts local_infos $
+         addFamInsts fam_insts   $
     do {    -- Compute instances from "deriving" clauses;
             -- This stuff computes a context for the derived instance
             -- decl, so it needs to know about all the instances possible
@@ -406,11 +411,14 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
                          ; return (gbl_env, emptyBag, emptyValBindsOut) }
                  else tcDeriving tycl_decls inst_decls deriv_decls
 
+       -- Remove any handwritten instance of poly-kinded Typeable and warn
+       ; dflags <- getDynFlags
+       ; when (wopt Opt_WarnTypeableInstances dflags) $
+              mapM_ (addWarnTc . instMsg) typeable_instances
 
        -- Check that if the module is compiled with -XSafe, there are no
-       -- hand written instances of Typeable as then unsafe casts could be
+       -- hand written instances of old Typeable as then unsafe casts could be
        -- performed. Derived instances are OK.
-       ; dflags <- getDynFlags
        ; when (safeLanguageOn dflags) $
              mapM_ (\x -> when (typInstCheck x)
                                (addErrAt (getSrcSpan $ iSpec x) typInstErr))
@@ -424,10 +432,27 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
                 , deriv_binds)
     }}
   where
-    typInstCheck ty = is_cls_nm (iSpec ty) `elem` typeableClassNames
+    -- Separate the Typeable instances from the rest
+    splitTypeable _   []     = ([],[])
+    splitTypeable env (i:is) =
+      let (typeableInsts, otherInsts) = splitTypeable env is
+      in if -- We will filter out instances of Typeable
+            (typeableClassName == is_cls_nm (iSpec i))
+            -- but not those that come from Data.Typeable.Internal
+            && tcg_mod env /= tYPEABLE_INTERNAL
+            -- nor those from an .hs-boot file (deriving can't be used there)
+            && not (isHsBoot (tcg_src env))
+         then (i:typeableInsts, otherInsts)
+         else (typeableInsts, i:otherInsts)
+
+    typInstCheck ty = is_cls_nm (iSpec ty) `elem` oldTypeableClassNames
     typInstErr = ptext $ sLit $ "Can't create hand written instances of Typeable in Safe"
                               ++ " Haskell! Can only derive them"
 
+    instMsg i = hang (ptext (sLit $ "Typeable instances can only be derived; ignoring "
+                                 ++ "the following instance:"))
+                     2 (pprInstance (iSpec i))
+
 addClsInsts :: [InstInfo Name] -> TcM a -> TcM a
 addClsInsts infos thing_inside
   = tcExtendLocalInstEnv (map iSpec infos) thing_inside