[commit: ghc] fix#7704: Fix deriving of new polykinded Typeable (on fix#7702 branch) (c3ce497)

[Simon Peyton Jones]

Repository : http://darcs.haskell.org/ghc.git/

On branch  : fix#7704

http://hackage.haskell.org/trac/ghc/changeset/c3ce4975746e5a323292487bbdc67153533531d3

>---------------------------------------------------------------

commit c3ce4975746e5a323292487bbdc67153533531d3
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Mon Mar 4 22:30:06 2013 +0000

    Fix deriving of new polykinded Typeable (on fix#7702 branch)

>---------------------------------------------------------------

 compiler/typecheck/TcDeriv.lhs | 33 +++++++++++++++++----------------
 1 file changed, 17 insertions(+), 16 deletions(-)

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 0968a8a..ce4e995 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -321,6 +321,7 @@ tcDeriving tycl_decls inst_decls deriv_decls
                                               else []
 
         ; early_specs <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls'
+        ; traceTc "tcDeriving 1" (ppr early_specs)
 
         -- for each type, determine the auxliary declarations that are common
         -- to multiple derivations involving that type (e.g. Generic and
@@ -683,13 +684,13 @@ mkEqnHelp orig tvs cls cls_tys tc_app mtheta
       = 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 }
+               Nothing  -> mkOldTypeableEqn 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
-               Nothing  -> mk_typeable_eqn orig tvs cls tycon tc_args mtheta }
+               Nothing  -> mkPolyKindedTypeableEqn orig tvs cls cls_tys tycon tc_args mtheta }
 
       | isDataFamilyTyCon tycon
       , length tc_args /= tyConArity tycon
@@ -771,10 +772,12 @@ mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
     inst_tys = [mkTyConApp tycon tc_args]
 
 ----------------------
-mk_old_typeable_eqn :: CtOrigin -> [TyVar] -> Class
+mkOldTypeableEqn :: CtOrigin -> [TyVar] -> Class
                     -> TyCon -> [TcType] -> DerivContext
                     -> TcM EarlyDerivSpec
-mk_old_typeable_eqn orig tvs cls tycon tc_args mtheta
+-- The "old" (pre GHC 7.8 polykinded Typeable) deriving Typeable
+-- used a horrid family of classes: Typeable, Typeable1, Typeable2, ... Typeable7
+mkOldTypeableEqn orig tvs cls tycon tc_args mtheta
         -- The Typeable class is special in several ways
         --        data T a b = ... deriving( Typeable )
         -- gives
@@ -789,7 +792,7 @@ mk_old_typeable_eqn orig tvs cls tycon tc_args mtheta
                   (ptext (sLit "Use deriving( Typeable ) on a data type declaration"))
         ; real_cls <- tcLookupClass (oldTypeableClassNames `getNth` tyConArity tycon)
                       -- See Note [Getting base classes]
-        ; mk_old_typeable_eqn orig tvs real_cls tycon [] (Just []) }
+        ; mkOldTypeableEqn orig tvs real_cls tycon [] (Just []) }
 
   | otherwise           -- standalone deriving
   = do  { checkTc (null tc_args)
@@ -803,16 +806,12 @@ 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
-                -> TyCon -> [TcType] -> DerivContext
-                -> TcM EarlyDerivSpec
-mk_typeable_eqn orig tvs cls tycon tc_args mtheta
+mkPolyKindedTypeableEqn :: CtOrigin -> [TyVar] -> Class -> [TcType]
+                        -> TyCon -> [TcType] -> DerivContext
+                        -> TcM EarlyDerivSpec
+mkPolyKindedTypeableEqn orig tvs cls cls_tys 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  { pprTrace "tvs, tycon, tc_args" (ppr (tvs, tycon, tc_args))
         $ checkTc (onlyKindVars tc_args)
                   (ptext (sLit "Derived typeable instance must be of form (Typeable")
@@ -820,10 +819,12 @@ mk_typeable_eqn orig tvs cls tycon tc_args mtheta
         ; dfun_name <- new_dfun_name cls tycon
         ; loc <- getSrcSpanM
         ; return (Right $
-                  DS { ds_loc = loc, ds_orig = orig, ds_name = dfun_name, ds_tvs = tvs
-                     , ds_cls = cls, ds_tys = tyConKind tycon : [mkTyConApp tycon tc_args]
+                  DS { ds_loc = loc, ds_orig = orig, ds_name = dfun_name
+                     , ds_tvs = tvs, ds_cls = cls
+                     , ds_tys = cls_tys ++ [mkTyConApp tycon tc_args]
                      , ds_tc = tycon, ds_tc_args = tc_args
-                     , ds_theta = mtheta `orElse` [], ds_newtype = False })  }
+                     , ds_theta = mtheta `orElse` []  -- Context is empty for polykinded Typeable
+                     , ds_newtype = False })  }
   where onlyKindVars     = and . map (isJKVar . tcGetTyVar_maybe)
         isJKVar (Just v) = isKindVar v
         isJKVar _        = False