-gen_inst_info :: Maybe Module -- Module name; Nothing => Prelude
- -> [RenamedFixityDecl] -- all known fixities;
- -- may be needed for Text
- -> GlobalNameMappers -- lookup stuff for names we may use
- -> InstInfo -- the main stuff to work on
- -> TcM s InstInfo -- the gen'd (filled-in) "instance decl"
-
-gen_inst_info modname fixities deriver_name_funs
- info@(InstInfo clas tyvars ty inst_decl_theta _ _ _ _ _ _ locn _)
- =
- -- Generate the various instance-related Ids
- mkInstanceRelatedIds
- True {-from_here-} modname
- NoInstancePragmas
- clas tyvars ty
- inst_decl_theta
- [{-no user pragmas-}]
- `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) ->
-
- -- Generate the bindings for the new instance declaration,
- -- rename it, and check for errors
- let
- (tycon,_,_) = getAppDataTyCon ty
-
- proto_mbinds
- | clas_key == eqClassKey = gen_Eq_binds tycon
- | clas_key == showClassKey = gen_Show_binds fixities tycon
- | clas_key == ordClassKey = gen_Ord_binds tycon
- | clas_key == enumClassKey = gen_Enum_binds tycon
- | clas_key == ixClassKey = gen_Ix_binds tycon
- | clas_key == readClassKey = gen_Read_binds fixities tycon
- | clas_key == binaryClassKey = gen_Binary_binds tycon
- | otherwise = panic "gen_inst_info:bad derived class"
- in
- rn4MtoTcM deriver_name_funs (
- rnMethodBinds clas_Name proto_mbinds
- ) `thenNF_Tc` \ (mbinds, errs) ->
+-- Generate the method bindings for the required instance
+-- (paired with class name, as we need that when generating dict
+-- names.)
+gen_bind :: FixityEnv -> InstInfo -> ({-class-}OccName, {-tyCon-}OccName, RdrNameMonoBinds)
+gen_bind fixities (InstInfo clas _ [ty] _ _ _ _ _)
+ | not from_here
+ = (clas_nm, tycon_nm, EmptyMonoBinds)
+ | clas `hasKey` showClassKey
+ = (clas_nm, tycon_nm, gen_Show_binds fixities tycon)
+ | clas `hasKey` readClassKey
+ = (clas_nm, tycon_nm, gen_Read_binds fixities tycon)
+ | otherwise
+ = (clas_nm, tycon_nm,
+ assoc "gen_bind:bad derived class"
+ [(eqClassKey, gen_Eq_binds)
+ ,(ordClassKey, gen_Ord_binds)
+ ,(enumClassKey, gen_Enum_binds)
+ ,(boundedClassKey, gen_Bounded_binds)
+ ,(ixClassKey, gen_Ix_binds)
+ ]
+ (classKey clas)
+ tycon)
+ where
+ clas_nm = nameOccName (getName clas)
+ tycon_nm = nameOccName (getName tycon)
+ from_here = isLocallyDefined tycon
+ (tycon,_,_) = splitAlgTyConApp ty