%
-% (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 Name ( isLocallyDefined, getSrcLoc,
+ Name, Module, NamedThing(..),
OccName, nameOccName
)
+import RdrName ( RdrName )
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 )
-> 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)) $
+ = 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
(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
+ = newDFunName cl_nm tycon_nm
Nothing mkGeneratedSrcLoc `thenRn` \ dfun_name ->
- rnMethodBinds meth_binds `thenRn` \ rn_meth_binds ->
+ rnMethodBinds meth_binds `thenRn` \ (rn_meth_binds, _) ->
returnRn (dfun_name, rn_meth_binds)
really_new_inst_infos = map (gen_inst_info modname)
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
-- (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 }
\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])
projects / ghc-hetmet.git / blobdiff