#include "HsVersions.h"
import HsSyn ( HsBinds(..), MonoBinds(..), collectMonoBinders )
-import RdrHsSyn ( RdrName, RdrNameMonoBinds )
+import RdrHsSyn ( RdrNameMonoBinds )
import RnHsSyn ( RenamedHsBinds, RenamedMonoBinds )
import CmdLineOpts ( opt_D_dump_deriv )
import DataCon ( dataConArgTys, isNullaryDataCon )
import PrelInfo ( needsDataDeclCtxtClassKeys )
import Maybes ( maybeToBool )
+import Module ( ModuleName )
import Name ( isLocallyDefined, getSrcLoc,
- Name, Module, NamedThing(..),
+ Name, NamedThing(..),
OccName, nameOccName
)
+import RdrName ( RdrName )
+import RnMonad ( Fixities )
import SrcLoc ( mkGeneratedSrcLoc, SrcLoc )
import TyCon ( tyConTyVars, tyConDataCons, tyConDerivings,
tyConTheta, maybeTyConSingleCon, isDataTyCon,
%************************************************************************
\begin{code}
-tcDeriving :: Module -- name of module under scrutiny
+tcDeriving :: ModuleName -- name of module under scrutiny
+ -> Fixities -- for the deriving code (Show/Read.)
-> RnNameSupply -- for "renaming" bits of generated code
-> Bag InstInfo -- What we already know about instances
-> TcM s (Bag InstInfo, -- The generated "instance decls".
RenamedHsBinds) -- Extra generated bindings
-tcDeriving modname rn_name_supply inst_decl_infos_in
+tcDeriving modname fixs rn_name_supply inst_decl_infos_in
= recoverTc (returnTc (emptyBag, EmptyBinds)) $
-- Fish the "deriving"-related information out of the TcEnv
let
extra_mbind_list = map gen_tag_n_con_monobind nm_alist_etc
extra_mbinds = foldr AndMonoBinds EmptyMonoBinds extra_mbind_list
- method_binds_s = map gen_bind new_inst_infos
+ method_binds_s = map (gen_bind fixs) new_inst_infos
mbinders = bagToList (collectMonoBinders extra_mbinds)
-- Rename to get RenamedBinds.
returnRn (dfun_names_w_method_binds, rn_extra_binds)
)
rn_one (cl_nm, tycon_nm, meth_binds)
- = newDFunName cl_nm tycon_nm
- Nothing mkGeneratedSrcLoc `thenRn` \ dfun_name ->
- rnMethodBinds meth_binds `thenRn` \ (rn_meth_binds, _) ->
+ = newDFunName (cl_nm, tycon_nm)
+ mkGeneratedSrcLoc `thenRn` \ dfun_name ->
+ rnMethodBinds meth_binds `thenRn` \ (rn_meth_binds, _) ->
returnRn (dfun_name, rn_meth_binds)
- really_new_inst_infos = map (gen_inst_info modname)
- (new_inst_infos `zip` dfun_names_w_method_binds)
+ really_new_inst_infos = zipWith gen_inst_info
+ new_inst_infos
+ dfun_names_w_method_binds
ddump_deriv = ddump_deriving really_new_inst_infos rn_extra_binds
in
-- Generate the method bindings for the required instance
-- (paired with class name, as we need that when generating dict
-- names.)
-gen_bind :: InstInfo -> ({-class-}OccName, {-tyCon-}OccName, RdrNameMonoBinds)
-gen_bind (InstInfo clas _ [ty] _ _ _ _ _)
+gen_bind :: Fixities -> InstInfo -> ({-class-}OccName, {-tyCon-}OccName, RdrNameMonoBinds)
+gen_bind fixities (InstInfo clas _ [ty] _ _ _ _ _)
| not from_here
= (clas_nm, tycon_nm, EmptyMonoBinds)
+ | ckey == showClassKey
+ = (clas_nm, tycon_nm, gen_Show_binds fixities tycon)
+ | ckey == readClassKey
+ = (clas_nm, tycon_nm, gen_Read_binds fixities tycon)
| otherwise
= (clas_nm, tycon_nm,
assoc "gen_bind:bad derived class"
,(ordClassKey, gen_Ord_binds)
,(enumClassKey, gen_Enum_binds)
,(boundedClassKey, gen_Bounded_binds)
- ,(showClassKey, gen_Show_binds)
- ,(readClassKey, gen_Read_binds)
,(ixClassKey, gen_Ix_binds)
]
- (classKey clas)
+ ckey
tycon)
where
clas_nm = nameOccName (getName clas)
tycon_nm = nameOccName (getName tycon)
from_here = isLocallyDefined tycon
(tycon,_,_) = splitAlgTyConApp ty
+ ckey = classKey clas
-gen_inst_info :: Module -- Module name
- -> (InstInfo, (Name, RenamedMonoBinds)) -- the main stuff to work on
+gen_inst_info :: InstInfo
+ -> (Name, RenamedMonoBinds)
-> InstInfo -- the gen'd (filled-in) "instance decl"
-gen_inst_info modname
- (InstInfo clas tyvars tys@(ty:_) inst_decl_theta _ _ locn _, (dfun_name, meth_binds))
+gen_inst_info (InstInfo clas tyvars tys@(ty:_) inst_decl_theta _ _ locn _)
+ (dfun_name, meth_binds)
=
-- Generate the various instance-related Ids
InstInfo clas tyvars tys inst_decl_theta
do_tag2con acc_Names tycon
| isDataTyCon tycon &&
(we_are_deriving enumClassKey tycon ||
- we_are_deriving ixClassKey tycon)
+ we_are_deriving ixClassKey tycon
+ && isEnumerationTyCon tycon)
= returnTc ( (tag2con_RDR tycon, tycon, GenTag2Con)
: (maxtag_RDR tycon, tycon, GenMaxTag)
: acc_Names)