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,9 +971,9 @@ dataConCannotMatch tys con ...@@ -971,9 +971,9 @@ dataConCannotMatch tys con
-- TODO: could gather equalities from superclasses too -- TODO: could gather equalities from superclasses too
predEqs pred = case classifyPredType pred of predEqs pred = case classifyPredType pred of
EqPred ty1 ty2 -> [(ty1, ty2)] EqPred NomEq ty1 ty2 -> [(ty1, ty2)]
TuplePred ts -> concatMap predEqs ts TuplePred ts -> concatMap predEqs ts
_ -> [] _ -> []
{- {-
************************************************************************ ************************************************************************
......
...@@ -951,9 +951,7 @@ ds_tc_coercion subst tc_co ...@@ -951,9 +951,7 @@ ds_tc_coercion subst tc_co
where where
go (TcRefl r ty) = Refl r (Coercion.substTy subst ty) go (TcRefl r ty) = Refl r (Coercion.substTy subst ty)
go (TcTyConAppCo r tc cos) = mkTyConAppCo r tc (map go cos) go (TcTyConAppCo r tc cos) = mkTyConAppCo r tc (map go cos)
go (TcAppCo co1 co2) = let leftCo = go co1 go (TcAppCo co1 co2) = mkAppCo (go co1) (go co2)
rightRole = nextRole leftCo in
mkAppCoFlexible leftCo rightRole (go co2)
go (TcForAllCo tv co) = mkForAllCo tv' (ds_tc_coercion subst' co) go (TcForAllCo tv co) = mkForAllCo tv' (ds_tc_coercion subst' co)
where where
(subst', tv') = Coercion.substTyVarBndr subst tv (subst', tv') = Coercion.substTyVarBndr subst tv
...@@ -969,6 +967,7 @@ ds_tc_coercion subst tc_co ...@@ -969,6 +967,7 @@ ds_tc_coercion subst tc_co
go (TcCastCo co1 co2) = mkCoCast (go co1) (go co2) go (TcCastCo co1 co2) = mkCoCast (go co1) (go co2)
go (TcCoVarCo v) = ds_ev_id subst v go (TcCoVarCo v) = ds_ev_id subst v
go (TcAxiomRuleCo co ts cs) = AxiomRuleCo co (map (Coercion.substTy subst) ts) (map go cs) 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 :: TcEvBinds -> CvSubst
ds_co_binds (EvBinds bs) = foldl ds_scc subst (sccEvBinds bs) ds_co_binds (EvBinds bs) = foldl ds_scc subst (sccEvBinds bs)
......
...@@ -6,18 +6,17 @@ module FamInst ( ...@@ -6,18 +6,17 @@ module FamInst (
FamInstEnvs, tcGetFamInstEnvs, FamInstEnvs, tcGetFamInstEnvs,
checkFamInstConsistency, tcExtendLocalFamInstEnv, checkFamInstConsistency, tcExtendLocalFamInstEnv,
tcLookupFamInst, tcLookupFamInst,
tcLookupDataFamInst, tcInstNewTyConTF_maybe, tcInstNewTyCon_maybe, tcLookupDataFamInst, tcLookupDataFamInst_maybe,
tcInstNewTyCon_maybe, tcTopNormaliseNewTypeTF_maybe,
newFamInst newFamInst
) where ) where
import HscTypes import HscTypes
import FamInstEnv import FamInstEnv
import InstEnv( roughMatchTcs ) import InstEnv( roughMatchTcs )
import Coercion( pprCoAxBranchHdr ) import Coercion hiding ( substTy )
import TcEvidence import TcEvidence
import LoadIface import LoadIface
import Type( applyTysX )
import TypeRep
import TcRnMonad import TcRnMonad
import TyCon import TyCon
import CoAxiom import CoAxiom
...@@ -27,6 +26,8 @@ import Outputable ...@@ -27,6 +26,8 @@ import Outputable
import UniqFM import UniqFM
import FastString import FastString
import Util import Util
import RdrName
import DataCon ( dataConName )
import Maybes import Maybes
import TcMType import TcMType
import TcType import TcType
...@@ -34,6 +35,7 @@ import Name ...@@ -34,6 +35,7 @@ import Name
import Control.Monad import Control.Monad
import Data.Map (Map) import Data.Map (Map)
import qualified Data.Map as Map import qualified Data.Map as Map
import Control.Arrow ( first, second )
#include "HsVersions.h" #include "HsVersions.h"
...@@ -216,45 +218,80 @@ tcLookupFamInst fam_envs tycon tys ...@@ -216,45 +218,80 @@ tcLookupFamInst fam_envs tycon tys
-- Checks for a newtype, and for being saturated -- Checks for a newtype, and for being saturated
-- Just like Coercion.instNewTyCon_maybe, but returns a TcCoercion -- Just like Coercion.instNewTyCon_maybe, but returns a TcCoercion
tcInstNewTyCon_maybe :: TyCon -> [TcType] -> Maybe (TcType, TcCoercion) tcInstNewTyCon_maybe :: TyCon -> [TcType] -> Maybe (TcType, TcCoercion)
tcInstNewTyCon_maybe tc tys tcInstNewTyCon_maybe tc tys = fmap (second TcCoercion) $
| Just (tvs, ty, co_tc) <- unwrapNewTyConEtad_maybe tc -- Check for newtype instNewTyCon_maybe tc tys
, tvs `leLength` tys -- Check saturated enough
= Just (applyTysX tvs ty tys, mkTcUnbranchedAxInstCo Representational co_tc tys)
| otherwise
= Nothing
-- | Like 'tcLookupDataFamInst_maybe', but returns the arguments back if
-- there is no data family to unwrap.
tcLookupDataFamInst :: FamInstEnvs -> TyCon -> [TcType] tcLookupDataFamInst :: FamInstEnvs -> TyCon -> [TcType]
-> (TyCon, [TcType], TcCoercion) -> (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) -- ^ 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 -- 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 tcLookupDataFamInst_maybe fam_inst_envs tc tc_args
-- Refl coercion and the original inputs
tcLookupDataFamInst fam_inst_envs tc tc_args
| isDataFamilyTyCon tc | isDataFamilyTyCon tc
, match : _ <- lookupFamInstEnv fam_inst_envs tc tc_args , match : _ <- lookupFamInstEnv fam_inst_envs tc tc_args
, FamInstMatch { fim_instance = rep_fam , FamInstMatch { fim_instance = rep_fam
, fim_tys = rep_args } <- match , fim_tys = rep_args } <- match
, let co_tc = famInstAxiom rep_fam , let co_tc = famInstAxiom rep_fam
rep_tc = dataFamInstRepTyCon rep_fam rep_tc = dataFamInstRepTyCon rep_fam
co = mkTcUnbranchedAxInstCo Representational co_tc rep_args co = mkUnbranchedAxInstCo Representational co_tc rep_args
= (rep_tc, rep_args, co) = 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 | otherwise
= Nothing = 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,9 +480,9 @@ oclose preds fixed_tvs ...@@ -480,9 +480,9 @@ oclose preds fixed_tvs
do let (cls_tvs, cls_fds) = classTvsFds cls do let (cls_tvs, cls_fds) = classTvsFds cls
fd <- cls_fds fd <- cls_fds
return (instFD fd cls_tvs tys) 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 TuplePred ts -> concatMap determined ts
_ -> [] _ -> []
{- {-
************************************************************************ ************************************************************************
......
...@@ -220,8 +220,21 @@ instCallConstraints orig preds ...@@ -220,8 +220,21 @@ instCallConstraints orig preds
= do { co <- unifyType ty1 ty2 = do { co <- unifyType ty1 ty2
; return (EvCoercion co) } ; return (EvCoercion co) }
| otherwise | otherwise
= do { ev_var <- emitWanted orig pred = do { ev_var <- emitWanted modified_orig pred
; return (EvId ev_var) } ; 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 () instStupidTheta :: CtOrigin -> TcThetaType -> TcM ()
......
This diff is collapsed.
...@@ -1807,7 +1807,6 @@ inferInstanceContexts infer_specs ...@@ -1807,7 +1807,6 @@ inferInstanceContexts infer_specs
do { theta <- simplifyDeriv the_pred tyvars deriv_rhs do { theta <- simplifyDeriv the_pred tyvars deriv_rhs
-- checkValidInstance tyvars theta clas inst_tys -- checkValidInstance tyvars theta clas inst_tys
-- Not necessary; see Note [Exotic derived instance contexts] -- Not necessary; see Note [Exotic derived instance contexts]
-- in TcSimplify
; traceTc "TcDeriv" (ppr deriv_rhs $$ ppr theta) ; traceTc "TcDeriv" (ppr deriv_rhs $$ ppr theta)
-- Claim: the result instance declaration is guaranteed valid -- Claim: the result instance declaration is guaranteed valid
......
...@@ -18,19 +18,19 @@ import Type ...@@ -18,19 +18,19 @@ import Type
import Kind ( isKind ) import Kind ( isKind )
import Unify ( tcMatchTys ) import Unify ( tcMatchTys )
import Module import Module
import FamInst ( FamInstEnvs, tcGetFamInstEnvs, tcLookupDataFamInst ) import FamInst
import Inst import Inst
import InstEnv import InstEnv
import TyCon import TyCon
import DataCon import DataCon
import TcEvidence import TcEvidence
import TysWiredIn ( coercibleClass )
import Name import Name
import RdrName ( lookupGRE_Name ) import RdrName ( lookupGRE_Name, GlobalRdrEnv )
import Id import Id
import Var import Var
import VarSet import VarSet
import VarEnv import VarEnv
import NameEnv
import Bag import Bag
import ErrUtils ( ErrMsg, makeIntoWarning, pprLocErrMsg, isWarning ) import ErrUtils ( ErrMsg, makeIntoWarning, pprLocErrMsg, isWarning )
import BasicTypes import BasicTypes
...@@ -44,7 +44,7 @@ import ListSetOps ( equivClasses ) ...@@ -44,7 +44,7 @@ import ListSetOps ( equivClasses )
import Control.Monad ( when ) import Control.Monad ( when )
import Data.Maybe 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 ...@@ -277,12 +277,12 @@ reportFlats ctxt flats -- Here 'flats' includes insolble goals
utterly_wrong, skolem_eq, is_hole, is_dict, utterly_wrong, skolem_eq, is_hole, is_dict,
is_equality, is_ip, is_irred :: Ct -> PredTree -> Bool 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 utterly_wrong _ _ = False
is_hole ct _ = isHoleCt ct 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 skolem_eq _ _ = False
is_equality _ (EqPred {}) = True is_equality _ (EqPred {}) = True
...@@ -340,7 +340,8 @@ mkSkolReporter ctxt cts ...@@ -340,7 +340,8 @@ mkSkolReporter ctxt cts
where where
cmp_lhs_type ct1 ct2 cmp_lhs_type ct1 ct2
= case (classifyPredType (ctPred ct1), classifyPredType (ctPred ct2)) of = 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) _ -> pprPanic "mkSkolReporter" (ppr ct1 $$ ppr ct2)
mkHoleReporter :: (ReportErrCtxt -> Ct -> TcM ErrMsg) -> Reporter mkHoleReporter :: (ReportErrCtxt -> Ct -> TcM ErrMsg) -> Reporter
...@@ -666,11 +667,16 @@ mkEqErr1 ctxt ct ...@@ -666,11 +667,16 @@ mkEqErr1 ctxt ct
| otherwise -- Wanted or derived | otherwise -- Wanted or derived
= do { (ctxt, binds_msg) <- relevantBindings True ctxt ct = do { (ctxt, binds_msg) <- relevantBindings True ctxt ct
; (env1, tidy_orig) <- zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc) ; (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 ; 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 ; dflags <- getDynFlags
; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctLocOrigin loc) $$ pprCtOrigin tidy_orig) ; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctLocOrigin loc) $$ pprCtOrigin tidy_orig)
; mkEqErr_help dflags (ctxt {cec_tidy = env1}) ; mkEqErr_help dflags (ctxt {cec_tidy = env1})
(wanted_msg $$ binds_msg) (wanted_msg $$ coercible_msg $$ binds_msg)
ct is_oriented ty1 ty2 } ct is_oriented ty1 ty2 }
where where
ev = ctEvidence ct ev = ctEvidence ct
...@@ -700,9 +706,86 @@ mkEqErr1 ctxt ct ...@@ -700,9 +706,86 @@ mkEqErr1 ctxt ct
TypeEqOrigin {} -> snd (mkExpectedActualMsg cty1 cty2 sub_o) TypeEqOrigin {} -> snd (mkExpectedActualMsg cty1 cty2 sub_o)
_ -> empty _ -> empty
mk_wanted_extra orig@(FunDepOrigin1 {}) = (Nothing, pprArising orig) mk_wanted_extra orig@(FunDepOrigin1 {}) = (Nothing, pprArising orig)
mk_wanted_extra orig@(FunDepOrigin2 {}) = (Nothing, pprArising orig) mk_wanted_extra orig@(FunDepOrigin2 {}) = (Nothing, pprArising orig)
mk_wanted_extra _ = (Nothing, empty) 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 mkEqErr_help :: DynFlags -> ReportErrCtxt -> SDoc
-> Ct -> Ct
...@@ -743,6 +826,7 @@ mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2 ...@@ -743,6 +826,7 @@ mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2
= mkErrorMsg ctxt ct $ (kindErrorMsg (mkTyVarTy tv1) ty2 $$ extra) = mkErrorMsg ctxt ct $ (kindErrorMsg (mkTyVarTy tv1) ty2 $$ extra)
| OC_Occurs <- occ_check_expand | 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:") = do { let occCheckMsg = hang (text "Occurs check: cannot construct the infinite type:")
2 (sep [ppr ty1, char '~', ppr ty2]) 2 (sep [ppr ty1, char '~', ppr ty2])
extra2 = mkEqInfoMsg ct ty1 ty2 extra2 = mkEqInfoMsg ct ty1 ty2
...@@ -762,7 +846,7 @@ mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2 ...@@ -762,7 +846,7 @@ mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2
| (implic:_) <- cec_encl ctxt | (implic:_) <- cec_encl ctxt
, Implic { ic_skols = skols } <- implic , Implic { ic_skols = skols } <- implic
, tv1 `elem` skols , 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 , extraTyVarInfo ctxt tv1 ty2
, extra ]) , extra ])
...@@ -771,7 +855,7 @@ mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2 ...@@ -771,7 +855,7 @@ mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2
, Implic { ic_env = env, ic_skols = skols, ic_info = skol_info } <- implic , Implic { ic_env = env, ic_skols = skols, ic_info = skol_info } <- implic
, let esc_skols = filter (`elemVarSet` (tyVarsOfType ty2)) skols , let esc_skols = filter (`elemVarSet` (tyVarsOfType ty2)) skols
, not (null esc_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 esc_doc = sep [ ptext (sLit "because type variable") <> plural esc_skols
<+> pprQuotedList esc_skols <+> pprQuotedList esc_skols
, ptext (sLit "would escape") <+> , ptext (sLit "would escape") <+>
...@@ -789,7 +873,7 @@ mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2 ...@@ -789,7 +873,7 @@ mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2
-- Nastiest case: attempt to unify an untouchable variable -- Nastiest case: attempt to unify an untouchable variable
| (implic:_) <- cec_encl ctxt -- Get the innermost context | (implic:_) <- cec_encl ctxt -- Get the innermost context
, Implic { ic_env = env, ic_given = given, ic_info = skol_info } <- implic , 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 tclvl_extra
= nest 2 $ = nest 2 $
sep [ quotes (ppr tv1) <+> ptext (sLit "is untouchable") sep [ quotes (ppr tv1) <+> ptext (sLit "is untouchable")
...@@ -807,9 +891,10 @@ mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2 ...@@ -807,9 +891,10 @@ mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2
-- Not an occurs check, because F is a type function. -- Not an occurs check, because F is a type function.
where where
occ_check_expand = occurCheckExpand dflags tv1 ty2 occ_check_expand = occurCheckExpand dflags tv1 ty2
k1 = tyVarKind tv1 k1 = tyVarKind tv1
k2 = typeKind ty2 k2 = typeKind ty2
ty1 = mkTyVarTy tv1 ty1 = mkTyVarTy tv1
eq_rel = ctEqRel ct
mkEqInfoMsg :: Ct -> TcType -> TcType -> SDoc mkEqInfoMsg :: Ct -> TcType -> TcType -> SDoc
-- Report (a) ambiguity if either side is a type function application -- Report (a) ambiguity if either side is a type function application
...@@ -853,7 +938,7 @@ misMatchOrCND ctxt ct oriented ty1 ty2 ...@@ -853,7 +938,7 @@ misMatchOrCND ctxt ct oriented ty1 ty2
isGivenCt ct isGivenCt ct
-- If the equality is unconditionally insoluble -- If the equality is unconditionally insoluble
-- or there is no context, don't report the context -- or there is no context, don't report the context
= misMatchMsg oriented ty1 ty2 = misMatchMsg oriented (ctEqRel ct) ty1 ty2
| otherwise | otherwise
= couldNotDeduce givens ([mkTcEqPred ty1 ty2], orig) = couldNotDeduce givens ([mkTcEqPred ty1 ty2], orig)
where where
...@@ -928,23 +1013,31 @@ kindErrorMsg ty1 ty2 ...@@ -928,23 +1013,31 @@ kindErrorMsg ty1 ty2
k2 = typeKind ty2 k2 = typeKind ty2
-------------------- --------------------
misMatchMsg :: Maybe SwapFlag -> TcType -> TcType -> SDoc -- Types are already tidy