import Generics ( mkTyConGenericBinds )
import TcRnMonad
+import TcMType ( checkValidInstance )
import TcEnv ( newDFunName, pprInstInfoDetails,
InstInfo(..), InstBindings(..), simpleInstInfoClsTy,
tcLookupClass, tcLookupTyCon, tcExtendTyVarEnv
import HscTypes ( FixityEnv )
import Class ( className, classArity, classKey, classTyVars, classSCTheta, Class )
-import Type ( zipOpenTvSubst, substTheta )
+import Type ( zipOpenTvSubst, substTheta, pprThetaArrow, pprClassPred )
import ErrUtils ( dumpIfSet_dyn )
import MkId ( mkDictFunId )
import DataCon ( isNullarySrcDataCon, isVanillaDataCon, dataConOrigArgTys )
isEnumerationTyCon, isRecursiveTyCon, TyCon
)
import TcType ( TcType, ThetaType, mkTyVarTys, mkTyConApp, tcTyConAppTyCon,
- isUnLiftedType, mkClassPred, tyVarsOfTypes, isArgTypeKind,
- tcEqTypes, tcSplitAppTys, mkAppTys )
+ isUnLiftedType, mkClassPred, tyVarsOfType,
+ isArgTypeKind, tcEqTypes, tcSplitAppTys, mkAppTys )
import Var ( TyVar, tyVarKind, varName )
import VarSet ( mkVarSet, subVarSet )
import PrelNames
mk_eqn (new_or_data, tycon_name, hs_deriv_ty)
= tcLookupTyCon tycon_name `thenM` \ tycon ->
setSrcSpan (srcLocSpan (getSrcLoc tycon)) $
- addErrCtxt (derivCtxt Nothing tycon) $
+ addErrCtxt (derivCtxt tycon) $
tcExtendTyVarEnv (tyConTyVars tycon) $ -- Deriving preds may (now) mention
-- the type variables for the type constructor
tcHsDeriv hs_deriv_ty `thenM` \ (deriv_tvs, clas, tys) ->
args_to_drop = drop n_args_to_keep rep_ty_args
args_to_keep = take n_args_to_keep rep_ty_args
- rep_tys = tys ++ [mkAppTys rep_fn args_to_keep]
+ rep_fn' = mkAppTys rep_fn args_to_keep
+ rep_tys = tys ++ [rep_fn']
rep_pred = mkClassPred clas rep_tys
-- rep_pred is the representation dictionary, from where
-- we are gong to get all the methods for the newtype dictionary
-- (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)
+ && (tyVarsOfType rep_fn' `subVarSet` mkVarSet tyvars_to_keep)
cant_derive_err = derivingThingErr clas tys tycon tyvars_to_keep
(vcat [ptext SLIT("even with cunning newtype deriving:"),
------------------------------------------------------------------
gen_soln (_, clas, tc,tyvars,deriv_rhs)
- = setSrcSpan (srcLocSpan (getSrcLoc tc)) $
- addErrCtxt (derivCtxt (Just clas) tc) $
- tcSimplifyDeriv tc tyvars deriv_rhs `thenM` \ theta ->
- returnM (sortLe (<=) theta) -- Canonicalise before returning the soluction
+ = setSrcSpan (srcLocSpan (getSrcLoc tc)) $
+ do { let inst_tys = [mkTyConApp tc (mkTyVarTys tyvars)]
+ ; theta <- addErrCtxt (derivInstCtxt1 clas inst_tys) $
+ tcSimplifyDeriv tc tyvars deriv_rhs
+ ; addErrCtxt (derivInstCtxt2 theta clas inst_tys) $
+ checkValidInstance tyvars theta clas inst_tys
+ ; return (sortLe (<=) theta) } -- Canonicalise before returning the soluction
+ where
+
------------------------------------------------------------------
mk_inst_spec (dfun_name, clas, tycon, tyvars, _) theta
-- *non-renamed* auxiliary bindings
; (rn_meth_binds, _fvs) <- discardWarnings $
bindLocalNames (map varName tyvars) $
- rnMethodBinds clas_nm [] meth_binds
+ rnMethodBinds clas_nm (\n -> []) [] meth_binds
-- Build the InstInfo
; return (InstInfo { iSpec = spec,
where
pred = mkClassPred clas (tys ++ [mkTyConApp tycon (mkTyVarTys tyvars)])
-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")
+derivCtxt :: TyCon -> SDoc
+derivCtxt tycon
+ = ptext SLIT("When deriving instances for") <+> quotes (ppr tycon)
+
+derivInstCtxt1 clas inst_tys
+ = ptext SLIT("When deriving the instance for") <+> quotes (pprClassPred clas inst_tys)
+
+derivInstCtxt2 theta clas inst_tys
+ = vcat [ptext SLIT("In the derived instance declaration"),
+ nest 2 (ptext SLIT("instance") <+> sep [pprThetaArrow theta,
+ pprClassPred clas inst_tys])]
\end{code}