%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcDeriv]{Deriving}
#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 TcMonad
import Inst ( InstanceMapper )
-import TcEnv ( getEnv_TyCons, tcLookupClassByKey )
-import TcKind ( TcKind )
+import TcEnv ( getEnvTyCons )
import TcGenDeriv -- Deriv stuff
-import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs )
+import TcInstUtil ( InstInfo(..), buildInstanceEnvs )
import TcSimplify ( tcSimplifyThetas )
import RnBinds ( rnMethodBinds, rnTopMonoBinds )
-import RnEnv ( newDfunName, bindLocatedLocalsRn )
-import RnMonad ( RnM, RnDown, SDown, RnNameSupply,
+import RnEnv ( newDFunName, bindLocatedLocalsRn )
+import RnMonad ( RnNameSupply,
renameSourceCode, thenRn, mapRn, returnRn )
import Bag ( Bag, emptyBag, unionBags, listToBag )
import Class ( classKey, Class )
-import ErrUtils ( ErrMsg )
+import ErrUtils ( dumpIfSet, Message )
import MkId ( mkDictFunId )
-import Id ( dataConArgTys, isNullaryDataCon )
+import Id ( mkVanillaId )
+import DataCon ( dataConArgTys, isNullaryDataCon )
import PrelInfo ( needsDataDeclCtxtClassKeys )
import Maybes ( maybeToBool )
-import Name ( isLocallyDefined, getSrcLoc, Provenance,
- Name{--O only-}, Module, NamedThing(..),
+import Module ( ModuleName )
+import Name ( isLocallyDefined, getSrcLoc,
+ Name, NamedThing(..),
OccName, nameOccName
)
+import RdrName ( RdrName )
+import RnMonad ( Fixities )
import SrcLoc ( mkGeneratedSrcLoc, SrcLoc )
import TyCon ( tyConTyVars, tyConDataCons, tyConDerivings,
tyConTheta, maybeTyConSingleCon, isDataTyCon,
isEnumerationTyCon, isAlgTyCon, TyCon
)
-import Type ( GenType(..), TauType, mkTyVarTys, mkTyConApp,
+import Type ( TauType, mkTyVarTys, mkTyConApp,
mkSigmaTy, mkDictTy, isUnboxedType,
splitAlgTyConApp
)
-import TysPrim ( voidTy )
-import TyVar ( GenTyVar, TyVar )
+import TysWiredIn ( voidTy )
+import Var ( TyVar )
import Unique -- Keys stuff
import Bag ( bagToList )
import Util ( zipWithEqual, sortLt, removeDups, assoc, thenCmp )
%************************************************************************
\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
- SDoc) -- Printable derived instance decls;
- -- for debugging via -ddump-derivings.
+ RenamedHsBinds) -- Extra generated bindings
-tcDeriving modname rn_name_supply inst_decl_infos_in
- = recoverTc (returnTc (emptyBag, EmptyBinds, empty)) $
+tcDeriving modname fixs rn_name_supply inst_decl_infos_in
+ = recoverTc (returnTc (emptyBag, EmptyBinds)) $
-- Fish the "deriving"-related information out of the TcEnv
-- and make the necessary "equations".
makeDerivEqns `thenTc` \ eqns ->
if null eqns then
- returnTc (emptyBag, EmptyBinds, text "No derivings")
+ returnTc (emptyBag, EmptyBinds)
else
-- Take the equation list and solve it, to deliver a list of
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.
(dfun_names_w_method_binds, rn_extra_binds)
= renameSourceCode modname rn_name_supply (
bindLocatedLocalsRn (ptext (SLIT("deriving"))) mbinders $ \ _ ->
- rnTopMonoBinds extra_mbinds [] `thenRn` \ rn_extra_binds ->
+ rnTopMonoBinds extra_mbinds [] `thenRn` \ (rn_extra_binds, _) ->
mapRn rn_one method_binds_s `thenRn` \ dfun_names_w_method_binds ->
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
- --pprTrace "derived:\n" (ddump_deriv) $
+ ioToTc (dumpIfSet opt_D_dump_deriv "Derived instances" ddump_deriv) `thenTc_`
- returnTc (listToBag really_new_inst_infos,
- rn_extra_binds,
- ddump_deriv)
+ returnTc (listToBag really_new_inst_infos, rn_extra_binds)
where
ddump_deriving :: [InstInfo] -> RenamedHsBinds -> SDoc
-
ddump_deriving inst_infos extra_binds
- = vcat ((map pp_info inst_infos) ++ [ppr extra_binds])
+ = vcat (map pp_info inst_infos) $$ ppr extra_binds
where
- pp_info (InstInfo clas tvs [ty] inst_decl_theta _ _ mbinds _ _)
- = ($$) (ppr (mkSigmaTy tvs inst_decl_theta (mkDictTy clas [ty])))
- (ppr mbinds)
+ pp_info (InstInfo clas tvs [ty] inst_decl_theta _ mbinds _ _)
+ = ppr (mkSigmaTy tvs inst_decl_theta (mkDictTy clas [ty]))
+ $$
+ ppr mbinds
\end{code}
= tcGetEnv `thenNF_Tc` \ env ->
let
local_data_tycons = filter (\tc -> isLocallyDefined tc && isAlgTyCon tc)
- (getEnv_TyCons env)
- in
- if null local_data_tycons then
- -- Bale out now; evalClass may not be loaded if there aren't any
- returnTc []
- else
- tcLookupClassByKey evalClassKey `thenNF_Tc` \ eval_clas ->
- let
- think_about_deriving = need_deriving eval_clas local_data_tycons
+ (getEnvTyCons env)
+
+ think_about_deriving = need_deriving local_data_tycons
(derive_these, _) = removeDups cmp_deriv think_about_deriving
eqns = map mk_eqn derive_these
in
+ if null local_data_tycons then
+ returnTc [] -- Bale out now
+ else
mapTc chk_out think_about_deriving `thenTc_`
returnTc eqns
where
------------------------------------------------------------------
- need_deriving :: Class -> [TyCon] -> [(Class, TyCon)]
+ need_deriving :: [TyCon] -> [(Class, TyCon)]
-- find the tycons that have `deriving' clauses;
- -- we handle the "every datatype in Eval" by
- -- doing a dummy "deriving" for it.
-
- need_deriving eval_clas tycons_to_consider
- = foldr ( \ tycon acc ->
- let
- acc_plus = if isLocallyDefined tycon
- then (eval_clas, tycon) : acc
- else acc
- in
- case (tyConDerivings tycon) of
- [] -> acc_plus
- cs -> [ (clas,tycon) | clas <- cs ] ++ acc_plus
- )
+
+ need_deriving tycons_to_consider
+ = foldr (\ tycon acc -> [(clas,tycon) | clas <- tyConDerivings tycon] ++ acc)
[]
tycons_to_consider
-- to make the rest of the equation
mk_eqn (clas, tycon)
- = (clas, tycon, tyvars, if_not_Eval constraints)
+ = (clas, tycon, tyvars, constraints)
where
clas_key = classKey clas
tyvars = tyConTyVars tycon -- ToDo: Do we need new tyvars ???
tyvar_tys = mkTyVarTys tyvars
data_cons = tyConDataCons tycon
- if_not_Eval cs = if clas_key == evalClassKey then [] else cs
-
constraints = extra_constraints ++ concat (map mk_constraints data_cons)
-- "extra_constraints": see notes above about contexts on data decls
mk_deriv_inst_info (clas, tycon, tyvars, _) theta
= InstInfo clas tyvars [mkTyConApp tycon (mkTyVarTys tyvars)]
theta
- (my_panic "dfun_theta")
-
dummy_dfun_id
-
(my_panic "binds") (getSrcLoc tycon)
(my_panic "upragmas")
where
dummy_dfun_id
- = mkDictFunId (getName tycon) dummy_dfun_ty bottom bottom
+ = mkVanillaId (getName tycon) dummy_dfun_ty
-- The name is getSrcLoc'd in an error message
- where
- bottom = panic "dummy_dfun_id"
dummy_dfun_ty = mkSigmaTy tyvars theta voidTy
-- All we need from the dfun is its "theta" part, used during
-- 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"
[(eqClassKey, gen_Eq_binds)
,(ordClassKey, gen_Ord_binds)
,(enumClassKey, gen_Enum_binds)
- ,(evalClassKey, gen_Eval_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
- dfun_theta dfun_id
+ dfun_id
meth_binds
locn []
where
- (dfun_id, dfun_theta) = mkInstanceRelatedIds
- dfun_name
- clas tyvars tys
- inst_decl_theta
+ dfun_id = mkDictFunId dfun_name clas tyvars tys inst_decl_theta
from_here = isLocallyDefined tycon
(tycon,_,_) = splitAlgTyConApp ty
foldlTc do_con2tag [] tycons_of_interest `thenTc` \ names_so_far ->
foldlTc do_tag2con names_so_far tycons_of_interest
where
- all_CTs = [ (c, get_tycon ty) | (InstInfo c _ [ty] _ _ _ _ _ _) <- inst_infos ]
+ all_CTs = [ (c, get_tycon ty) | (InstInfo c _ [ty] _ _ _ _ _) <- inst_infos ]
get_tycon ty = case splitAlgTyConApp ty of { (tc, _, _) -> tc }
do_con2tag acc_Names tycon
| isDataTyCon tycon &&
- (we_are_deriving eqClassKey tycon
+ ((we_are_deriving eqClassKey tycon
&& any isNullaryDataCon (tyConDataCons tycon))
|| (we_are_deriving ordClassKey tycon
&& not (maybeToBool (maybeTyConSingleCon tycon)))
|| (we_are_deriving enumClassKey tycon)
- || (we_are_deriving ixClassKey tycon)
+ || (we_are_deriving ixClassKey tycon))
= returnTc ((con2tag_RDR tycon, tycon, GenCon2Tag)
: acc_Names)
= returnTc acc_Names
do_tag2con acc_Names tycon
- = if (we_are_deriving enumClassKey tycon)
- || (we_are_deriving ixClassKey tycon)
- then
- returnTc ( (tag2con_RDR tycon, tycon, GenTag2Con)
- : (maxtag_RDR tycon, tycon, GenMaxTag)
- : acc_Names)
- else
- returnTc acc_Names
+ | isDataTyCon tycon &&
+ (we_are_deriving enumClassKey tycon ||
+ we_are_deriving ixClassKey tycon
+ && isEnumerationTyCon tycon)
+ = returnTc ( (tag2con_RDR tycon, tycon, GenTag2Con)
+ : (maxtag_RDR tycon, tycon, GenMaxTag)
+ : acc_Names)
+ | otherwise
+ = returnTc acc_Names
we_are_deriving clas_key tycon
= is_in_eqns clas_key tycon all_CTs
\end{code}
\begin{code}
-derivingThingErr :: FAST_STRING -> FAST_STRING -> TyCon -> ErrMsg
+derivingThingErr :: FAST_STRING -> FAST_STRING -> TyCon -> Message
derivingThingErr thing why tycon
= hang (hsep [ptext SLIT("Can't make a derived instance of"), ptext thing])