[commit: ghc] master: Do not generate duplicate instances with AutoDeriveTypeable (2154b82)

[José Pedro Magalhães]

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

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/2154b82e97632abef64e73cc0f6c5cd13ab8e71c

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

commit 2154b82e97632abef64e73cc0f6c5cd13ab8e71c
Author: Jose Pedro Magalhaes <jpm at cs.ox.ac.uk>
Date:   Fri Mar 8 10:42:39 2013 +0000

    Do not generate duplicate instances with AutoDeriveTypeable

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

 compiler/typecheck/TcDeriv.lhs | 46 +++++++++++++++++++++++++-----------------
 1 file changed, 27 insertions(+), 19 deletions(-)

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index c52be42..1244aca 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -313,14 +313,7 @@ tcDeriving tycl_decls inst_decls deriv_decls
           is_boot <- tcIsHsBoot
         ; traceTc "tcDeriving" (ppr is_boot)
 
-        -- 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'
+        ; 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
@@ -376,12 +369,6 @@ 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, not (isSynDecl t), not (isTypeFamilyDecl t) ]
-
 -- Prints the representable type family instance
 pprRepTy :: FamInst Unbranched -> SDoc
 pprRepTy fi@(FamInst { fi_branches = FirstBranch (FamInstBranch { fib_lhs = lhs
@@ -492,17 +479,38 @@ makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
         ; eqns2 <- concatMapM (recoverM (return []) . deriveInstDecl) inst_decls
         ; eqns3 <- mapAndRecoverM deriveStandalone deriv_decls
         ; let eqns = eqns1 ++ eqns2 ++ eqns3
+
+        -- If AutoDeriveTypeable is set, we automatically add Typeable instances
+        -- for every data type and type class declared in the module
+        ; isAutoTypeable <- xoptM Opt_AutoDeriveTypeable
+        ; let eqns4 = if isAutoTypeable then deriveTypeable tycl_decls eqns else []
+        ; eqns4' <- mapAndRecoverM deriveStandalone eqns4
+        ; let eqns' = eqns ++ eqns4'
+
         ; if is_boot then   -- No 'deriving' at all in hs-boot files
-              do { unless (null eqns) (add_deriv_err (head eqns))
+              do { unless (null eqns') (add_deriv_err (head eqns'))
                  ; return [] }
-          else return eqns }
+          else return eqns' }
   where
+    deriveTypeable :: [LTyClDecl Name] -> [EarlyDerivSpec] -> [LDerivDecl Name]
+    deriveTypeable tys dss =
+      [ L l (DerivDecl (L l (HsAppTy (noLoc (HsTyVar typeableClassName))
+                                     (L l (HsTyVar (tcdName t))))))
+      | L l t <- tys
+        -- Don't add Typeable instances for type synonyms and type families
+      , not (isSynDecl t), not (isTypeFamilyDecl t)
+        -- ... nor if the user has already given a deriving clause
+      , not (hasInstance (tcdName t) dss) ]
+
+    -- Check if an automatically generated DS for deriving Typeable should be
+    -- ommitted because the user had manually requested for an instance
+    hasInstance :: Name -> [EarlyDerivSpec] -> Bool
+    hasInstance n = any (\ds -> n == tyConName (either ds_tc ds_tc ds))
+
     add_deriv_err eqn
-       = setSrcSpan loc $
+       = setSrcSpan (either ds_loc ds_loc eqn) $
          addErr (hang (ptext (sLit "Deriving not permitted in hs-boot file"))
                     2 (ptext (sLit "Use an instance declaration instead")))
-       where
-         loc = case eqn of  { Left ds -> ds_loc ds; Right ds -> ds_loc ds }
 
 ------------------------------------------------------------------
 deriveTyDecl :: LTyClDecl Name -> TcM [EarlyDerivSpec]