import HscTypes ( FixityEnv )
import Class ( className, classArity, classKey, classTyVars, classSCTheta, Class )
-import Type ( zipOpenTvSubst, substTheta, pprThetaArrow, pprClassPred )
+import Type ( zipOpenTvSubst, substTheta, pprThetaArrow, pprClassPred, mkTyVarTy )
import ErrUtils ( dumpIfSet_dyn )
import MkId ( mkDictFunId )
-import DataCon ( isNullarySrcDataCon, isVanillaDataCon, dataConOrigArgTys )
+import DataCon ( isNullarySrcDataCon, isVanillaDataCon, dataConOrigArgTys, dataConInstOrigArgTys )
import Maybes ( catMaybes )
import RdrName ( RdrName )
import Name ( Name, getSrcLoc )
ordinary_constraints
= [ mkClassPred clas [arg_ty]
| data_con <- tyConDataCons tycon,
- arg_ty <- dataConOrigArgTys data_con,
+ arg_ty <- dataConInstOrigArgTys data_con (map mkTyVarTy (tyConTyVars tycon)),
not (isUnLiftedType arg_ty) -- No constraints for unlifted types?
]
gen_soln (_, clas, tc,tyvars,deriv_rhs)
= setSrcSpan (srcLocSpan (getSrcLoc tc)) $
do { let inst_tys = [mkTyConApp tc (mkTyVarTys tyvars)]
- ; theta <- addErrCtxt (derivInstCtxt [] clas inst_tys) $
+ ; theta <- addErrCtxt (derivInstCtxt1 clas inst_tys) $
tcSimplifyDeriv tc tyvars deriv_rhs
- ; addErrCtxt (derivInstCtxt theta clas inst_tys) $
+ ; addErrCtxt (derivInstCtxt2 theta clas inst_tys) $
checkValidInstance tyvars theta clas inst_tys
; return (sortLe (<=) theta) } -- Canonicalise before returning the soluction
where
\begin{code}
derivingThingErr clas tys tycon tyvars why
= sep [hsep [ptext SLIT("Can't make a derived instance of"), quotes (ppr pred)],
- parens why]
+ nest 2 (parens why)]
where
pred = mkClassPred clas (tys ++ [mkTyConApp tycon (mkTyVarTys tyvars)])
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])
+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}