import TcMonad
import TcEnv ( tcSetInstEnv, newDFunName, InstInfo(..), pprInstInfo,
- tcLookupClass, tcLookupTyCon
+ tcLookupClass, tcLookupTyCon, tcExtendTyVarEnv
)
import TcGenDeriv -- Deriv stuff
import InstEnv ( InstEnv, simpleDFunClassTyCon, extendInstEnv )
import TcMonoType ( tcHsPred )
-import TcSimplify ( tcSimplifyThetas )
+import TcSimplify ( tcSimplifyDeriv )
import RnBinds ( rnMethodBinds, rnTopMonoBinds )
import RnEnv ( bindLocatedLocalsRn )
)
import TcType ( TcType, ThetaType, mkTyVarTys, mkTyConApp, getClassPredTys_maybe,
isUnLiftedType, mkClassPred, tyVarsOfTypes, tcSplitFunTys,
- tcSplitTyConApp_maybe )
+ tcSplitTyConApp_maybe, tcEqTypes, tyVarsOfTheta )
import Var ( TyVar, tyVarKind )
import VarSet ( mkVarSet, subVarSet )
import PrelNames
-import Util ( zipWithEqual, sortLt )
+import Util ( zipWithEqual, sortLt, eqListBy )
import ListSetOps ( removeDups, assoc )
import Outputable
import Maybe ( isJust )
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_`
mk_eqn (new_or_data, tycon_name, pred)
= tcLookupTyCon tycon_name `thenNF_Tc` \ tycon ->
tcAddSrcLoc (getSrcLoc tycon) $
- tcAddErrCtxt (derivCtxt tycon) $
+ tcAddErrCtxt (derivCtxt Nothing tycon) $
+ tcExtendTyVarEnv (tyConTyVars tycon) $ -- Deriving preds may (now) mention
+ -- the type variables for the type constructor
tcHsPred pred `thenTc` \ pred' ->
case getClassPredTys_maybe pred' of
Nothing -> bale_out (malformedPredErr tycon pred)
offensive_class = classKey clas `elem` needsDataDeclCtxtClassKeys
- mk_eqn_help NewType tycon clas []
- | clas `hasKey` readClassKey || clas `hasKey` showClassKey
- = mk_eqn_help DataType tycon clas [] -- Use the generate-full-code mechanism for Read and Show
-
mk_eqn_help NewType tycon clas tys
- = doptsTc Opt_GlasgowExts `thenTc` \ gla_exts ->
- if not gla_exts then -- Not glasgow-exts?
- mk_eqn_help DataType tycon clas tys -- revert to ordinary mechanism
- else if not can_derive then
- bale_out cant_derive_err
- else
- new_dfun_name clas tycon `thenNF_Tc` \ dfun_name ->
+ = doptsTc Opt_GlasgowExts `thenTc` \ gla_exts ->
+ if can_derive_via_isomorphism && (gla_exts || standard_instance) then
+ -- Go ahead and use the isomorphism
+ new_dfun_name clas tycon `thenNF_Tc` \ dfun_name ->
returnTc (Nothing, Just (NewTypeDerived (mk_dfun dfun_name)))
+ else
+ if standard_instance then
+ mk_eqn_help DataType tycon clas [] -- Go via bale-out route
+ else
+ bale_out cant_derive_err
where
-- Here is the plan for newtype derivings. We see
-- newtype T a1...an = T (t ak...an) deriving (C1...Cm)
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])
[ctxt_pred]
-- We can only do this newtype deriving thing if:
- can_derive = 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
+ standard_instance = null tys && classKey clas `elem` derivableClassKeys
+
+ can_derive_via_isomorphism
+ = not (clas `hasKey` readClassKey) -- Never derive Read,Show this way
+ && not (clas `hasKey` showClassKey)
+ && 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
+ && 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")
is_single_con = maybeToBool (maybeTyConSingleCon tycon)
is_enumeration_or_single = is_enumeration || is_single_con
- single_nullary_why = SLIT("one constructor data type or type with all nullary constructors expected")
- nullary_why = SLIT("data type with all nullary constructors expected")
- no_cons_why = SLIT("type has no data constructors")
- non_std_why = SLIT("not a derivable class")
- existential_why = SLIT("it has existentially-quantified constructor(s)")
+ single_nullary_why = SLIT("one constructor data type or type with all nullary constructors expected")
+ nullary_why = SLIT("data type with all nullary constructors expected")
+ no_cons_why = SLIT("type has no data constructors")
+ non_std_why = SLIT("not a derivable class")
+ existential_why = SLIT("it has existentially-quantified constructor(s)")
new_dfun_name clas tycon -- Just a simple wrapper
= newDFunName clas [mkTyConApp tycon []] (getSrcLoc tycon)
-- It fails if any iteration fails
iterateDeriv :: [DerivSoln] ->TcM [DFunId]
iterateDeriv current_solns
- = checkNoErrsTc (iterateOnce current_solns)
- `thenTc` \ (new_dfuns, new_solns) ->
+ = getDOptsTc `thenNF_Tc` \ dflags ->
+ let
+ dfuns = zipWithEqual "add_solns" mk_deriv_dfun orig_eqns current_solns
+ inst_env = extend_inst_env dflags inst_env_in dfuns
+ in
+ checkNoErrsTc (
+ -- Extend the inst info from the explicit instance decls
+ -- with the current set of solutions, and simplify each RHS
+ tcSetInstEnv inst_env $
+ mapTc gen_soln orig_eqns
+ ) `thenTc` \ new_solns ->
if (current_solns == new_solns) then
- returnTc new_dfuns
+ returnTc dfuns
else
iterateDeriv new_solns
------------------------------------------------------------------
- iterateOnce current_solns
- = -- 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
- in
- -- Simplify each RHS
- tcSetInstEnv inst_env (
- listTc [ tcAddSrcLoc (getSrcLoc tc) $
- tcAddErrCtxt (derivCtxt tc) $
- tcSimplifyThetas deriv_rhs
- | (_, _,tc,_,deriv_rhs) <- orig_eqns ]
- ) `thenTc` \ next_solns ->
-
- -- Canonicalise the solutions, so they compare nicely
- let canonicalised_next_solns = [ sortLt (<) next_soln | next_soln <- next_solns ]
- in
- returnTc (new_dfuns, canonicalised_next_solns)
+
+ gen_soln (_, clas, tc,tyvars,deriv_rhs)
+ = tcAddSrcLoc (getSrcLoc tc) $
+ tcAddErrCtxt (derivCtxt (Just clas) tc) $
+ tcSimplifyDeriv tyvars deriv_rhs `thenTc` \ theta ->
+ returnTc (sortLt (<) theta) -- Canonicalise before returning the soluction
\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}
%************************************************************************
malformedPredErr tycon pred = ptext SLIT("Illegal deriving item") <+> ppr pred
-derivCtxt tycon
- = ptext SLIT("When deriving classes for") <+> quotes (ppr tycon)
+derivCtxt :: Maybe Class -> TyCon -> SDoc
+derivCtxt maybe_cls tycon
+ = ptext SLIT("When deriving") <+> cls <+> ptext SLIT("for type") <+> quotes (ppr tycon)
+ where
+ cls = case maybe_cls of
+ Nothing -> ptext SLIT("instances")
+ Just c -> ptext SLIT("the") <+> quotes (ppr c) <+> ptext SLIT("instance")
\end{code}
projects / ghc-hetmet.git / blobdiff