[commit: ghc] master: Fix #5863 (6806906)

[José Pedro Magalhães]

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

On branch  : master

https://github.com/ghc/ghc/commit/6806906d41581c42805e2f09cc6fda9035a288ef

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

commit 6806906d41581c42805e2f09cc6fda9035a288ef
Author: Jose Pedro Magalhaes <jpm at cs.ox.ac.uk>
Date:   Tue May 21 14:55:36 2013 +0100

    Fix #5863

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

 compiler/typecheck/TcDeriv.lhs    | 32 ++++++++++++++++++++++++--------
 docs/users_guide/glasgow_exts.xml |  3 +++
 2 files changed, 27 insertions(+), 8 deletions(-)

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index d7cb08d..786d93e 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -606,9 +606,13 @@ deriveTyData tvs tc tc_args (L loc deriv_pred)
 
                 -- Typeable is special
         ; if className cls == typeableClassName
-          then mkEqnHelp DerivOrigin
-                  tvs cls cls_tys
-                  (mkTyConApp tc (kindVarsOnly tc_args)) Nothing
+          then do {
+        ; dflags <- getDynFlags
+        ; case checkTypeableConditions (dflags, tc, tc_args) of
+               Just err -> failWithTc (derivingThingErr False cls cls_tys
+                                         (mkTyConApp tc tc_args) err)
+               Nothing  -> mkEqnHelp DerivOrigin tvs cls cls_tys
+                             (mkTyConApp tc (kindVarsOnly tc_args)) Nothing }
           else do {
 
         -- Given data T a b c = ... deriving( C d ),
@@ -715,10 +719,8 @@ mkEqnHelp orig tvs cls cls_tys tc_app 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  -> mkPolyKindedTypeableEqn orig tvs cls cls_tys tycon tc_args mtheta }
+      -- We checked for errors before, so we don't need to do that again
+      = mkPolyKindedTypeableEqn orig tvs cls cls_tys tycon tc_args mtheta
 
       | isDataFamilyTyCon tycon
       , length tc_args /= tyConArity tycon
@@ -985,7 +987,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
+checkTypeableConditions    = checkFlag Opt_DeriveDataTypeable `andCond` cond_TypeableOK
 checkOldTypeableConditions = checkFlag Opt_DeriveDataTypeable `andCond` cond_oldTypeableOK
 
 nonStdErr :: Class -> SDoc
@@ -1130,6 +1132,20 @@ cond_oldTypeableOK (_, tc, _)
     bad_kind = quotes (pprSourceTyCon tc) <+>
                ptext (sLit "must only have arguments of kind `*'")
 
+cond_TypeableOK :: Condition
+-- Only not ok if it's a data instance
+cond_TypeableOK (_, tc, tc_args)
+  | isDataFamilyTyCon tc && not (null tc_args)
+  = Just no_families
+
+  | otherwise
+  = Nothing
+  where
+    no_families = sep [ ptext (sLit "Deriving Typeable is not allowed for family instances;")
+                      , ptext (sLit "derive Typeable for")
+                          <+> quotes (pprSourceTyCon tc)
+                          <+> ptext (sLit "alone") ]
+
 functorLikeClassKeys :: [Unique]
 functorLikeClassKeys = [functorClassKey, foldableClassKey, traversableClassKey]
 
diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml
index 47c8ab0..d9ad6a5 100644
--- a/docs/users_guide/glasgow_exts.xml
+++ b/docs/users_guide/glasgow_exts.xml
@@ -3377,6 +3377,9 @@ type class. Instances for datatypes can be derived by attaching a
 <literal>deriving Typeable</literal> clause to the datatype declaration, or by
 using standalone deriving (see <xref linkend="stand-alone-deriving"/>).
 Instances for type classes can only be derived using standalone deriving.
+For data families, <literal>Typeable</literal> should only be derived for the
+uninstantiated family type; each instance will then automatically have a
+<literal>Typeable</literal> instance too.
 See also <xref linkend="auto-derive-typeable"/>.
 </para>
 <para>