%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcDeriv]{Deriving}
import TcMonad
import Inst ( InstanceMapper )
-import TcEnv ( getEnv_TyCons, tcLookupClassByKey )
-import TcKind ( TcKind )
+import TcEnv ( getEnv_TyCons )
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 RnMonad ( RnNameSupply,
renameSourceCode, thenRn, mapRn, returnRn )
import Bag ( Bag, emptyBag, unionBags, listToBag )
import Class ( classKey, Class )
import ErrUtils ( ErrMsg )
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 Name ( isLocallyDefined, getSrcLoc,
+ Name, Module, NamedThing(..),
OccName, nameOccName
)
import SrcLoc ( mkGeneratedSrcLoc, SrcLoc )
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 )
ddump_deriving inst_infos extra_binds
= vcat ((map pp_info inst_infos) ++ [ppr extra_binds])
where
- pp_info (InstInfo clas tvs [ty] inst_decl_theta _ _ mbinds _ _)
+ pp_info (InstInfo clas tvs [ty] inst_decl_theta _ mbinds _ _)
= ($$) (ppr (mkSigmaTy tvs inst_decl_theta (mkDictTy clas [ty])))
(ppr mbinds)
\end{code}
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
+
+ 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
-- (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 (InstInfo clas _ [ty] _ _ _ _ _)
| not from_here
= (clas_nm, tycon_nm, EmptyMonoBinds)
| otherwise
[(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)
-> 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))
+ (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)
+ = 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