Commit 0cc47eb9 authored by eir@cis.upenn.edu's avatar eir@cis.upenn.edu

Rewrite `Coercible` solver

Summary:
This is a rewrite of the algorithm to solve for Coercible "instances".

A preliminary form of these ideas is at
https://ghc.haskell.org/trac/ghc/wiki/Design/NewCoercibleSolver

The basic idea here is that the `EqPred` constructor of `PredTree`
now is parameterised by a new type `EqRel` (where
`data EqRel = NomEq | ReprEq`). Thus, every equality constraint can
now talk about nominal equality (the usual case) or representational
equality (the `Coercible` case).

This is a change from the previous
behavior where `Coercible` was just considered a regular class with
a special case in `matchClassInst`.

Because of this change, representational equalities are now
canonicalized just like nominal ones, allowing more equalities
to be solved -- in particular, the case at the top of #9117.

A knock-on effect is that the flattener must be aware of the
choice of equality relation, because the inert set now stores
both representational inert equalities alongside the nominal
inert equalities. Of course, we can use representational equalities
to rewrite only within another representational equality --
thus the parameterization of the flattener.

A nice side effect of this change is that I've introduced a new
type `CtFlavour`, which tracks G vs. W vs. D, removing some ugliness
in the flattener.

This commit includes some refactoring as discussed on D546.
It also removes the ability of Deriveds to rewrite Deriveds.

This fixes bugs #9117 and #8984.

Reviewers: simonpj, austin, nomeata

Subscribers: carter, thomie

Differential Revision: https://phabricator.haskell.org/D546

GHC Trac Issues: #9117, #8984
parent 058262ba
......@@ -971,7 +971,7 @@ dataConCannotMatch tys con
-- TODO: could gather equalities from superclasses too
predEqs pred = case classifyPredType pred of
EqPred ty1 ty2 -> [(ty1, ty2)]
EqPred NomEq ty1 ty2 -> [(ty1, ty2)]
TuplePred ts -> concatMap predEqs ts
_ -> []
......
......@@ -951,9 +951,7 @@ ds_tc_coercion subst tc_co
where
go (TcRefl r ty) = Refl r (Coercion.substTy subst ty)
go (TcTyConAppCo r tc cos) = mkTyConAppCo r tc (map go cos)
go (TcAppCo co1 co2) = let leftCo = go co1
rightRole = nextRole leftCo in
mkAppCoFlexible leftCo rightRole (go co2)
go (TcAppCo co1 co2) = mkAppCo (go co1) (go co2)
go (TcForAllCo tv co) = mkForAllCo tv' (ds_tc_coercion subst' co)
where
(subst', tv') = Coercion.substTyVarBndr subst tv
......@@ -969,6 +967,7 @@ ds_tc_coercion subst tc_co
go (TcCastCo co1 co2) = mkCoCast (go co1) (go co2)
go (TcCoVarCo v) = ds_ev_id subst v
go (TcAxiomRuleCo co ts cs) = AxiomRuleCo co (map (Coercion.substTy subst) ts) (map go cs)
go (TcCoercion co) = co
ds_co_binds :: TcEvBinds -> CvSubst
ds_co_binds (EvBinds bs) = foldl ds_scc subst (sccEvBinds bs)
......
......@@ -6,18 +6,17 @@ module FamInst (
FamInstEnvs, tcGetFamInstEnvs,
checkFamInstConsistency, tcExtendLocalFamInstEnv,
tcLookupFamInst,
tcLookupDataFamInst, tcInstNewTyConTF_maybe, tcInstNewTyCon_maybe,
tcLookupDataFamInst, tcLookupDataFamInst_maybe,
tcInstNewTyCon_maybe, tcTopNormaliseNewTypeTF_maybe,
newFamInst
) where
import HscTypes
import FamInstEnv
import InstEnv( roughMatchTcs )
import Coercion( pprCoAxBranchHdr )
import Coercion hiding ( substTy )
import TcEvidence
import LoadIface
import Type( applyTysX )
import TypeRep
import TcRnMonad
import TyCon
import CoAxiom
......@@ -27,6 +26,8 @@ import Outputable
import UniqFM
import FastString
import Util
import RdrName
import DataCon ( dataConName )
import Maybes
import TcMType
import TcType
......@@ -34,6 +35,7 @@ import Name
import Control.Monad
import Data.Map (Map)
import qualified Data.Map as Map
import Control.Arrow ( first, second )
#include "HsVersions.h"
......@@ -216,45 +218,80 @@ tcLookupFamInst fam_envs tycon tys
-- Checks for a newtype, and for being saturated
-- Just like Coercion.instNewTyCon_maybe, but returns a TcCoercion
tcInstNewTyCon_maybe :: TyCon -> [TcType] -> Maybe (TcType, TcCoercion)
tcInstNewTyCon_maybe tc tys
| Just (tvs, ty, co_tc) <- unwrapNewTyConEtad_maybe tc -- Check for newtype
, tvs `leLength` tys -- Check saturated enough
= Just (applyTysX tvs ty tys, mkTcUnbranchedAxInstCo Representational co_tc tys)
| otherwise
= Nothing
tcInstNewTyCon_maybe tc tys = fmap (second TcCoercion) $
instNewTyCon_maybe tc tys
-- | Like 'tcLookupDataFamInst_maybe', but returns the arguments back if
-- there is no data family to unwrap.
tcLookupDataFamInst :: FamInstEnvs -> TyCon -> [TcType]
-> (TyCon, [TcType], TcCoercion)
tcLookupDataFamInst fam_inst_envs tc tc_args
| Just (rep_tc, rep_args, co)
<- tcLookupDataFamInst_maybe fam_inst_envs tc tc_args
= (rep_tc, rep_args, TcCoercion co)
| otherwise
= (tc, tc_args, mkTcRepReflCo (mkTyConApp tc tc_args))
tcLookupDataFamInst_maybe :: FamInstEnvs -> TyCon -> [TcType]
-> Maybe (TyCon, [TcType], Coercion)
-- ^ Converts a data family type (eg F [a]) to its representation type (eg FList a)
-- and returns a coercion between the two: co :: F [a] ~R FList a
-- If there is no instance, or it's not a data family, just return
-- Refl coercion and the original inputs
tcLookupDataFamInst fam_inst_envs tc tc_args
tcLookupDataFamInst_maybe fam_inst_envs tc tc_args
| isDataFamilyTyCon tc
, match : _ <- lookupFamInstEnv fam_inst_envs tc tc_args
, FamInstMatch { fim_instance = rep_fam
, fim_tys = rep_args } <- match
, let co_tc = famInstAxiom rep_fam
rep_tc = dataFamInstRepTyCon rep_fam
co = mkTcUnbranchedAxInstCo Representational co_tc rep_args
= (rep_tc, rep_args, co)
co = mkUnbranchedAxInstCo Representational co_tc rep_args
= Just (rep_tc, rep_args, co)
| otherwise
= (tc, tc_args, mkTcNomReflCo (mkTyConApp tc tc_args))
tcInstNewTyConTF_maybe :: FamInstEnvs -> TcType -> Maybe (TyCon, TcType, TcCoercion)
-- ^ If (instNewTyConTF_maybe envs ty) returns Just (ty', co)
-- then co :: ty ~R ty'
-- ty is (D tys) is a newtype (possibly after looking through the type family D)
-- ty' is the RHS type of the of (D tys) newtype
tcInstNewTyConTF_maybe fam_envs ty
| Just (tc, tc_args) <- tcSplitTyConApp_maybe ty
, let (rep_tc, rep_tc_args, fam_co) = tcLookupDataFamInst fam_envs tc tc_args
, Just (inner_ty, nt_co) <- tcInstNewTyCon_maybe rep_tc rep_tc_args
= Just (rep_tc, inner_ty, fam_co `mkTcTransCo` nt_co)
| otherwise
= Nothing
-- | Get rid of top-level newtypes, potentially looking through newtype
-- instances. Only unwraps newtypes that are in scope. This is used
-- for solving for `Coercible` in the solver. This version is careful
-- not to unwrap data/newtype instances if it can't continue unwrapping.
-- Such care is necessary for proper error messages.
--
-- Does not look through type families. Does not normalise arguments to a
-- tycon.
--
-- Always produces a representational coercion.
tcTopNormaliseNewTypeTF_maybe :: FamInstEnvs
-> GlobalRdrEnv
-> Type
-> Maybe (TcCoercion, Type)
tcTopNormaliseNewTypeTF_maybe faminsts rdr_env ty
-- cf. FamInstEnv.topNormaliseType_maybe and Coercion.topNormaliseNewType_maybe
= fmap (first TcCoercion) $ topNormaliseTypeX_maybe stepper ty
where
stepper
= unwrap_newtype
`composeSteppers`
\ rec_nts tc tys ->
case tcLookupDataFamInst_maybe faminsts tc tys of
Just (tc', tys', co) ->
modifyStepResultCo (co `mkTransCo`)
(unwrap_newtype rec_nts tc' tys')
Nothing -> NS_Done
unwrap_newtype rec_nts tc tys
| data_cons_in_scope tc
= unwrapNewTypeStepper rec_nts tc tys
| otherwise
= NS_Done
data_cons_in_scope :: TyCon -> Bool
data_cons_in_scope tc
= isWiredInName (tyConName tc) ||
(not (isAbstractTyCon tc) && all in_scope data_con_names)
where
data_con_names = map dataConName (tyConDataCons tc)
in_scope dc = not $ null $ lookupGRE_Name rdr_env dc
{-
************************************************************************
* *
......
......@@ -480,7 +480,7 @@ oclose preds fixed_tvs
do let (cls_tvs, cls_fds) = classTvsFds cls
fd <- cls_fds
return (instFD fd cls_tvs tys)
EqPred t1 t2 -> [([t1],[t2]), ([t2],[t1])]
EqPred NomEq t1 t2 -> [([t1],[t2]), ([t2],[t1])]
TuplePred ts -> concatMap determined ts
_ -> []
......
......@@ -220,8 +220,21 @@ instCallConstraints orig preds
= do { co <- unifyType ty1 ty2
; return (EvCoercion co) }
| otherwise
= do { ev_var <- emitWanted orig pred
= do { ev_var <- emitWanted modified_orig pred
; return (EvId ev_var) }
where
-- Coercible constraints appear as normal class constraints, but
-- are aggressively canonicalized and manipulated during solving.
-- The final equality to solve may barely resemble the initial
-- constraint. Here, we remember the initial constraint in a
-- CtOrigin for better error messages. It's perhaps worthwhile
-- considering making this approach general, for other class
-- constraints, too.
modified_orig
| Just (Representational, ty1, ty2) <- getEqPredTys_maybe pred
= CoercibleOrigin ty1 ty2
| otherwise
= orig
----------------
instStupidTheta :: CtOrigin -> TcThetaType -> TcM ()
......
This diff is collapsed.
......@@ -1807,7 +1807,6 @@ inferInstanceContexts infer_specs
do { theta <- simplifyDeriv the_pred tyvars deriv_rhs
-- checkValidInstance tyvars theta clas inst_tys
-- Not necessary; see Note [Exotic derived instance contexts]
-- in TcSimplify
; traceTc "TcDeriv" (ppr deriv_rhs $$ ppr theta)
-- Claim: the result instance declaration is guaranteed valid
......
......@@ -18,19 +18,19 @@ import Type
import Kind ( isKind )
import Unify ( tcMatchTys )
import Module
import FamInst ( FamInstEnvs, tcGetFamInstEnvs, tcLookupDataFamInst )
import FamInst
import Inst
import InstEnv
import TyCon
import DataCon
import TcEvidence
import TysWiredIn ( coercibleClass )
import Name
import RdrName ( lookupGRE_Name )
import RdrName ( lookupGRE_Name, GlobalRdrEnv )
import Id
import Var
import VarSet
import VarEnv
import NameEnv
import Bag
import ErrUtils ( ErrMsg, makeIntoWarning, pprLocErrMsg, isWarning )
import BasicTypes
......@@ -44,7 +44,7 @@ import ListSetOps ( equivClasses )
import Control.Monad ( when )
import Data.Maybe
import Data.List ( partition, mapAccumL, zip4, nub, sortBy )
import Data.List ( partition, mapAccumL, nub, sortBy )
{-
************************************************************************
......@@ -277,12 +277,12 @@ reportFlats ctxt flats -- Here 'flats' includes insolble goals
utterly_wrong, skolem_eq, is_hole, is_dict,
is_equality, is_ip, is_irred :: Ct -> PredTree -> Bool
utterly_wrong _ (EqPred ty1 ty2) = isRigid ty1 && isRigid ty2
utterly_wrong _ (EqPred _ ty1 ty2) = isRigid ty1 && isRigid ty2
utterly_wrong _ _ = False
is_hole ct _ = isHoleCt ct
skolem_eq _ (EqPred ty1 ty2) = isRigidOrSkol ty1 && isRigidOrSkol ty2
skolem_eq _ (EqPred NomEq ty1 ty2) = isRigidOrSkol ty1 && isRigidOrSkol ty2
skolem_eq _ _ = False
is_equality _ (EqPred {}) = True
......@@ -340,7 +340,8 @@ mkSkolReporter ctxt cts
where
cmp_lhs_type ct1 ct2
= case (classifyPredType (ctPred ct1), classifyPredType (ctPred ct2)) of
(EqPred ty1 _, EqPred ty2 _) -> ty1 `cmpType` ty2
(EqPred eq_rel1 ty1 _, EqPred eq_rel2 ty2 _) ->
(eq_rel1 `compare` eq_rel2) `thenCmp` (ty1 `cmpType` ty2)
_ -> pprPanic "mkSkolReporter" (ppr ct1 $$ ppr ct2)
mkHoleReporter :: (ReportErrCtxt -> Ct -> TcM ErrMsg) -> Reporter
......@@ -666,11 +667,16 @@ mkEqErr1 ctxt ct
| otherwise -- Wanted or derived
= do { (ctxt, binds_msg) <- relevantBindings True ctxt ct
; (env1, tidy_orig) <- zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc)
; rdr_env <- getGlobalRdrEnv
; fam_envs <- tcGetFamInstEnvs
; let (is_oriented, wanted_msg) = mk_wanted_extra tidy_orig
coercible_msg = case ctEvEqRel ev of
NomEq -> empty
ReprEq -> mkCoercibleExplanation rdr_env fam_envs ty1 ty2
; dflags <- getDynFlags
; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctLocOrigin loc) $$ pprCtOrigin tidy_orig)
; mkEqErr_help dflags (ctxt {cec_tidy = env1})
(wanted_msg $$ binds_msg)
(wanted_msg $$ coercible_msg $$ binds_msg)
ct is_oriented ty1 ty2 }
where
ev = ctEvidence ct
......@@ -702,8 +708,85 @@ mkEqErr1 ctxt ct
mk_wanted_extra orig@(FunDepOrigin1 {}) = (Nothing, pprArising orig)
mk_wanted_extra orig@(FunDepOrigin2 {}) = (Nothing, pprArising orig)
mk_wanted_extra orig@(DerivOriginCoerce _ oty1 oty2)
= (Nothing, pprArising orig $+$ mkRoleSigs oty1 oty2)
mk_wanted_extra orig@(CoercibleOrigin oty1 oty2)
-- if the origin types are the same as the final types, don't
-- clutter output with repetitive information
| not (oty1 `eqType` ty1 && oty2 `eqType` ty2) &&
not (oty1 `eqType` ty2 && oty2 `eqType` ty1)
= (Nothing, pprArising orig $+$ mkRoleSigs oty1 oty2)
| otherwise
-- still print role sigs even if types line up
= (Nothing, mkRoleSigs oty1 oty2)
mk_wanted_extra _ = (Nothing, empty)
-- | This function tries to reconstruct why a "Coercible ty1 ty2" constraint
-- is left over.
mkCoercibleExplanation :: GlobalRdrEnv -> FamInstEnvs
-> TcType -> TcType -> SDoc
mkCoercibleExplanation rdr_env fam_envs ty1 ty2
| Just (tc, tys) <- tcSplitTyConApp_maybe ty1
, (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys
, Just msg <- coercible_msg_for_tycon rep_tc
= msg
| Just (tc, tys) <- splitTyConApp_maybe ty2
, (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys
, Just msg <- coercible_msg_for_tycon rep_tc
= msg
| Just (s1, _) <- tcSplitAppTy_maybe ty1
, Just (s2, _) <- tcSplitAppTy_maybe ty2
, s1 `eqType` s2
, has_unknown_roles s1
= hang (text "NB: We cannot know what roles the parameters to" <+>
quotes (ppr s1) <+> text "have;")
2 (text "we must assume that the role is nominal")
| otherwise
= empty
where
coercible_msg_for_tycon tc
| isAbstractTyCon tc
= Just $ hsep [ text "NB: The type constructor"
, quotes (pprSourceTyCon tc)
, text "is abstract" ]
| isNewTyCon tc
, [data_con] <- tyConDataCons tc
, let dc_name = dataConName data_con
, null (lookupGRE_Name rdr_env dc_name)
= Just $ hang (text "The data constructor" <+> quotes (ppr dc_name))
2 (sep [ text "of newtype" <+> quotes (pprSourceTyCon tc)
, text "is not in scope" ])
| otherwise = Nothing
has_unknown_roles ty
| Just (tc, tys) <- tcSplitTyConApp_maybe ty
= length tys >= tyConArity tc -- oversaturated tycon
| Just (s, _) <- tcSplitAppTy_maybe ty
= has_unknown_roles s
| isTyVarTy ty
= True
| otherwise
= False
-- | Make a listing of role signatures for all the parameterised tycons
-- used in the provided types
mkRoleSigs :: Type -> Type -> SDoc
mkRoleSigs ty1 ty2
= ppUnless (null role_sigs) $
hang (text "Relevant role signatures:")
2 (vcat role_sigs)
where
tcs = nameEnvElts $ tyConsOfType ty1 `plusNameEnv` tyConsOfType ty2
role_sigs = mapMaybe ppr_role_sig tcs
ppr_role_sig tc
| null roles -- if there are no parameters, don't bother printing
= Nothing
| otherwise
= Just $ hsep $ [text "type role", ppr tc] ++ map ppr roles
where
roles = tyConRoles tc
mkEqErr_help :: DynFlags -> ReportErrCtxt -> SDoc
-> Ct
-> Maybe SwapFlag -- Nothing <=> not sure
......@@ -743,6 +826,7 @@ mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2
= mkErrorMsg ctxt ct $ (kindErrorMsg (mkTyVarTy tv1) ty2 $$ extra)
| OC_Occurs <- occ_check_expand
, NomEq <- ctEqRel ct -- reporting occurs check for Coercible is strange
= do { let occCheckMsg = hang (text "Occurs check: cannot construct the infinite type:")
2 (sep [ppr ty1, char '~', ppr ty2])
extra2 = mkEqInfoMsg ct ty1 ty2
......@@ -762,7 +846,7 @@ mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2
| (implic:_) <- cec_encl ctxt
, Implic { ic_skols = skols } <- implic
, tv1 `elem` skols
= mkErrorMsg ctxt ct (vcat [ misMatchMsg oriented ty1 ty2
= mkErrorMsg ctxt ct (vcat [ misMatchMsg oriented eq_rel ty1 ty2
, extraTyVarInfo ctxt tv1 ty2
, extra ])
......@@ -771,7 +855,7 @@ mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2
, Implic { ic_env = env, ic_skols = skols, ic_info = skol_info } <- implic
, let esc_skols = filter (`elemVarSet` (tyVarsOfType ty2)) skols
, not (null esc_skols)
= do { let msg = misMatchMsg oriented ty1 ty2
= do { let msg = misMatchMsg oriented eq_rel ty1 ty2
esc_doc = sep [ ptext (sLit "because type variable") <> plural esc_skols
<+> pprQuotedList esc_skols
, ptext (sLit "would escape") <+>
......@@ -789,7 +873,7 @@ mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2
-- Nastiest case: attempt to unify an untouchable variable
| (implic:_) <- cec_encl ctxt -- Get the innermost context
, Implic { ic_env = env, ic_given = given, ic_info = skol_info } <- implic
= do { let msg = misMatchMsg oriented ty1 ty2
= do { let msg = misMatchMsg oriented eq_rel ty1 ty2
tclvl_extra
= nest 2 $
sep [ quotes (ppr tv1) <+> ptext (sLit "is untouchable")
......@@ -810,6 +894,7 @@ mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2
k1 = tyVarKind tv1
k2 = typeKind ty2
ty1 = mkTyVarTy tv1
eq_rel = ctEqRel ct
mkEqInfoMsg :: Ct -> TcType -> TcType -> SDoc
-- Report (a) ambiguity if either side is a type function application
......@@ -853,7 +938,7 @@ misMatchOrCND ctxt ct oriented ty1 ty2
isGivenCt ct
-- If the equality is unconditionally insoluble
-- or there is no context, don't report the context
= misMatchMsg oriented ty1 ty2
= misMatchMsg oriented (ctEqRel ct) ty1 ty2
| otherwise
= couldNotDeduce givens ([mkTcEqPred ty1 ty2], orig)
where
......@@ -928,23 +1013,31 @@ kindErrorMsg ty1 ty2
k2 = typeKind ty2
--------------------
misMatchMsg :: Maybe SwapFlag -> TcType -> TcType -> SDoc -- Types are already tidy
misMatchMsg :: Maybe SwapFlag -> EqRel -> TcType -> TcType -> SDoc
-- Types are already tidy
-- If oriented then ty1 is actual, ty2 is expected
misMatchMsg oriented ty1 ty2
misMatchMsg oriented eq_rel ty1 ty2
| Just IsSwapped <- oriented
= misMatchMsg (Just NotSwapped) ty2 ty1
= misMatchMsg (Just NotSwapped) eq_rel ty2 ty1
| Just NotSwapped <- oriented
= sep [ ptext (sLit "Couldn't match expected") <+> what <+> quotes (ppr ty2)
, nest 12 $ ptext (sLit "with actual") <+> what <+> quotes (ppr ty1)
= sep [ text "Couldn't match" <+> repr1 <+> text "expected" <+>
what <+> quotes (ppr ty2)
, nest (12 + extra_space) $
text "with" <+> repr2 <+> text "actual" <+> what <+> quotes (ppr ty1)
, sameOccExtra ty2 ty1 ]
| otherwise
= sep [ ptext (sLit "Couldn't match") <+> what <+> quotes (ppr ty1)
, nest 14 $ ptext (sLit "with") <+> quotes (ppr ty2)
= sep [ text "Couldn't match" <+> repr1 <+> what <+> quotes (ppr ty1)
, nest (15 + extra_space) $
text "with" <+> repr2 <+> quotes (ppr ty2)
, sameOccExtra ty1 ty2 ]
where
what | isKind ty1 = ptext (sLit "kind")
| otherwise = ptext (sLit "type")
(repr1, repr2, extra_space) = case eq_rel of
NomEq -> (empty, empty, 0)
ReprEq -> (text "representation of", text "that of", 10)
mkExpectedActualMsg :: Type -> Type -> CtOrigin -> (Maybe SwapFlag, SDoc)
-- NotSwapped means (actual, expected), IsSwapped is the reverse
mkExpectedActualMsg ty1 ty2 (TypeEqOrigin { uo_actual = act, uo_expected = exp })
......@@ -1048,7 +1141,6 @@ mkDictErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkDictErr ctxt cts
= ASSERT( not (null cts) )
do { inst_envs <- tcGetInstEnvs
; fam_envs <- tcGetFamInstEnvs
; let (ct1:_) = cts -- ct1 just for its location
min_cts = elim_superclasses cts
; lookups <- mapM (lookup_cls_inst inst_envs) min_cts
......@@ -1059,7 +1151,7 @@ mkDictErr ctxt cts
-- But we report only one of them (hence 'head') because they all
-- have the same source-location origin, to try avoid a cascade
-- of error from one location
; (ctxt, err) <- mk_dict_err fam_envs ctxt (head (no_inst_cts ++ overlap_cts))
; (ctxt, err) <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts))
; mkErrorMsg ctxt ct1 err }
where
no_givens = null (getUserGivens ctxt)
......@@ -1085,17 +1177,16 @@ mkDictErr ctxt cts
where
min_preds = mkMinimalBySCs (map ctPred cts)
mk_dict_err :: FamInstEnvs -> ReportErrCtxt -> (Ct, ClsInstLookupResult)
mk_dict_err :: ReportErrCtxt -> (Ct, ClsInstLookupResult)
-> TcM (ReportErrCtxt, SDoc)
-- Report an overlap error if this class constraint results
-- from an overlap (returning Left clas), otherwise return (Right pred)
mk_dict_err fam_envs ctxt (ct, (matches, unifiers, safe_haskell))
mk_dict_err ctxt (ct, (matches, unifiers, safe_haskell))
| null matches -- No matches but perhaps several unifiers
= do { let (is_ambig, ambig_msg) = mkAmbigMsg ct
; (ctxt, binds_msg) <- relevantBindings True ctxt ct
; traceTc "mk_dict_err" (ppr ct $$ ppr is_ambig $$ ambig_msg)
; rdr_env <- getGlobalRdrEnv
; return (ctxt, cannot_resolve_msg rdr_env is_ambig binds_msg ambig_msg) }
; return (ctxt, cannot_resolve_msg is_ambig binds_msg ambig_msg) }
| not safe_haskell -- Some matches => overlap errors
= return (ctxt, overlap_msg)
......@@ -1110,8 +1201,8 @@ mk_dict_err fam_envs ctxt (ct, (matches, unifiers, safe_haskell))
givens = getUserGivens ctxt
all_tyvars = all isTyVarTy tys
cannot_resolve_msg rdr_env has_ambig_tvs binds_msg ambig_msg
= vcat [ addArising orig (no_inst_msg $$ coercible_explanation rdr_env)
cannot_resolve_msg has_ambig_tvs binds_msg ambig_msg
= vcat [ addArising orig no_inst_msg
, vcat (pp_givens givens)
, ppWhen (has_ambig_tvs && not (null unifiers && null givens))
(vcat [ ambig_msg, binds_msg, potential_msg ])
......@@ -1143,11 +1234,6 @@ mk_dict_err fam_envs ctxt (ct, (matches, unifiers, safe_haskell))
ppr_skol skol_info = ppr skol_info
no_inst_msg
| clas == coercibleClass
= let (ty1, ty2) = getEqPredTys pred
in sep [ ptext (sLit "Could not coerce from") <+> quotes (ppr ty1)
, nest 19 (ptext (sLit "to") <+> quotes (ppr ty2)) ]
-- The nesting makes the types line up
| null givens && null matches
= ptext (sLit "No instance for")
<+> pprParendType pred
......@@ -1241,53 +1327,6 @@ mk_dict_err fam_envs ctxt (ct, (matches, unifiers, safe_haskell))
]
]
-- This function tries to reconstruct why a "Coercible ty1 ty2" constraint
-- is left over. Therefore its logic has to stay in sync with
-- getCoericbleInst in TcInteract. See Note [Coercible Instances]
coercible_explanation rdr_env
| clas /= coercibleClass = empty
| Just (tc1,tyArgs1) <- splitTyConApp_maybe ty1,
Just (tc2,tyArgs2) <- splitTyConApp_maybe ty2,
tc1 == tc2
= nest 2 $ vcat $
[ fsep [ hsep [ ptext $ sLit "because the", speakNth n, ptext $ sLit "type argument"]
, hsep [ ptext $ sLit "of", quotes (ppr tc1), ptext $ sLit "has role Nominal,"]
, ptext $ sLit "but the arguments"
, quotes (ppr t1)
, ptext $ sLit "and"
, quotes (ppr t2)
, ptext $ sLit "differ" ]
| (n,Nominal,t1,t2) <- zip4 [1..] (tyConRoles tc1) tyArgs1 tyArgs2
, not (t1 `eqType` t2)
]
| Just (tc, tys) <- tcSplitTyConApp_maybe ty1
, (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys
, Just msg <- coercible_msg_for_tycon rdr_env rep_tc
= msg
| Just (tc, tys) <- splitTyConApp_maybe ty2
, (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys
, Just msg <- coercible_msg_for_tycon rdr_env rep_tc
= msg
| otherwise
= nest 2 $ sep [ ptext (sLit "because") <+> quotes (ppr ty1)
, nest 4 (vcat [ ptext (sLit "and") <+> quotes (ppr ty2)
, ptext (sLit "are different types.") ]) ]
where
(ty1, ty2) = getEqPredTys pred
coercible_msg_for_tycon rdr_env tc
| isAbstractTyCon tc
= Just $ hsep [ ptext $ sLit "because the type constructor", quotes (pprSourceTyCon tc)
, ptext $ sLit "is abstract" ]
| isNewTyCon tc
, [data_con] <- tyConDataCons tc
, let dc_name = dataConName data_con
, null (lookupGRE_Name rdr_env dc_name)
= Just $ hang (ptext (sLit "because the data constructor") <+> quotes (ppr dc_name))
2 (sep [ ptext (sLit "of newtype") <+> quotes (pprSourceTyCon tc)
, ptext (sLit "is not in scope") ])
| otherwise = Nothing
usefulContext :: ReportErrCtxt -> TcPredType -> [SkolemInfo]
usefulContext ctxt pred
= go (cec_encl ctxt)
......
......@@ -18,11 +18,12 @@ module TcEvidence (
-- TcCoercion
TcCoercion(..), LeftOrRight(..), pickLR,
mkTcReflCo, mkTcNomReflCo,
mkTcReflCo, mkTcNomReflCo, mkTcRepReflCo,