import TcMonad
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 RnMonad4
import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) )
-import RnBinds4 ( rnMethodBinds, rnTopBinds )
+--import RnBinds4 ( rnMethodBinds, rnTopBinds )
-import Bag ( Bag, isEmptyBag, unionBags, listToBag )
+import Bag ( emptyBag{-ToDo:rm-}, Bag, isEmptyBag, unionBags, listToBag )
import Class ( GenClass, getClassKey )
-import ErrUtils ( pprBagOfErrors, addErrLoc, TcError(..) )
-import Id ( getDataConSig, getDataConArity )
+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 )
%************************************************************************
\begin{code}
-tcDeriving :: FAST_STRING -- name of module under scrutiny
+tcDeriving :: Module -- name of module under scrutiny
-> GlobalNameMappers -- for "renaming" bits of generated code
-> Bag InstInfo -- What we already know about instances
-> [RenamedFixityDecl] -- Fixity info; used by Read and Show
-- for debugging via -ddump-derivings.
tcDeriving modname renamer_name_funs inst_decl_infos_in fixities
+ = returnTc (trace "tcDeriving:ToDo" (emptyBag, EmptyBinds, \ x -> ppNil))
+{- LATER:
+
+tcDeriving modname renamer_name_funs 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
in
gen_tag_n_con_binds deriver_name_funs 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_name_funs) 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
)
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
where
clas_key = getClassKey clas
clas_Name
- = let (mod, nm) = getOrigName clas in
+ = let (mod, nm) = moduleNamePair clas in
ClassName clas_key (mkPreludeCoreName mod nm) []
\end{code}
\begin{code}
gen_tag_n_con_binds :: GlobalNameMappers
- -> [(ProtoName, Name, TyCon, TagThingWanted)]
+ -> [(RdrName, RnName, TyCon, TagThingWanted)]
-> TcM s RenamedHsBinds
gen_tag_n_con_binds deriver_name_funs nm_alist_etc
\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)
\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