This patch arranges that derived instances use the same instance-decl
checking code as user-defined instances. That gives greater consistency
in error messages.
Furthermore, the error description if this consistency check fails is now
much more explicit. For example, drvfail003 now says
Variable occurs more often in a constraint than in the instance head
in the constraint: Show (v (v a))
(Use -fallow-undecidable-instances to permit this)
In the derived instance
instance (Show (v (v a))) => Show (Square_ v w a)
import Generics ( mkTyConGenericBinds )
import TcRnMonad
import Generics ( mkTyConGenericBinds )
import TcRnMonad
+import TcMType ( checkValidInstance )
import TcEnv ( newDFunName, pprInstInfoDetails,
InstInfo(..), InstBindings(..), simpleInstInfoClsTy,
tcLookupClass, tcLookupTyCon, tcExtendTyVarEnv
import TcEnv ( newDFunName, pprInstInfoDetails,
InstInfo(..), InstBindings(..), simpleInstInfoClsTy,
tcLookupClass, tcLookupTyCon, tcExtendTyVarEnv
import HscTypes ( FixityEnv )
import Class ( className, classArity, classKey, classTyVars, classSCTheta, Class )
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 )
import ErrUtils ( dumpIfSet_dyn )
import MkId ( mkDictFunId )
import DataCon ( isNullarySrcDataCon, isVanillaDataCon, dataConOrigArgTys )
mk_eqn (new_or_data, tycon_name, hs_deriv_ty)
= tcLookupTyCon tycon_name `thenM` \ tycon ->
setSrcSpan (srcLocSpan (getSrcLoc tycon)) $
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) ->
tcExtendTyVarEnv (tyConTyVars tycon) $ -- Deriving preds may (now) mention
-- the type variables for the type constructor
tcHsDeriv hs_deriv_ty `thenM` \ (deriv_tvs, clas, tys) ->
------------------------------------------------------------------
gen_soln (_, clas, tc,tyvars,deriv_rhs)
------------------------------------------------------------------
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 (derivInstCtxt [] clas inst_tys) $
+ tcSimplifyDeriv tc tyvars deriv_rhs
+ ; addErrCtxt (derivInstCtxt 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
------------------------------------------------------------------
mk_inst_spec (dfun_name, clas, tycon, tyvars, _) theta
where
pred = mkClassPred clas (tys ++ [mkTyConApp tycon (mkTyVarTys tyvars)])
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)
+
+derivInstCtxt theta clas inst_tys
+ = hang (ptext SLIT("In the derived instance"))
+ 2 (ptext SLIT("instance") <+> sep [pprThetaArrow theta, pprClassPred clas inst_tys])
import TcEnv ( tcGetGlobalTyVars, tcLookupId, findGlobals, pprBinders,
lclEnvElts, tcMetaTy )
import InstEnv ( lookupInstEnv, classInstances, pprInstances )
import TcEnv ( tcGetGlobalTyVars, tcLookupId, findGlobals, pprBinders,
lclEnvElts, tcMetaTy )
import InstEnv ( lookupInstEnv, classInstances, pprInstances )
-import TcMType ( zonkTcTyVarsAndFV, tcInstTyVars, zonkTcPredType,
- checkAmbiguity, checkInstTermination )
+import TcMType ( zonkTcTyVarsAndFV, tcInstTyVars, zonkTcPredType )
import TcType ( TcTyVar, TcTyVarSet, ThetaType, TcPredType, tidyPred,
mkClassPred, isOverloadedTy, mkTyConApp, isSkolemTyVar,
mkTyVarTy, tcGetTyVar, isTyVarClassPred, mkTyVarTys,
import TcType ( TcTyVar, TcTyVarSet, ThetaType, TcPredType, tidyPred,
mkClassPred, isOverloadedTy, mkTyConApp, isSkolemTyVar,
mkTyVarTy, tcGetTyVar, isTyVarClassPred, mkTyVarTys,
rev_env = zipTopTvSubst tvs (mkTyVarTys tyvars)
-- This reverse-mapping is a Royal Pain,
-- but the result should mention TyVars not TcTyVars
rev_env = zipTopTvSubst tvs (mkTyVarTys tyvars)
-- This reverse-mapping is a Royal Pain,
-- but the result should mention TyVars not TcTyVars
-
- head_ty = TyConApp tc (map TyVarTy tvs)
in
addNoInstanceErrs Nothing [] bad_insts `thenM_`
mapM_ (addErrTc . badDerivedPred) weird_preds `thenM_`
in
addNoInstanceErrs Nothing [] bad_insts `thenM_`
mapM_ (addErrTc . badDerivedPred) weird_preds `thenM_`
- checkAmbiguity tvs simpl_theta tv_set `thenM_`
- -- Check instance termination as for user-declared instances.
- -- unless we had -fallow-undecidable-instances (which risks
- -- non-termination in the 'deriving' context-inference fixpoint
- -- loop).
- ifM (gla_exts && not undecidable_ok)
- (checkInstTermination simpl_theta [head_ty]) `thenM_`
returnM (substTheta rev_env simpl_theta)
where
doc = ptext SLIT("deriving classes for a data type")
returnM (substTheta rev_env simpl_theta)
where
doc = ptext SLIT("deriving classes for a data type")