X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcDeriv.lhs;h=3cfaaa944bfd9240c97656d8467e5a00c03b94fb;hb=94b1c019c4b397d8aad1e8cad8919a1208cceb0a;hp=a24f1473148c75d7dd643fccf9320dac9f3a7799;hpb=aa0c0de94e25aa64139688f8e4c4ba51ddca6f54;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index a24f147..3cfaaa9 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -296,7 +296,7 @@ tcDeriving tycl_decls inst_decls deriv_decls
 	; insts2 <- mapM (genInst False overlap_flag) final_specs
 
 		 -- Generate the generic to/from functions from each type declaration
-	; gen_binds <- mkGenericBinds is_boot
+	; gen_binds <- mkGenericBinds is_boot tycl_decls
 	; (inst_info, rn_binds, rn_dus) <- renameDeriv is_boot gen_binds (insts1 ++ insts2)
 
 	; dflags <- getDOpts
@@ -362,19 +362,19 @@ renameDeriv is_boot gen_binds insts
 	      ; let binds' = VanillaInst rn_binds [] standalone_deriv
 	      ; return (InstInfo { iSpec = inst, iBinds = binds' }, fvs) }
 	where
-	  (tyvars,_,clas,_) = instanceHead inst
-	  clas_nm  	    = className clas
+	  (tyvars,_, clas,_) = instanceHead inst
+	  clas_nm            = className clas
 
 -----------------------------------------
-mkGenericBinds :: Bool -> TcM (LHsBinds RdrName)
-mkGenericBinds is_boot
+mkGenericBinds :: Bool -> [LTyClDecl Name] -> TcM (LHsBinds RdrName)
+mkGenericBinds is_boot tycl_decls
   | is_boot 
   = return emptyBag
   | otherwise
-  = do	{ gbl_env <- getGblEnv
-	; let tcs = typeEnvTyCons (tcg_type_env gbl_env)
-	; return (unionManyBags [ mkTyConGenericBinds tc | 
-				  tc <- tcs, tyConHasGenerics tc ]) }
+  = do	{ tcs <- mapM tcLookupTyCon [ tcdName d 
+    	      	      		    | L _ d <- tycl_decls, isDataDecl d ]
+	; return (unionManyBags [ mkTyConGenericBinds tc
+				| tc <- tcs, tyConHasGenerics tc ]) }
 		-- We are only interested in the data type declarations,
 		-- and then only in the ones whose 'has-generics' flag is on
 		-- The predicate tyConHasGenerics finds both of these
@@ -1147,9 +1147,9 @@ mkNewTypeEqn orig dflags tvs
 					 
 	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 ]
+		  , ppUnless arity_ok arity_msg
+		  , ppUnless eta_ok eta_msg
+		  , ppUnless ats_ok 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")
@@ -1387,6 +1387,7 @@ genInst standalone_deriv oflag spec
 -- When dealing with the deriving clause
 --    co1 : N [(b,b)] ~ R1:N (b,b)
 --    co2 : R1:N (b,b) ~ Tree (b,b)
+--    co  : N [(b,b)] ~ Tree (b,b)
 
 genDerivBinds :: SrcSpan -> FixityEnv -> Class -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
 genDerivBinds loc fix_env clas tycon