--- Generate the method bindings for the required instance
--- (paired with DFunId, as we need that when renaming
--- the method binds)
-gen_bind :: DFunId -> TcM (DFunId, RdrNameMonoBinds)
-gen_bind dfun
- = getFixityEnv `thenM` \ fix_env ->
- let
- (clas, tycon) = simpleDFunClassTyCon dfun
- gen_binds_fn = assoc "gen_bind:bad derived class"
- gen_list (getUnique clas)
-
- gen_list = [(eqClassKey, gen_Eq_binds)
- ,(ordClassKey, gen_Ord_binds)
- ,(enumClassKey, gen_Enum_binds)
- ,(boundedClassKey, gen_Bounded_binds)
- ,(ixClassKey, gen_Ix_binds)
- ,(showClassKey, gen_Show_binds fix_env)
- ,(readClassKey, gen_Read_binds fix_env)
- ,(typeableClassKey,gen_Typeable_binds)
- ,(dataClassKey, gen_Data_binds)
- ]
- in
- returnM (dfun, gen_binds_fn tycon)
+-- Generate the InstInfo for the required instance,
+-- plus any auxiliary bindings required
+genInst :: Instance -> TcM (InstInfo, LHsBinds RdrName)
+genInst spec
+ = do { fix_env <- getFixityEnv
+ ; let
+ (tyvars,_,clas,[ty]) = instanceHead spec
+ clas_nm = className clas
+ tycon = tcTyConAppTyCon ty
+ (meth_binds, aux_binds) = genDerivBinds clas fix_env tycon
+
+ -- Bring the right type variables into
+ -- scope, and rename the method binds
+ -- It's a bit yukky that we return *renamed* InstInfo, but
+ -- *non-renamed* auxiliary bindings
+ ; (rn_meth_binds, _fvs) <- discardWarnings $
+ bindLocalNames (map varName tyvars) $
+ rnMethodBinds clas_nm [] meth_binds
+
+ -- Build the InstInfo
+ ; return (InstInfo { iSpec = spec,
+ iBinds = VanillaInst rn_meth_binds [] },
+ aux_binds)
+ }
+
+genDerivBinds clas fix_env tycon
+ | className clas `elem` typeableClassNames
+ = (gen_Typeable_binds tycon, emptyLHsBinds)
+
+ | otherwise
+ = case assocMaybe gen_list (getUnique clas) of
+ Just gen_fn -> gen_fn fix_env tycon
+ Nothing -> pprPanic "genDerivBinds: bad derived class" (ppr clas)
+ where
+ gen_list :: [(Unique, FixityEnv -> TyCon -> (LHsBinds RdrName, LHsBinds RdrName))]
+ gen_list = [(eqClassKey, no_aux_binds (ignore_fix_env gen_Eq_binds))
+ ,(ordClassKey, no_aux_binds (ignore_fix_env gen_Ord_binds))
+ ,(enumClassKey, no_aux_binds (ignore_fix_env gen_Enum_binds))
+ ,(boundedClassKey, no_aux_binds (ignore_fix_env gen_Bounded_binds))
+ ,(ixClassKey, no_aux_binds (ignore_fix_env gen_Ix_binds))
+ ,(typeableClassKey,no_aux_binds (ignore_fix_env gen_Typeable_binds))
+ ,(showClassKey, no_aux_binds gen_Show_binds)
+ ,(readClassKey, no_aux_binds gen_Read_binds)
+ ,(dataClassKey, gen_Data_binds)
+ ]
+
+ -- no_aux_binds is used for generators that don't
+ -- need to produce any auxiliary bindings
+ no_aux_binds f fix_env tc = (f fix_env tc, emptyLHsBinds)
+ ignore_fix_env f fix_env tc = f tc