import TyCon ( tyConTyVars, tyConDataCons, tyConArity, newTyConRep,
tyConTheta, maybeTyConSingleCon, isDataTyCon,
- isEnumerationTyCon, TyCon, isRecursiveTyCon
+ isEnumerationTyCon, TyCon
)
import TcType ( TcType, ThetaType, mkTyVarTys, mkTyConApp, getClassPredTys_maybe,
isUnLiftedType, mkClassPred, tyVarsOfTypes, tcSplitFunTys,
- tcSplitTyConApp_maybe )
+ tcSplitTyConApp_maybe, tcEqTypes )
import Var ( TyVar, tyVarKind )
import VarSet ( mkVarSet, subVarSet )
import PrelNames
tcDeriving prs mod inst_env get_fixity tycl_decls
= recoverTc (returnTc ([], EmptyBinds)) $
+ getDOptsTc `thenNF_Tc` \ dflags ->
-- Fish the "deriving"-related information out of the TcEnv
-- and make the necessary "equations".
- makeDerivEqns tycl_decls `thenTc` \ (ordinary_eqns, inst_info2) ->
-
- deriveOrdinaryStuff mod prs inst_env get_fixity
- ordinary_eqns `thenTc` \ (inst_info1, binds) ->
+ makeDerivEqns tycl_decls `thenTc` \ (ordinary_eqns, newtype_inst_info) ->
+ let
+ -- Add the newtype-derived instances to the inst env
+ -- before tacking the "ordinary" ones
+ inst_env1 = extend_inst_env dflags inst_env
+ (map iDFunId newtype_inst_info)
+ in
+ deriveOrdinaryStuff mod prs inst_env1 get_fixity
+ ordinary_eqns `thenTc` \ (ordinary_inst_info, binds) ->
let
- inst_info = inst_info2 ++ inst_info1 -- info2 usually empty
+ inst_info = newtype_inst_info ++ ordinary_inst_info
in
- getDOptsTc `thenNF_Tc` \ dflags ->
ioToTc (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
(ddump_deriving inst_info binds)) `thenTc_`
Just (rep_tc, rep_ty_args) = maybe_rep_app
n_tyvars_to_keep = tyConArity tycon - n_args_to_drop
- tyvars_to_keep = ASSERT( n_tyvars_to_keep >= 0 && n_tyvars_to_keep <= length tyvars )
- take n_tyvars_to_keep tyvars -- Kind checking should ensure this
+ tyvars_to_drop = drop n_tyvars_to_keep tyvars
+ tyvars_to_keep = take n_tyvars_to_keep tyvars
n_args_to_keep = tyConArity rep_tc - n_args_to_drop
- args_to_keep = ASSERT( n_args_to_keep >= 0 && n_args_to_keep <= length rep_ty_args )
- take n_args_to_keep rep_ty_args
+ args_to_drop = drop n_args_to_keep rep_ty_args
+ args_to_keep = take n_args_to_keep rep_ty_args
ctxt_pred = mkClassPred clas (tys ++ [mkTyConApp rep_tc args_to_keep])
can_derive_via_isomorphism
= not (clas `hasKey` readClassKey) -- Never derive Read,Show this way
&& not (clas `hasKey` showClassKey)
- && not (isRecursiveTyCon tycon) -- Newtype isn't recursive
+ && n_tyvars_to_keep >= 0 -- Well kinded;
+ -- eg not: newtype T = T Int deriving( Monad )
&& isJust maybe_rep_app -- The rep type is a type constructor app
- && (tyVarsOfTypes args_to_keep `subVarSet` mkVarSet tyvars_to_keep)
- -- and the tyvars are all in scope
+ && n_args_to_keep >= 0 -- Well kinded:
+ -- eg not: newtype T a = T Int deriving( Monad )
+ && eta_ok -- Eta reduction works
+
+ -- Check that eta reduction is OK
+ -- (a) the dropped-off args are identical
+ -- (b) the remaining type args mention
+ -- only the remaining type variables
+ eta_ok = (args_to_drop `tcEqTypes` mkTyVarTys tyvars_to_drop)
+ && (tyVarsOfTypes args_to_keep `subVarSet` mkVarSet tyvars_to_keep)
cant_derive_err = derivingThingErr clas tys tycon tyvars_to_keep
SLIT("too hard for cunning newtype deriving")
= -- Extend the inst info from the explicit instance decls
-- with the current set of solutions, giving a
getDOptsTc `thenNF_Tc` \ dflags ->
- let (new_dfuns, inst_env) =
- add_solns dflags inst_env_in orig_eqns current_solns
+ let
+ new_dfuns = zipWithEqual "add_solns" mk_deriv_dfun orig_eqns current_solns
+ inst_env = extend_inst_env dflags inst_env_in new_dfuns
+ -- the eqns and solns move "in lockstep"; we have the eqns
+ -- because we need the LHS info for addClassInstance.
in
-- Simplify each RHS
tcSetInstEnv inst_env (
\end{code}
\begin{code}
-add_solns :: DynFlags
- -> InstEnv -- The global, non-derived ones
- -> [DerivEqn] -> [DerivSoln]
- -> ([DFunId], InstEnv)
- -- the eqns and solns move "in lockstep"; we have the eqns
- -- because we need the LHS info for addClassInstance.
-
-add_solns dflags inst_env_in eqns solns
- = (new_dfuns, inst_env)
- where
- new_dfuns = zipWithEqual "add_solns" mk_deriv_dfun eqns solns
- (inst_env, _) = extendInstEnv dflags inst_env_in new_dfuns
+extend_inst_env dflags inst_env new_dfuns
+ = new_inst_env
+ where
+ (new_inst_env, _errs) = extendInstEnv dflags inst_env new_dfuns
-- Ignore the errors about duplicate instances.
-- We don't want repeated error messages
-- They'll appear later, when we do the top-level extendInstEnvs
- mk_deriv_dfun (dfun_name, clas, tycon, tyvars, _) theta
- = mkDictFunId dfun_name clas tyvars
- [mkTyConApp tycon (mkTyVarTys tyvars)]
- theta
+mk_deriv_dfun (dfun_name, clas, tycon, tyvars, _) theta
+ = mkDictFunId dfun_name clas tyvars
+ [mkTyConApp tycon (mkTyVarTys tyvars)]
+ theta
\end{code}
%************************************************************************
projects / ghc-hetmet.git / blobdiff