-gen_inst_info :: Maybe Module -- Module name; Nothing => Prelude
- -> [RenamedFixityDecl] -- all known fixities;
- -- may be needed for Text
- -> RnEnv -- 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_rn_env
- 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
- rnMtoTcM deriver_rn_env (
- setExtraRn emptyUFM{-no fixities-} $
- rnMethodBinds clas_Name proto_mbinds
- ) `thenNF_Tc` \ (mbinds, errs) ->
-
- if not (isEmptyBag errs) then
- pprPanic "gen_inst_info:renamer errs!\n"
- (ppAbove (pprBagOfErrors PprDebug errs) (ppr PprDebug proto_mbinds))
- else
- --pprTrace "derived binds:" (ppr PprDebug proto_mbinds) $
-
- -- All done
- let
- from_here = isLocallyDefined tycon -- If so, then from here
- in
- returnTc (InstInfo clas tyvars ty inst_decl_theta
- dfun_theta dfun_id const_meth_ids
- (if from_here then mbinds else EmptyMonoBinds)
- from_here modname locn [])
+-- Generate the method bindings for the required instance
+-- (paired with class name, as we need that when generating dict
+-- names.)
+gen_bind :: (Name -> Maybe Fixity) -> DFunId -> RdrNameMonoBinds
+gen_bind get_fixity dfun
+ | clas `hasKey` showClassKey = gen_Show_binds get_fixity tycon
+ | clas `hasKey` readClassKey = gen_Read_binds get_fixity tycon
+ | otherwise
+ = 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