Fix Trac #2721: reject newtype deriving if the class has associated types

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 1a21240..eac2209 100644 (file)
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -1000,19 +1000,21 @@ mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving tvs
        -------------------------------------------------------------------
        --  Figuring out whether we can only do this newtype-deriving thing
 
-       right_arity = length cls_tys + 1 == classArity cls
-
-               -- Never derive Read,Show,Typeable,Data this way 
-       non_iso_class cls = className cls `elem` ([readClassName, showClassName, dataClassName] ++
-                                                 typeableClassNames)
        can_derive_via_isomorphism
           =  not (non_iso_class cls)
-          && right_arity                       -- Well kinded;
-                                               -- eg not: newtype T ... deriving( ST )
-                                               --      because ST needs *2* type params
-          && eta_ok                            -- Eta reduction works
+          && arity_ok
+          && eta_ok
+          && ats_ok
 --        && not (isRecursiveTyCon tycon)      -- Note [Recursive newtypes]
 
+               -- Never derive Read,Show,Typeable,Data by isomorphism
+       non_iso_class cls = className cls `elem` ([readClassName, showClassName, dataClassName] ++
+                                                 typeableClassNames)
+
+       arity_ok = length cls_tys + 1 == classArity cls
+               -- Well kinded; eg not: newtype T ... deriving( ST )
+               --                      because ST needs *2* type params
+
        -- Check that eta reduction is OK
        eta_ok = nt_eta_arity <= length rep_tc_args
                -- The newtype can be eta-reduced to match the number
@@ -1022,17 +1024,19 @@ mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving tvs
                --     And the [a] must not mention 'b'.  That's all handled
                --     by nt_eta_rity.
 
-       cant_derive_err = vcat [ptext (sLit "even with cunning newtype deriving:"),
-                               if isRecursiveTyCon tycon then
-                                 ptext (sLit "the newtype may be recursive")
-                               else empty,
-                               if not right_arity then 
-                                 quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "does not have arity 1")
-                               else empty,
-                               if not eta_ok then 
-                                 ptext (sLit "cannot eta-reduce the representation type enough")
-                               else empty
-                               ]
+       ats_ok = null (classATs cls)    
+              -- No associated types for the class, because we don't 
+              -- currently generate type 'instance' decls; and cannot do
+              -- so for 'data' instance decls
+                                        
+       cant_derive_err
+          = vcat [ ptext (sLit "even with cunning newtype deriving:")
+                 , if arity_ok then empty else arity_msg
+                 , if eta_ok then empty else eta_msg
+                 , if ats_ok then empty else ats_msg ]
+        arity_msg = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "does not have arity 1")
+       eta_msg   = ptext (sLit "cannot eta-reduce the representation type enough")
+       ats_msg   = ptext (sLit "the class has associated types")
 \end{code}
 
 Note [Recursive newtypes]