Commit 9a058b17 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Refactor the handling of kind errors

* Treat kind-equality constraints as *derived* equalities,
  with no evidence.  That is really what they are at the moment.

* Get rid of EvKindCast and friends.

* Postpone kind errors properly to the constraint solver
  (lots of small knock-on effects)

I moved SwapFlag to BasicTypes as well
parent 6a9542af
...@@ -66,6 +66,7 @@ module BasicTypes( ...@@ -66,6 +66,7 @@ module BasicTypes(
StrictnessMark(..), isMarkedStrict, StrictnessMark(..), isMarkedStrict,
DefMethSpec(..), DefMethSpec(..),
SwapFlag(..), flipSwap, unSwap,
CompilerPhase(..), PhaseNum, CompilerPhase(..), PhaseNum,
Activation(..), isActive, isActiveIn, Activation(..), isActive, isActiveIn,
...@@ -123,6 +124,31 @@ type RepArity = Int ...@@ -123,6 +124,31 @@ type RepArity = Int
type Alignment = Int -- align to next N-byte boundary (N must be a power of 2). type Alignment = Int -- align to next N-byte boundary (N must be a power of 2).
\end{code} \end{code}
%************************************************************************
%* *
Swap flag
%* *
%************************************************************************
\begin{code}
data SwapFlag
= NotSwapped -- Args are: actual, expected
| IsSwapped -- Args are: expected, actual
instance Outputable SwapFlag where
ppr IsSwapped = ptext (sLit "Is-swapped")
ppr NotSwapped = ptext (sLit "Not-swapped")
flipSwap :: SwapFlag -> SwapFlag
flipSwap IsSwapped = NotSwapped
flipSwap NotSwapped = IsSwapped
unSwap :: SwapFlag -> (a->a->b) -> a -> a -> b
unSwap NotSwapped f a b = f a b
unSwap IsSwapped f a b = f b a
\end{code}
%************************************************************************ %************************************************************************
%* * %* *
\subsection[FunctionOrData]{FunctionOrData} \subsection[FunctionOrData]{FunctionOrData}
......
...@@ -741,10 +741,6 @@ dsEvTerm (EvCast tm co) ...@@ -741,10 +741,6 @@ dsEvTerm (EvCast tm co)
-- 'v' is always a lifted evidence variable so it is -- 'v' is always a lifted evidence variable so it is
-- unnecessary to call varToCoreExpr v here. -- unnecessary to call varToCoreExpr v here.
dsEvTerm (EvKindCast v co)
= do { v' <- dsEvTerm v
; dsTcCoercion co $ (\_ -> v') }
dsEvTerm (EvDFunApp df tys tms) = do { tms' <- mapM dsEvTerm tms dsEvTerm (EvDFunApp df tys tms) = do { tms' <- mapM dsEvTerm tms
; return (Var df `mkTyApps` tys `mkApps` tms') } ; return (Var df `mkTyApps` tys `mkApps` tms') }
dsEvTerm (EvCoercion co) = dsTcCoercion co mkEqBox dsEvTerm (EvCoercion co) = dsTcCoercion co mkEqBox
......
...@@ -622,13 +622,17 @@ because now the 'b' has escaped its scope. We'd have to flatten to ...@@ -622,13 +622,17 @@ because now the 'b' has escaped its scope. We'd have to flatten to
and we have not begun to think about how to make that work! and we have not begun to think about how to make that work!
\begin{code} \begin{code}
flattenTyVar :: CtLoc -> FlattenMode flattenTyVar, flattenFinalTyVar
-> CtFlavour -> TcTyVar -> TcS (Xi, TcCoercion) :: CtLoc -> FlattenMode
-> CtFlavour -> TcTyVar -> TcS (Xi, TcCoercion)
-- "Flattening" a type variable means to apply the substitution to it -- "Flattening" a type variable means to apply the substitution to it
-- The substitution is actually the union of the substitution in the TyBinds -- The substitution is actually the union of the substitution in the TyBinds
-- for the unification variables that have been unified already with the inert -- for the unification variables that have been unified already with the inert
-- equalities, see Note [Spontaneously solved in TyBinds] in TcInteract. -- equalities, see Note [Spontaneously solved in TyBinds] in TcInteract.
flattenTyVar loc f ctxt tv flattenTyVar loc f ctxt tv
| not (isTcTyVar tv) -- Happens when flatten under a (forall a. ty)
= flattenFinalTyVar loc f ctxt tv -- So ty contains referneces to the non-TcTyVar a
| otherwise
= do { mb_ty <- isFilledMetaTyVar_maybe tv = do { mb_ty <- isFilledMetaTyVar_maybe tv
; case mb_ty of { ; case mb_ty of {
Just ty -> flatten loc f ctxt ty ; Just ty -> flatten loc f ctxt ty ;
...@@ -655,13 +659,7 @@ flattenTyVar loc f ctxt tv ...@@ -655,13 +659,7 @@ flattenTyVar loc f ctxt tv
-- In fact, because of flavors, it couldn't possibly be idempotent, -- In fact, because of flavors, it couldn't possibly be idempotent,
-- this is explained in Note [Non-idempotent inert substitution] -- this is explained in Note [Non-idempotent inert substitution]
Nothing -> Nothing -> flattenFinalTyVar loc f ctxt tv
-- Done, but make sure the kind is zonked
do { let knd = tyVarKind tv
; (new_knd,_kind_co) <- flatten loc f ctxt knd
; let ty = mkTyVarTy (setVarType tv new_knd)
; return (ty, mkTcReflCo ty) }
} } } } } } } } } } } }
where where
tv_eq_subst subst tv tv_eq_subst subst tv
...@@ -672,6 +670,13 @@ flattenTyVar loc f ctxt tv ...@@ -672,6 +670,13 @@ flattenTyVar loc f ctxt tv
-- NB: even if ct is Derived we are not going to -- NB: even if ct is Derived we are not going to
-- touch the actual coercion so we are fine. -- touch the actual coercion so we are fine.
| otherwise = Nothing | otherwise = Nothing
flattenFinalTyVar loc f ctxt tv
= -- Done, but make sure the kind is zonked
do { let knd = tyVarKind tv
; (new_knd,_kind_co) <- flatten loc f ctxt knd
; let ty = mkTyVarTy (setVarType tv new_knd)
; return (ty, mkTcReflCo ty) }
\end{code} \end{code}
Note [Non-idempotent inert substitution] Note [Non-idempotent inert substitution]
...@@ -795,11 +800,11 @@ canEq loc ev ty1 ty2 ...@@ -795,11 +800,11 @@ canEq loc ev ty1 ty2
Nothing -> return Stop Nothing -> return Stop
Just new_ev -> last_chance new_ev s1 s2 } Just new_ev -> last_chance new_ev s1 s2 }
where where
last_chance new_ev ty1 ty2 last_chance ev ty1 ty2
| Just (tc1,tys1) <- tcSplitTyConApp_maybe ty1 | Just (tc1,tys1) <- tcSplitTyConApp_maybe ty1
, Just (tc2,tys2) <- tcSplitTyConApp_maybe ty2 , Just (tc2,tys2) <- tcSplitTyConApp_maybe ty2
, isDecomposableTyCon tc1 && isDecomposableTyCon tc2 , isDecomposableTyCon tc1 && isDecomposableTyCon tc2
= canDecomposableTyConApp loc new_ev tc1 tys1 tc2 tys2 = canDecomposableTyConApp loc ev tc1 tys1 tc2 tys2
| Just (s1,t1) <- tcSplitAppTy_maybe ty1 | Just (s1,t1) <- tcSplitAppTy_maybe ty1
, Just (s2,t2) <- tcSplitAppTy_maybe ty2 , Just (s2,t2) <- tcSplitAppTy_maybe ty2
...@@ -811,7 +816,7 @@ canEq loc ev ty1 ty2 ...@@ -811,7 +816,7 @@ canEq loc ev ty1 ty2
; canEvVarsCreated loc ctevs } ; canEvVarsCreated loc ctevs }
| otherwise | otherwise
= do { emitInsoluble (CNonCanonical { cc_ev = new_ev, cc_loc = loc }) = do { emitInsoluble (CNonCanonical { cc_ev = ev, cc_loc = loc })
; return Stop } ; return Stop }
------------------------ ------------------------
...@@ -860,47 +865,25 @@ emitKindConstraint ct -- By now ct is canonical ...@@ -860,47 +865,25 @@ emitKindConstraint ct -- By now ct is canonical
_ -> continueWith ct _ -> continueWith ct
where where
emit_kind_constraint loc ev ty1 ty2 emit_kind_constraint loc _ev ty1 ty2
| compatKind k1 k2 -- True when ty1,ty2 are themselves kinds, | compatKind k1 k2 -- True when ty1,ty2 are themselves kinds,
= continueWith ct -- because then k1, k2 are BOX = continueWith ct -- because then k1, k2 are BOX
| otherwise | otherwise
= ASSERT( isKind k1 && isKind k2 ) = ASSERT( isKind k1 && isKind k2 )
do { mw <- newWantedEvVar (mkEqPred k1 k2) do { mw <- newDerived (mkEqPred k1 k2)
; kev_tm <- case mw of ; case mw of
Cached ev_tm -> return ev_tm Nothing -> return ()
Fresh kev -> do { emitWorkNC kind_co_loc [kev] Just kev -> emitWorkNC kind_co_loc [kev]
; return (ctEvTerm kev) } ; continueWith ct }
; let xcomp [x] = mkEvKindCast x (evTermCoercion kev_tm)
xcomp _ = panic "emit_kind_constraint:can't happen"
xdecomp x = [mkEvKindCast x (evTermCoercion kev_tm)]
xev = XEvTerm xcomp xdecomp
; ctevs <- xCtFlavor ev [mkTcEqPred ty1 ty2] xev
-- Important: Do not cache original as Solved since we are supposed to
-- solve /exactly/ the same constraint later! Example:
-- (alpha :: kappa0)
-- (T :: *)
-- Equality is: (alpha ~ T), so we will emitConstraint (kappa0 ~ *) but
-- we don't want to say that (alpha ~ T) is now Solved!
--
-- We do need to do this xCtFlavor so that in the case of
-- -fdefer-type-errors we still make a demand on kev_tm
; case ctevs of
[] -> return Stop
[new_ctev] -> continueWith (ct { cc_ev = new_ctev })
_ -> panic "emitKindConstraint" }
where where
k1 = typeKind ty1 k1 = typeKind ty1
k2 = typeKind ty2 k2 = typeKind ty2
ctxt = mkKindErrorCtxtTcS ty1 k1 ty2 k2
-- Always create a Wanted kind equality even if -- Always create a Wanted kind equality even if
-- you are decomposing a given constraint. -- you are decomposing a given constraint.
-- NB: DV finds this reasonable for now. Maybe we have to revisit. -- NB: DV finds this reasonable for now. Maybe we have to revisit.
kind_co_loc = pushErrCtxtSameOrigin ctxt loc kind_co_loc = setCtLocOrigin loc (KindEqOrigin ty1 ty2 (ctLocOrigin loc))
\end{code} \end{code}
Note [Make sure that insolubles are fully rewritten] Note [Make sure that insolubles are fully rewritten]
......
...@@ -126,14 +126,11 @@ report_unsolved mb_binds_var defer wanted ...@@ -126,14 +126,11 @@ report_unsolved mb_binds_var defer wanted
; let tidy_env = tidyFreeTyVars env0 free_tvs ; let tidy_env = tidyFreeTyVars env0 free_tvs
free_tvs = tyVarsOfWC wanted free_tvs = tyVarsOfWC wanted
err_ctxt = CEC { cec_encl = [] err_ctxt = CEC { cec_encl = []
, cec_insol = False
--errs_so_far || insolubleWC wanted
-- Don't report ambiguity errors if
-- there are any other solid errors
-- to report
, cec_tidy = tidy_env , cec_tidy = tidy_env
, cec_defer = defer , cec_defer = defer
, cec_suppress = False , cec_suppress = insolubleWC wanted
-- Suppress all but insolubles if there are
-- any insoulubles, or earlier errors
, cec_binds = mb_binds_var } , cec_binds = mb_binds_var }
; traceTc "reportUnsolved (after unflattening):" $ ; traceTc "reportUnsolved (after unflattening):" $
...@@ -151,9 +148,6 @@ data ReportErrCtxt ...@@ -151,9 +148,6 @@ data ReportErrCtxt
-- (innermost first) -- (innermost first)
-- ic_skols and givens are tidied, rest are not -- ic_skols and givens are tidied, rest are not
, cec_tidy :: TidyEnv , cec_tidy :: TidyEnv
, cec_insol :: Bool -- True <=> do not report errors involving
-- ambiguous errors
, cec_binds :: Maybe EvBindsVar , cec_binds :: Maybe EvBindsVar
-- Nothinng <=> Report all errors, including holes; no bindings -- Nothinng <=> Report all errors, including holes; no bindings
-- Just ev <=> make some errors (depending on cec_defer) -- Just ev <=> make some errors (depending on cec_defer)
...@@ -185,23 +179,20 @@ reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_given = given ...@@ -185,23 +179,20 @@ reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_given = given
implic' = implic { ic_skols = tvs' implic' = implic { ic_skols = tvs'
, ic_given = map (tidyEvVar env2) given , ic_given = map (tidyEvVar env2) given
, ic_info = info' } , ic_info = info' }
insoluble' = case info of
InferSkol {} -> ic_insoluble
_ -> cec_insol ctxt
ctxt' = ctxt { cec_tidy = env2 ctxt' = ctxt { cec_tidy = env2
, cec_encl = implic' : cec_encl ctxt , cec_encl = implic' : cec_encl ctxt
, cec_insol = insoluble'
, cec_binds = case cec_binds ctxt of , cec_binds = case cec_binds ctxt of
Nothing -> Nothing Nothing -> Nothing
Just {} -> Just evb } Just {} -> Just evb }
reportWanteds :: ReportErrCtxt -> WantedConstraints -> TcM () reportWanteds :: ReportErrCtxt -> WantedConstraints -> TcM ()
reportWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = implics }) reportWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = implics })
= do { reportFlats ctxt tidy_cts = do { reportFlats (ctxt { cec_suppress = False }) (mapBag (tidyCt env) insols)
; reportFlats ctxt (mapBag (tidyCt env) flats)
; mapBagM_ (reportImplic ctxt) implics } ; mapBagM_ (reportImplic ctxt) implics }
where where
env = cec_tidy ctxt env = cec_tidy ctxt
tidy_cts = mapBag (tidyCt env) (insols `unionBags` flats) -- tidy_cts = mapBag (tidyCt env) (insols `unionBags` flats)
-- All the Derived ones have been filtered out alrady -- All the Derived ones have been filtered out alrady
-- by the constraint solver. This is ok; we don't want -- by the constraint solver. This is ok; we don't want
-- to report unsolved Derived goals as error -- to report unsolved Derived goals as error
...@@ -263,14 +254,6 @@ isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of ...@@ -263,14 +254,6 @@ isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of
_ -> Nothing _ -> Nothing
----------------- -----------------
{-
reportAmbigErrs :: Reporter
reportAmbigErrs ctxt cts
| cec_insol ctxt = return ()
| otherwise = reportFlatErrs ctxt cts
-- Only report ambiguity if no other errors (at all) happened
-- See Note [Avoiding spurious errors] in TcSimplify
-}
reportFlatErrs :: Reporter reportFlatErrs :: Reporter
-- Called once for non-ambigs, once for ambigs -- Called once for non-ambigs, once for ambigs
-- Report equality errors, and others only if we've done all -- Report equality errors, and others only if we've done all
...@@ -279,12 +262,10 @@ reportFlatErrs :: Reporter ...@@ -279,12 +262,10 @@ reportFlatErrs :: Reporter
reportFlatErrs reportFlatErrs
= tryReporters = tryReporters
[ ("Equalities", is_equality, mkGroupReporter mkEqErr) ] [ ("Equalities", is_equality, mkGroupReporter mkEqErr) ]
(\ctxt cts -> do { let ctxt' | cec_insol ctxt = ctxt { cec_suppress = True } (\ctxt cts -> do { let (dicts, ips, irreds) = go cts [] [] []
| otherwise = ctxt ; mkGroupReporter mkIPErr ctxt ips
; let (dicts, ips, irreds) = go cts [] [] [] ; mkGroupReporter mkIrredErr ctxt irreds
; mkGroupReporter mkIPErr ctxt' ips ; mkGroupReporter mkDictErr ctxt dicts })
; mkGroupReporter mkIrredErr ctxt' irreds
; mkGroupReporter mkDictErr ctxt' dicts })
where where
is_equality _ (EqPred {}) = True is_equality _ (EqPred {}) = True
is_equality _ _ = False is_equality _ _ = False
...@@ -558,10 +539,11 @@ mkEqErr1 :: ReportErrCtxt -> Ct -> TcM ErrMsg ...@@ -558,10 +539,11 @@ mkEqErr1 :: ReportErrCtxt -> Ct -> TcM ErrMsg
mkEqErr1 ctxt ct mkEqErr1 ctxt ct
= do { (ctxt, binds_msg) <- relevantBindings ctxt ct = do { (ctxt, binds_msg) <- relevantBindings ctxt ct
; (ctxt, orig) <- zonkTidyOrigin ctxt orig ; (ctxt, orig) <- zonkTidyOrigin ctxt orig
; let (is_oriented, wanted_msg) = mk_wanted_extra orig
; if isGiven ev then ; if isGiven ev then
mkEqErr_help ctxt (inaccessible_msg orig $$ binds_msg) ct False ty1 ty2 mkEqErr_help ctxt (inaccessible_msg orig $$ binds_msg) ct Nothing ty1 ty2
else else
mk_err binds_msg orig } mkEqErr_help ctxt (wanted_msg $$ binds_msg) ct is_oriented ty1 ty2 }
where where
ev = cc_ev ct ev = cc_ev ct
orig = ctLocOrigin (cc_loc ct) orig = ctLocOrigin (cc_loc ct)
...@@ -572,24 +554,26 @@ mkEqErr1 ctxt ct ...@@ -572,24 +554,26 @@ mkEqErr1 ctxt ct
-- If the types in the error message are the same as the types -- If the types in the error message are the same as the types
-- we are unifying, don't add the extra expected/actual message -- we are unifying, don't add the extra expected/actual message
mk_err extra (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp })) mk_wanted_extra orig@(TypeEqOrigin {})
| act `pickyEqType` ty1 = mkExpectedActualMsg ty1 ty2 orig
, exp `pickyEqType` ty2 = mkEqErr_help ctxt extra ct True ty2 ty1
| exp `pickyEqType` ty1
, act `pickyEqType` ty2 = mkEqErr_help ctxt extra ct True ty1 ty2 mk_wanted_extra (KindEqOrigin cty1 cty2 sub_o)
| otherwise = mkEqErr_help ctxt extra1 ct False ty1 ty2 = (Nothing, msg1 $$ msg2)
where where
extra1 = msg $$ extra msg1 = hang (ptext (sLit "When matching types"))
msg = mkExpectedActualMsg exp act 2 (vcat [ ppr cty1 <+> dcolon <+> ppr (typeKind cty1)
mk_err extra _ = mkEqErr_help ctxt extra ct False ty1 ty2 , ppr cty2 <+> dcolon <+> ppr (typeKind cty2) ])
msg2 = case sub_o of
TypeEqOrigin {} -> snd (mkExpectedActualMsg cty1 cty2 sub_o)
_ -> empty
mk_wanted_extra _ = (Nothing, empty)
mkEqErr_help, reportEqErr mkEqErr_help, reportEqErr
:: ReportErrCtxt -> SDoc :: ReportErrCtxt -> SDoc
-> Ct -> Ct
-> Bool -- True <=> Types are correct way round; -> Maybe SwapFlag -- Nothing <=> not sure
-- report "expected ty1, actual ty2"
-- False <=> Just report a mismatch without orientation
-- The ReportErrCtxt has expected/actual
-> TcType -> TcType -> TcM ErrMsg -> TcType -> TcType -> TcM ErrMsg
mkEqErr_help ctxt extra ct oriented ty1 ty2 mkEqErr_help ctxt extra ct oriented ty1 ty2
| Just tv1 <- tcGetTyVar_maybe ty1 = mkTyVarEqErr ctxt extra ct oriented tv1 ty2 | Just tv1 <- tcGetTyVar_maybe ty1 = mkTyVarEqErr ctxt extra ct oriented tv1 ty2
...@@ -601,7 +585,7 @@ reportEqErr ctxt extra1 ct oriented ty1 ty2 ...@@ -601,7 +585,7 @@ reportEqErr ctxt extra1 ct oriented ty1 ty2
; mkErrorMsg ctxt' ct (vcat [ misMatchOrCND ctxt' ct oriented ty1 ty2 ; mkErrorMsg ctxt' ct (vcat [ misMatchOrCND ctxt' ct oriented ty1 ty2
, extra2, extra1]) } , extra2, extra1]) }
mkTyVarEqErr :: ReportErrCtxt -> SDoc -> Ct -> Bool -> TcTyVar -> TcType -> TcM ErrMsg mkTyVarEqErr :: ReportErrCtxt -> SDoc -> Ct -> Maybe SwapFlag -> TcTyVar -> TcType -> TcM ErrMsg
-- tv1 and ty2 are already tidied -- tv1 and ty2 are already tidied
mkTyVarEqErr ctxt extra ct oriented tv1 ty2 mkTyVarEqErr ctxt extra ct oriented tv1 ty2
-- Occurs check -- Occurs check
...@@ -697,7 +681,7 @@ isUserSkolem ctxt tv ...@@ -697,7 +681,7 @@ isUserSkolem ctxt tv
is_user_skol_info (InferSkol {}) = False is_user_skol_info (InferSkol {}) = False
is_user_skol_info _ = True is_user_skol_info _ = True
misMatchOrCND :: ReportErrCtxt -> Ct -> Bool -> TcType -> TcType -> SDoc misMatchOrCND :: ReportErrCtxt -> Ct -> Maybe SwapFlag -> TcType -> TcType -> SDoc
-- If oriented then ty1 is expected, ty2 is actual -- If oriented then ty1 is expected, ty2 is actual
misMatchOrCND ctxt ct oriented ty1 ty2 misMatchOrCND ctxt ct oriented ty1 ty2
| null givens || | null givens ||
...@@ -710,7 +694,7 @@ misMatchOrCND ctxt ct oriented ty1 ty2 ...@@ -710,7 +694,7 @@ misMatchOrCND ctxt ct oriented ty1 ty2
= couldNotDeduce givens ([mkEqPred ty1 ty2], orig) = couldNotDeduce givens ([mkEqPred ty1 ty2], orig)
where where
givens = getUserGivens ctxt givens = getUserGivens ctxt
orig = TypeEqOrigin (UnifyOrigin ty1 ty2) orig = TypeEqOrigin ty1 ty2
couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> SDoc couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> SDoc
couldNotDeduce givens (wanteds, orig) couldNotDeduce givens (wanteds, orig)
...@@ -763,10 +747,12 @@ kindErrorMsg ty1 ty2 ...@@ -763,10 +747,12 @@ kindErrorMsg ty1 ty2
k2 = typeKind ty2 k2 = typeKind ty2
-------------------- --------------------
misMatchMsg :: Bool -> TcType -> TcType -> SDoc -- Types are already tidy misMatchMsg :: Maybe SwapFlag -> TcType -> TcType -> SDoc -- Types are already tidy
-- If oriented then ty1 is expected, ty2 is actual -- If oriented then ty1 is expected, ty2 is actual
misMatchMsg oriented ty1 ty2 misMatchMsg oriented ty1 ty2
| oriented | Just IsSwapped <- oriented
= misMatchMsg (Just NotSwapped) ty2 ty1
| Just NotSwapped <- oriented
= sep [ ptext (sLit "Couldn't match expected") <+> what <+> quotes (ppr ty1) = sep [ ptext (sLit "Couldn't match expected") <+> what <+> quotes (ppr ty1)
, nest 12 $ ptext (sLit "with actual") <+> what <+> quotes (ppr ty2) ] , nest 12 $ ptext (sLit "with actual") <+> what <+> quotes (ppr ty2) ]
| otherwise | otherwise
...@@ -776,10 +762,16 @@ misMatchMsg oriented ty1 ty2 ...@@ -776,10 +762,16 @@ misMatchMsg oriented ty1 ty2
what | isKind ty1 = ptext (sLit "kind") what | isKind ty1 = ptext (sLit "kind")
| otherwise = ptext (sLit "type") | otherwise = ptext (sLit "type")
mkExpectedActualMsg :: Type -> Type -> SDoc mkExpectedActualMsg :: Type -> Type -> CtOrigin -> (Maybe SwapFlag, SDoc)
mkExpectedActualMsg exp_ty act_ty mkExpectedActualMsg ty1 ty2 (TypeEqOrigin { uo_actual = act, uo_expected = exp })
= vcat [ text "Expected type:" <+> ppr exp_ty | act `pickyEqType` ty1, exp `pickyEqType` ty2 = (Just IsSwapped, empty)
, text " Actual type:" <+> ppr act_ty ] | exp `pickyEqType` ty1, act `pickyEqType` ty2 = (Just NotSwapped, empty)
| otherwise = (Nothing, msg)
where
msg = vcat [ text "Expected type:" <+> ppr exp
, text " Actual type:" <+> ppr act ]
mkExpectedActualMsg _ _ _ = panic "mkExprectedAcutalMsg"
\end{code} \end{code}
Note [Reporting occurs-check errors] Note [Reporting occurs-check errors]
...@@ -874,7 +866,7 @@ mk_dict_err ctxt (ct, (matches, unifiers, safe_haskell)) ...@@ -874,7 +866,7 @@ mk_dict_err ctxt (ct, (matches, unifiers, safe_haskell))
cannot_resolve_msg has_ambig_tvs binds_msg ambig_msg cannot_resolve_msg has_ambig_tvs binds_msg ambig_msg
= vcat [ addArising orig (no_inst_herald <+> pprParendType pred) = vcat [ addArising orig (no_inst_herald <+> pprParendType pred)
, vcat (pp_givens givens) , vcat (pp_givens givens)
, if (has_ambig_tvs && all_tyvars) , if (has_ambig_tvs && not (null unifiers && null givens))
then vcat [ ambig_msg, binds_msg, potential_msg ] then vcat [ ambig_msg, binds_msg, potential_msg ]
else empty else empty
, show_fixes (add_to_ctxt_fixes has_ambig_tvs ++ drv_fixes) ] , show_fixes (add_to_ctxt_fixes has_ambig_tvs ++ drv_fixes) ]
...@@ -1232,10 +1224,15 @@ zonkTidyOrigin ctxt (GivenOrigin skol_info) ...@@ -1232,10 +1224,15 @@ zonkTidyOrigin ctxt (GivenOrigin skol_info)
= do { skol_info1 <- zonkSkolemInfo skol_info = do { skol_info1 <- zonkSkolemInfo skol_info
; let (env1, skol_info2) = tidySkolemInfo (cec_tidy ctxt) skol_info1 ; let (env1, skol_info2) = tidySkolemInfo (cec_tidy ctxt) skol_info1
; return (ctxt { cec_tidy = env1 }, GivenOrigin skol_info2) } ; return (ctxt { cec_tidy = env1 }, GivenOrigin skol_info2) }
zonkTidyOrigin ctxt (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp })) zonkTidyOrigin ctxt (TypeEqOrigin { uo_actual = act, uo_expected = exp })
= do { (env1, act') <- zonkTidyTcType (cec_tidy ctxt) act = do { (env1, act') <- zonkTidyTcType (cec_tidy ctxt) act
; (env2, exp') <- zonkTidyTcType env1 exp ; (env2, exp') <- zonkTidyTcType env1 exp
; return ( ctxt { cec_tidy = env2 } ; return ( ctxt { cec_tidy = env2 }
, TypeEqOrigin (UnifyOrigin { uo_actual = act', uo_expected = exp' })) } , TypeEqOrigin { uo_actual = act', uo_expected = exp' }) }
zonkTidyOrigin ctxt (KindEqOrigin ty1 ty2 orig)
= do { (env1, ty1') <- zonkTidyTcType (cec_tidy ctxt) ty1
; (env2, ty2') <- zonkTidyTcType env1 ty2
; (ctxt2, orig') <- zonkTidyOrigin (ctxt { cec_tidy = env2 }) orig
; return (ctxt2, KindEqOrigin ty1' ty2' orig') }
zonkTidyOrigin ctxt orig = return (ctxt, orig) zonkTidyOrigin ctxt orig = return (ctxt, orig)
\end{code} \end{code}
...@@ -16,7 +16,7 @@ module TcEvidence ( ...@@ -16,7 +16,7 @@ module TcEvidence (
EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds, EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds,
EvTerm(..), mkEvCast, evVarsOfTerm, mkEvKindCast, EvTerm(..), mkEvCast, evVarsOfTerm,
EvLit(..), evTermCoercion, EvLit(..), evTermCoercion,
-- TcCoercion -- TcCoercion
...@@ -483,8 +483,6 @@ data EvTerm ...@@ -483,8 +483,6 @@ data EvTerm
-- dictionaries, even though the former have no -- dictionaries, even though the former have no
-- selector Id. We count up from _0_ -- selector Id. We count up from _0_
| EvKindCast EvTerm TcCoercion -- See Note [EvKindCast]
| EvLit EvLit -- Dictionary for class "SingI" for type lits. | EvLit EvLit -- Dictionary for class "SingI" for type lits.
-- Note [EvLit] -- Note [EvLit]
...@@ -521,19 +519,6 @@ and the constraint ...@@ -521,19 +519,6 @@ and the constraint
[G] g1 :: a~Bool [G] g1 :: a~Bool
See Trac [7238] See Trac [7238]
Note [EvKindCast]
~~~~~~~~~~~~~~~~~
EvKindCast g kco is produced when we have a constraint (g : s1 ~ s2)
but the kinds of s1 and s2 (k1 and k2 respectively) don't match but
are rather equal by a coercion. You may think that this coercion will
always turn out to be ReflCo, so why is this needed? Because sometimes
we will want to defer kind errors until the runtime and in these cases
that coercion will be an 'error' term, which we want to evaluate rather
than silently forget about!
The relevant (and only) place where such a coercion is produced in
the simplifier is in TcCanonical.emitKindConstraint.
Note [EvBinds/EvTerm] Note [EvBinds/EvTerm]
~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~
How evidence is created and updated. Bindings for dictionaries, How evidence is created and updated. Bindings for dictionaries,
...@@ -595,11 +580,6 @@ mkEvCast ev lco ...@@ -595,11 +580,6 @@ mkEvCast ev lco
| isTcReflCo lco = ev | isTcReflCo lco = ev
| otherwise = EvCast ev lco | otherwise = EvCast ev lco
mkEvKindCast :: EvTerm -> TcCoercion -> EvTerm
mkEvKindCast ev lco
| isTcReflCo lco = ev
| otherwise = EvKindCast ev lco
emptyTcEvBinds :: TcEvBinds emptyTcEvBinds :: TcEvBinds
emptyTcEvBinds = EvBinds emptyBag emptyTcEvBinds = EvBinds emptyBag
...@@ -625,7 +605,6 @@ evVarsOfTerm (EvSuperClass v _) = evVarsOfTerm v ...@@ -625,7 +605,6 @@ evVarsOfTerm (EvSuperClass v _) = evVarsOfTerm v
evVarsOfTerm (EvCast tm co) = evVarsOfTerm tm `unionVarSet` coVarsOfTcCo co evVarsOfTerm (EvCast tm co) = evVarsOfTerm tm `unionVarSet` coVarsOfTcCo co
evVarsOfTerm (EvTupleMk evs) = evVarsOfTerms evs evVarsOfTerm (EvTupleMk evs) = evVarsOfTerms evs
evVarsOfTerm (EvDelayedError _ _) = emptyVarSet evVarsOfTerm (EvDelayedError _ _) = emptyVarSet
evVarsOfTerm (EvKindCast v co) = coVarsOfTcCo co `unionVarSet` evVarsOfTerm v
evVarsOfTerm (EvLit _) = emptyVarSet evVarsOfTerm (EvLit _) = emptyVarSet
evVarsOfTerms :: [EvTerm] -> VarSet evVarsOfTerms :: [EvTerm] -> VarSet
...@@ -683,7 +662,6 @@ instance Outputable EvBind where ...@@ -683,7 +662,6 @@ instance Outputable EvBind where
instance Outputable EvTerm where instance Outputable EvTerm where
ppr (EvId v) = ppr v ppr (EvId v) = ppr v
ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendTcCo co ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendTcCo co
ppr (EvKindCast v co) = ppr v <+> (ptext (sLit "`kind-cast`")) <+> pprParendTcCo co
ppr (EvCoercion co) = ptext (sLit "CO") <+> ppr co ppr (EvCoercion co) = ptext (sLit "CO") <+> ppr co
ppr (EvTupleSel v n) = ptext (sLit "tupsel") <> parens (ppr (v,n)) ppr (EvTupleSel v n) = ptext (sLit "tupsel") <> parens (ppr (v,n))
ppr (EvTupleMk vs) = ptext (sLit "tupmk") <+> ppr vs ppr (EvTupleMk vs) = ptext (sLit "tupmk") <+> ppr vs
......
...@@ -1117,11 +1117,6 @@ zonkEvTerm env (EvCoercion co) = do { co' <- zonkTcLCoToLCo env co ...@@ -1117,11 +1117,6 @@ zonkEvTerm env (EvCoercion co) = do { co' <- zonkTcLCoToLCo env co
zonkEvTerm env (EvCast tm co) = do { tm' <- zonkEvTerm env tm zonkEvTerm env (EvCast tm co) = do { tm' <- zonkEvTerm env tm
; co' <- zonkTcLCoToLCo env co ; co' <- zonkTcLCoToLCo env co
; return (mkEvCast tm' co') } ; return (mkEvCast tm' co') }