From 37863eec8d97fc12d2ccb47d5eaf531ed0dff9ab Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Mon, 3 Nov 2003 15:26:23 +0000
Subject: [PATCH] [project @ 2003-11-03 15:26:22 by simonpj] The generic
to/from methods for derivable type classes should only be generated for types
in the current group, rather than all the in-scope tycons. Otherwise they
get generated multiple times in a Template-Haskell situation.
---
ghc/compiler/typecheck/TcDeriv.lhs | 14 ++++++++++----
ghc/compiler/types/Generics.lhs | 10 +++-------
2 files changed, 13 insertions(+), 11 deletions(-)
diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs
index 911da5cdf41..a9e1a83db97 100644
--- a/ghc/compiler/typecheck/TcDeriv.lhs
+++ b/ghc/compiler/typecheck/TcDeriv.lhs
@@ -16,7 +16,7 @@ import RdrHsSyn ( RdrNameMonoBinds )
import RnHsSyn ( RenamedHsBinds, RenamedTyClDecl, RenamedHsPred )
import CmdLineOpts ( DynFlag(..) )
-import Generics ( mkGenericBinds )
+import Generics ( mkTyConGenericBinds )
import TcRnMonad
import TcEnv ( newDFunName,
InstInfo(..), pprInstInfo, InstBindings(..),
@@ -43,7 +43,7 @@ import Name ( Name, getSrcLoc )
import NameSet ( NameSet, emptyNameSet, duDefs )
import Unique ( Unique, getUnique )
-import TyCon ( tyConTyVars, tyConDataCons, tyConArity,
+import TyCon ( tyConTyVars, tyConDataCons, tyConArity, tyConHasGenerics,
tyConTheta, isProductTyCon, isDataTyCon,
isEnumerationTyCon, isRecursiveTyCon, TyCon
)
@@ -211,8 +211,7 @@ tcDeriving tycl_decls
-- before tacking the "ordinary" ones
-- Generate the generic to/from functions from each type declaration
- ; tcg_env <- getGblEnv
- ; let gen_binds = mkGenericBinds (typeEnvTyCons (tcg_type_env tcg_env))
+ ; gen_binds <- mkGenericBinds tycl_decls
; let inst_info = newtype_inst_info ++ ordinary_inst_info
-- Rename these extra bindings, discarding warnings about unused bindings etc
@@ -254,6 +253,13 @@ deriveOrdinaryStuff eqns
-- Done
; returnM (inst_infos, andMonoBindList (extra_binds : aux_binds_s)) }
+
+-----------------------------------------
+mkGenericBinds tycl_decls
+ = do { tcs <- mapM tcLookupTyCon [tc_name | TyData { tcdName = tc_name } <- tycl_decls]
+ -- We are only interested in the data type declarations
+ ; return (andMonoBindList [mkTyConGenericBinds tc | tc <- tcs, tyConHasGenerics tc]) }
+ -- And then only in the ones whose 'has-generics' flag is on
\end{code}
diff --git a/ghc/compiler/types/Generics.lhs b/ghc/compiler/types/Generics.lhs
index a0297ad7eef..4ea84dc98a1 100644
--- a/ghc/compiler/types/Generics.lhs
+++ b/ghc/compiler/types/Generics.lhs
@@ -1,5 +1,5 @@
\begin{code}
-module Generics ( canDoGenerics, mkGenericBinds,
+module Generics ( canDoGenerics, mkTyConGenericBinds,
mkGenericRhs,
validGenericInstanceType, validGenericMethodType
) where
@@ -248,12 +248,8 @@ canDoGenerics data_cons
type US = Int -- Local unique supply, just a plain Int
type FromAlt = (Pat RdrName, HsExpr RdrName)
-mkGenericBinds :: [TyCon] -> MonoBinds RdrName
-mkGenericBinds tcs = andMonoBindList [ mkTyConGenBinds tc
- | tc <- tcs, tyConHasGenerics tc]
-
-mkTyConGenBinds :: TyCon -> MonoBinds RdrName
-mkTyConGenBinds tycon
+mkTyConGenericBinds :: TyCon -> MonoBinds RdrName
+mkTyConGenericBinds tycon
= FunMonoBind from_RDR False {- Not infix -}
[mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts]
loc
--
GitLab