\begin{code}
#include "HsVersions.h"
-module TcDeriv (
- tcDeriving
- ) where
+module TcDeriv ( tcDeriving ) where
import Ubiq
import RnHsSyn ( RenamedHsBinds(..), RenamedFixityDecl(..) )
import TcHsSyn ( TcIdOcc )
-import TcMonad
+import TcMonad hiding ( rnMtoTcM )
import Inst ( InstOrigin(..), InstanceMapper(..) )
import TcEnv ( getEnv_TyCons )
-import TcGenDeriv -- Deriv stuff
+import TcKind ( TcKind )
+--import TcGenDeriv -- Deriv stuff
import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs )
import TcSimplify ( tcSimplifyThetas )
-import RnMonad4
-import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) )
-import RnBinds4 ( rnMethodBinds, rnTopBinds )
+import RnMonad
+import RnUtils ( RnEnv(..) )
+import RnBinds ( rnMethodBinds, rnTopBinds )
-import Bag ( Bag, isEmptyBag, unionBags, listToBag )
-import Class ( GenClass, getClassKey )
-import ErrUtils ( pprBagOfErrors, addErrLoc, TcError(..) )
-import Id ( getDataConSig, getDataConArity )
+import Bag ( emptyBag{-ToDo:rm-}, Bag, isEmptyBag, unionBags, listToBag )
+import Class ( GenClass, classKey )
+import CmdLineOpts ( opt_CompilingPrelude )
+import ErrUtils ( pprBagOfErrors, addErrLoc, Error(..) )
+import Id ( dataConSig, dataConArity )
import Maybes ( assocMaybe, maybeToBool, Maybe(..) )
-import Name ( Name(..) )
-import NameTypes ( mkPreludeCoreName, Provenance(..) )
import Outputable
import PprType ( GenType, GenTyVar, GenClass, TyCon )
import PprStyle
import Pretty
-import ProtoName ( eqProtoName, ProtoName(..), Name )
import SrcLoc ( mkGeneratedSrcLoc, mkUnknownSrcLoc, SrcLoc )
-import TyCon ( getTyConTyVars, getTyConDataCons, getTyConDerivings,
+import TyCon ( tyConTyVars, tyConDataCons, tyConDerivings,
maybeTyConSingleCon, isEnumerationTyCon, TyCon )
-import Type ( GenType(..), TauType(..), mkTyVarTy, applyTyCon,
+import Type ( GenType(..), TauType(..), mkTyVarTys, applyTyCon,
mkSigmaTy, mkDictTy, isPrimType, instantiateTy,
getAppTyCon, getAppDataTyCon )
import TyVar ( GenTyVar )
-import UniqFM ( eltsUFM )
+import UniqFM ( emptyUFM )
import Unique -- Keys stuff
import Util ( zipWithEqual, zipEqual, sortLt, removeDups,
thenCmp, cmpList, panic, pprPanic, pprPanic# )
%************************************************************************
\begin{code}
-tcDeriving :: FAST_STRING -- name of module under scrutiny
- -> GlobalNameMappers -- for "renaming" bits of generated code
+tcDeriving :: Module -- name of module under scrutiny
+ -> RnEnv -- for "renaming" bits of generated code
-> Bag InstInfo -- What we already know about instances
-> [RenamedFixityDecl] -- Fixity info; used by Read and Show
-> TcM s (Bag InstInfo, -- The generated "instance decls".
PprStyle -> Pretty) -- Printable derived instance decls;
-- for debugging via -ddump-derivings.
-tcDeriving modname renamer_name_funs inst_decl_infos_in fixities
+tcDeriving modname rn_env inst_decl_infos_in fixities
+ = returnTc (trace "tcDeriving:ToDo" (emptyBag, EmptyBinds, \ x -> ppNil))
+{- LATER:
+
+tcDeriving modname rn_env inst_decl_infos_in fixities
= -- Fish the "deriving"-related information out of the TcEnv
-- and make the necessary "equations".
makeDerivEqns `thenTc` \ eqns ->
-- Take the equation list and solve it, to deliver a list of
-- solutions, a.k.a. the contexts for the instance decls
-- required for the corresponding equations.
- solveDerivEqns modname inst_decl_infos_in eqns
+ solveDerivEqns inst_decl_infos_in eqns
`thenTc` \ new_inst_infos ->
-- Now augment the InstInfos, adding in the rather boring
assoc_maybe ((k,v) : vs) key
= if k `eqProtoName` key then Just v else assoc_maybe vs key
in
- gen_tag_n_con_binds deriver_name_funs nm_alist_etc `thenTc` \ extra_binds ->
+ gen_tag_n_con_binds deriver_rn_env nm_alist_etc `thenTc` \ extra_binds ->
- mapTc (gen_inst_info modname fixities deriver_name_funs) new_inst_infos
+ mapTc (gen_inst_info maybe_mod fixities deriver_rn_env) new_inst_infos
`thenTc` \ really_new_inst_infos ->
returnTc (listToBag really_new_inst_infos,
extra_binds,
ddump_deriving really_new_inst_infos extra_binds)
where
+ maybe_mod = if opt_CompilingPrelude then Nothing else Just mod_name
+
ddump_deriving :: [InstInfo] -> RenamedHsBinds -> (PprStyle -> Pretty)
ddump_deriving inst_infos extra_binds sty
makeDerivEqns
= tcGetEnv `thenNF_Tc` \ env ->
let
- tycons = eltsUFM (getEnv_TyCons env)
+ tycons = getEnv_TyCons env
think_about_deriving = need_deriving tycons
in
mapTc (chk_out think_about_deriving) think_about_deriving `thenTc_`
need_deriving tycons_to_consider
= foldr ( \ tycon acc ->
- case (getTyConDerivings tycon) of
+ case (tyConDerivings tycon) of
[] -> acc
cs -> [ (clas,tycon) | clas <- cs ] ++ acc
)
chk_out :: [(Class, TyCon)] -> (Class, TyCon) -> TcM s ()
chk_out whole_deriving_list this_one@(clas, tycon)
= let
- clas_key = getClassKey clas
+ clas_key = classKey clas
in
-- Are things OK for deriving Enum (if appropriate)?
mk_eqn (clas, tycon)
= (clas, tycon, tyvars, constraints)
where
- tyvars = getTyConTyVars tycon -- ToDo: Do we need new tyvars ???
- tyvar_tys = map mkTyVarTy tyvars
- data_cons = getTyConDataCons tycon
+ tyvars = tyConTyVars tycon -- ToDo: Do we need new tyvars ???
+ tyvar_tys = mkTyVarTys tyvars
+ data_cons = tyConDataCons tycon
constraints = concat (map mk_constraints data_cons)
mk_constraints data_con
not (isPrimType arg_ty) -- No constraints for primitive types
]
where
- (con_tyvars, _, arg_tys, _) = getDataConSig data_con
+ (con_tyvars, _, arg_tys, _) = dataConSig data_con
inst_env = con_tyvars `zipEqual` tyvar_tys
-- same number of tyvars in data constr and type constr!
\end{code}
\end{itemize}
\begin{code}
-solveDerivEqns :: FAST_STRING
- -> Bag InstInfo
+solveDerivEqns :: Bag InstInfo
-> [DerivEqn]
-> TcM s [InstInfo] -- Solns in same order as eqns.
-- This bunch is Absolutely minimal...
-solveDerivEqns modname inst_decl_infos_in orig_eqns
+solveDerivEqns inst_decl_infos_in orig_eqns
= iterateDeriv initial_solutions
where
-- The initial solutions for the equations claim that each
= -- Extend the inst info from the explicit instance decls
-- with the current set of solutions, giving a
- add_solns modname inst_decl_infos_in orig_eqns current_solns
+ add_solns inst_decl_infos_in orig_eqns current_solns
`thenTc` \ (new_inst_infos, inst_mapper) ->
-- Simplify each RHS, using a DerivingOrigin containing an
-- the eqns and solns move "in lockstep"; we have the eqns
-- because we need the LHS info for addClassInstance.
-add_solns modname inst_infos_in eqns solns
+add_solns inst_infos_in eqns solns
= buildInstanceEnvs all_inst_infos `thenTc` \ inst_mapper ->
returnTc (new_inst_infos, inst_mapper)
where
all_inst_infos = inst_infos_in `unionBags` listToBag new_inst_infos
mk_deriv_inst_info (clas, tycon, tyvars, _) theta
- = InstInfo clas tyvars (applyTyCon tycon (map mkTyVarTy tyvars))
+ = InstInfo clas tyvars (applyTyCon tycon (mkTyVarTys tyvars))
theta
theta -- Blarg. This is the dfun_theta slot,
-- which is needed by buildInstanceEnv;
\end{itemize}
\begin{code}
-gen_inst_info :: FAST_STRING -- Module name
+gen_inst_info :: Maybe Module -- Module name; Nothing => Prelude
-> [RenamedFixityDecl] -- all known fixities;
-- may be needed for Text
- -> GlobalNameMappers -- lookup stuff for names we may use
+ -> RnEnv -- lookup stuff for names we may use
-> InstInfo -- the main stuff to work on
-> TcM s InstInfo -- the gen'd (filled-in) "instance decl"
-gen_inst_info modname fixities deriver_name_funs
+gen_inst_info modname fixities deriver_rn_env
info@(InstInfo clas tyvars ty inst_decl_theta _ _ _ _ _ _ locn _)
=
-- Generate the various instance-related Ids
| clas_key == binaryClassKey = gen_Binary_binds tycon
| otherwise = panic "gen_inst_info:bad derived class"
in
- rn4MtoTcM deriver_name_funs (
+ rnMtoTcM deriver_rn_env (
+ setExtraRn emptyUFM{-no fixities-} $
rnMethodBinds clas_Name proto_mbinds
) `thenNF_Tc` \ (mbinds, errs) ->
(if from_here then mbinds else EmptyMonoBinds)
from_here modname locn [])
where
- clas_key = getClassKey clas
+ clas_key = classKey clas
clas_Name
- = let (mod, nm) = getOrigName clas in
+ = let (mod, nm) = moduleNamePair clas in
ClassName clas_key (mkPreludeCoreName mod nm) []
\end{code}
maxtag_Foo :: Int -- ditto (NB: not unboxed)
\begin{code}
-gen_tag_n_con_binds :: GlobalNameMappers
- -> [(ProtoName, Name, TyCon, TagThingWanted)]
+gen_tag_n_con_binds :: RnEnv
+ -> [(RdrName, RnName, TyCon, TagThingWanted)]
-> TcM s RenamedHsBinds
-gen_tag_n_con_binds deriver_name_funs nm_alist_etc
+gen_tag_n_con_binds deriver_rn_env nm_alist_etc
= let
proto_mbind_list = map gen_tag_n_con_monobind nm_alist_etc
proto_mbinds = foldr AndMonoBinds EmptyMonoBinds proto_mbind_list
in
- rn4MtoTcM deriver_name_funs (
+ rnMtoTcM deriver_rn_env (
+ setExtraRn emptyUFM{-no fixities-} $
rnTopBinds (SingleBind (RecBind proto_mbinds))
) `thenNF_Tc` \ (binds, errs) ->
\begin{code}
gen_taggery_Names :: [DerivEqn]
- -> TcM s [(ProtoName, Name, -- for an assoc list
+ -> TcM s [(RdrName, RnName, -- for an assoc list
TyCon, -- related tycon
TagThingWanted)]
where
do_con2tag acc_Names tycon
= if (we_are_deriving eqClassKey tycon
- && any ( (== 0).getDataConArity ) (getTyConDataCons tycon))
+ && any ( (== 0).dataConArity ) (tyConDataCons tycon))
|| (we_are_deriving ordClassKey tycon
&& not (maybeToBool (maybeTyConSingleCon tycon)))
|| (we_are_deriving enumClassKey tycon)
where
is_in_eqns clas_key tycon [] = False
is_in_eqns clas_key tycon ((c,t,_,_):eqns)
- = (clas_key == getClassKey c && tycon == t)
+ = (clas_key == classKey c && tycon == t)
|| is_in_eqns clas_key tycon eqns
\end{code}
\begin{code}
-derivingEnumErr :: TyCon -> TcError
+derivingEnumErr :: TyCon -> Error
derivingEnumErr tycon
= addErrLoc (getSrcLoc tycon) "Can't derive an instance of `Enum'" ( \ sty ->
ppBesides [ppStr "type `", ppr sty tycon, ppStr "'"] )
-derivingIxErr :: TyCon -> TcError
+derivingIxErr :: TyCon -> Error
derivingIxErr tycon
= addErrLoc (getSrcLoc tycon) "Can't derive an instance of `Ix'" ( \ sty ->
ppBesides [ppStr "type `", ppr sty tycon, ppStr "'"] )
+-}
\end{code}
projects / ghc-hetmet.git / blobdiff