-gen_inst_info :: Module -- Module name
- -> [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
- (InstInfo clas tyvars ty inst_decl_theta _ _ _ _ _ _ locn _)
- =
- -- Generate the various instance-related Ids
- mkInstanceRelatedIds
- True {-from_here-} locn 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,_,_) = --pprTrace "gen_inst_info:ty" (ppCat[ppr PprDebug clas, ppr PprDebug ty]) $
- getAppDataTyCon ty
-
- proto_mbinds
- = assoc "gen_inst_info:bad derived class"
- [(eqClassKey, gen_Eq_binds)
- ,(ordClassKey, gen_Ord_binds)
- ,(enumClassKey, gen_Enum_binds)
- ,(evalClassKey, gen_Eval_binds)
- ,(boundedClassKey, gen_Bounded_binds)
- ,(showClassKey, gen_Show_binds fixities)
- ,(readClassKey, gen_Read_binds fixities)
- ,(ixClassKey, gen_Ix_binds)
- ]
- clas_key $ tycon
- in
-{-
- let
- ((qual, unqual, tc_qual, tc_unqual), stack) = deriver_rn_env
- in
- pprTrace "gen_inst:qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM qual]) $
- pprTrace "gen_inst:unqual:" (ppCat (map ppPStr (keysFM unqual))) $
- pprTrace "gen_inst:tc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $
- pprTrace "gen_inst:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $
--}
- -- pprTrace "derived binds:" (ppr PprDebug proto_mbinds) $
-
- 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
- -- 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