; 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
; 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
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")
-- 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