From: simonpj <unknown>
Date: Mon, 3 Nov 2003 15:26:23 +0000 (+0000)
Subject: [project @ 2003-11-03 15:26:22 by simonpj]
X-Git-Tag: Approx_11550_changesets_converted~286
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=37863eec8d97fc12d2ccb47d5eaf531ed0dff9ab

[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.
---

diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs
index 911da5c..a9e1a83 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 a0297ad..4ea84dc 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