Commit e9e413ec authored by Joachim Breitner's avatar Joachim Breitner
Browse files

Large refactor: Move CtLoc field from Ct to CtEvidence

parent b6b5c417
......@@ -83,7 +83,8 @@ emitWanted :: CtOrigin -> TcPredType -> TcM EvVar
emitWanted origin pred
= do { loc <- getCtLoc origin
; ev <- newWantedEvVar pred
; emitFlat (mkNonCanonical loc (CtWanted { ctev_pred = pred, ctev_evar = ev }))
; emitFlat $ mkNonCanonical $
CtWanted { ctev_pred = pred, ctev_evar = ev, ctev_loc = loc }
; return ev }
newMethodFromName :: CtOrigin -> Name -> TcRhoType -> TcM (HsExpr TcId)
......@@ -568,8 +569,7 @@ tidyCt env ct
= case ct of
CHoleCan { cc_ev = ev }
-> ct { cc_ev = tidy_ev env ev }
_ -> CNonCanonical { cc_ev = tidy_ev env (cc_ev ct)
, cc_loc = cc_loc ct }
_ -> mkNonCanonical (tidy_ev env (ctEvidence ct))
where
tidy_ev :: TidyEnv -> CtEvidence -> CtEvidence
-- NB: we do not tidy the ctev_evtm/var field because we don't
......
This diff is collapsed.
......@@ -337,7 +337,7 @@ mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg)
mkGroupReporter mk_err ctxt cts
= mapM_ (reportGroup mk_err ctxt) (equivClasses cmp_loc cts)
where
cmp_loc ct1 ct2 = ctLocSpan (cc_loc ct1) `compare` ctLocSpan (cc_loc ct2)
cmp_loc ct1 ct2 = ctLocSpan (ctev_loc (ctEvidence ct1)) `compare` ctLocSpan (ctev_loc (ctEvidence ct2))
reportGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> ReportErrCtxt
-> [Ct] -> TcM ()
......@@ -361,7 +361,7 @@ maybeReportError ctxt err
maybeAddDeferredBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
-- See Note [Deferring coercion errors to runtime]
maybeAddDeferredBinding ctxt err ct
| CtWanted { ctev_pred = pred, ctev_evar = ev_id } <- cc_ev ct
| CtWanted { ctev_pred = pred, ctev_evar = ev_id } <- ctEvidence ct
-- Only add deferred bindings for Wanted constraints
, isHoleCt ct || cec_defer ctxt -- And it's a hole or we have -fdefer-type-errors
, Just ev_binds_var <- cec_binds ctxt -- We have somewhere to put the bindings
......@@ -418,13 +418,13 @@ pprWithArising (ct:cts)
| otherwise
= (loc, vcat (map ppr_one (ct:cts)))
where
loc = cc_loc ct
loc = ctev_loc (ctEvidence ct)
ppr_one ct = hang (parens (pprType (ctPred ct)))
2 (pprArisingAt (cc_loc ct))
2 (pprArisingAt (ctev_loc (ctEvidence ct)))
mkErrorMsg :: ReportErrCtxt -> Ct -> SDoc -> TcM ErrMsg
mkErrorMsg ctxt ct msg
= do { let tcl_env = ctLocEnv (cc_loc ct)
= do { let tcl_env = ctLocEnv (ctev_loc (ctEvidence ct))
; err_info <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env)
; mkLongErrAt (tcl_loc tcl_env) msg err_info }
......@@ -518,7 +518,7 @@ mkIrredErr ctxt cts
; mkErrorMsg ctxt ct1 (msg $$ binds_msg) }
where
(ct1:_) = cts
orig = ctLocOrigin (cc_loc ct1)
orig = ctLocOrigin (ctev_loc (ctEvidence ct1))
givens = getUserGivens ctxt
msg = couldNotDeduce givens (map ctPred cts, orig)
......@@ -528,7 +528,7 @@ mkHoleError ctxt ct@(CHoleCan { cc_occ = occ })
= do { let tyvars = varSetElems (tyVarsOfCt ct)
tyvars_msg = map loc_msg tyvars
msg = vcat [ hang (ptext (sLit "Found hole") <+> quotes (ppr occ))
2 (ptext (sLit "with type:") <+> pprType (ctEvPred (cc_ev ct)))
2 (ptext (sLit "with type:") <+> pprType (ctEvPred (ctEvidence ct)))
, ppUnless (null tyvars_msg) (ptext (sLit "Where:") <+> vcat tyvars_msg) ]
; (ctxt, binds_doc) <- relevantBindings False ctxt ct
-- The 'False' means "don't filter the bindings; see Trac #8191
......@@ -551,7 +551,7 @@ mkIPErr ctxt cts
; mkErrorMsg ctxt ct1 (msg $$ bind_msg) }
where
(ct1:_) = cts
orig = ctLocOrigin (cc_loc ct1)
orig = ctLocOrigin (ctev_loc (ctEvidence ct1))
preds = map ctPred cts
givens = getUserGivens ctxt
msg | null givens
......@@ -602,25 +602,26 @@ mkEqErr1 ctxt ct
; let (given_loc, given_msg) = mk_given (cec_encl ctxt)
; dflags <- getDynFlags
; mkEqErr_help dflags ctxt (given_msg $$ binds_msg)
(ct { cc_loc = given_loc}) -- Note [Inaccessible code]
(ct { cc_ev = ev {ctev_loc = given_loc}}) -- Note [Inaccessible code]
Nothing ty1 ty2 }
| otherwise -- Wanted or derived
= do { (ctxt, binds_msg) <- relevantBindings True ctxt ct
; (ctxt, tidy_orig) <- zonkTidyOrigin ctxt (ctLocOrigin (cc_loc ct))
; (ctxt, tidy_orig) <- zonkTidyOrigin ctxt (ctLocOrigin loc)
; let (is_oriented, wanted_msg) = mk_wanted_extra tidy_orig
; dflags <- getDynFlags
; mkEqErr_help dflags ctxt (wanted_msg $$ binds_msg)
ct is_oriented ty1 ty2 }
where
ev = cc_ev ct
ev = ctEvidence ct
loc = ctev_loc ev
(ty1, ty2) = getEqPredTys (ctEvPred ev)
mk_given :: [Implication] -> (CtLoc, SDoc)
-- For given constraints we overwrite the env (and hence src-loc)
-- with one from the implication. See Note [Inaccessible code]
mk_given [] = (cc_loc ct, empty)
mk_given (implic : _) = (setCtLocEnv (cc_loc ct) (ic_env implic)
mk_given [] = (loc, empty)
mk_given (implic : _) = (setCtLocEnv loc (ic_env implic)
, hang (ptext (sLit "Inaccessible code in"))
2 (ppr (ic_info implic)))
......@@ -993,7 +994,7 @@ mk_dict_err ctxt (ct, (matches, unifiers, safe_haskell))
| otherwise
= return (ctxt, safe_haskell_msg)
where
orig = ctLocOrigin (cc_loc ct)
orig = ctLocOrigin (ctev_loc (ctEvidence ct))
pred = ctPred ct
(clas, tys) = getClassPredTys pred
ispecs = [ispec | (ispec, _) <- matches]
......@@ -1324,7 +1325,7 @@ relevantBindings want_filtering ctxt ct
else do { traceTc "rb" doc
; return (ctxt { cec_tidy = tidy_env' }, doc) } }
where
lcl_env = ctLocEnv (cc_loc ct)
lcl_env = ctLocEnv (ctev_loc (ctEvidence ct))
ct_tvs = tyVarsOfCt ct
run_out :: Maybe Int -> Bool
......@@ -1396,16 +1397,16 @@ are created by in RtClosureInspect.zonkRTTIType.
%************************************************************************
\begin{code}
solverDepthErrorTcS :: SubGoalCounter -> Ct -> TcM a
solverDepthErrorTcS cnt ct
solverDepthErrorTcS :: SubGoalCounter -> CtEvidence -> TcM a
solverDepthErrorTcS cnt ev
= setCtLoc loc $
do { pred <- zonkTcType (ctPred ct)
do { pred <- zonkTcType (ctEvPred ev)
; env0 <- tcInitTidyEnv
; let tidy_env = tidyFreeTyVars env0 (tyVarsOfType pred)
tidy_pred = tidyType tidy_env pred
; failWithTcM (tidy_env, hang (msg cnt) 2 (ppr tidy_pred)) }
where
loc = cc_loc ct
loc = ctev_loc ev
depth = ctLocDepth loc
value = subGoalCounterValue cnt depth
msg CountConstraints =
......
......@@ -137,7 +137,7 @@ tcHole occ res_ty
; name <- newSysName occ
; let ev = mkLocalId name ty
; loc <- getCtLoc HoleOrigin
; let can = CHoleCan { cc_ev = CtWanted ty ev, cc_loc = loc, cc_occ = occ }
; let can = CHoleCan { cc_ev = CtWanted ty ev loc, cc_occ = occ }
; emitInsoluble can
; tcWrapResult (HsVar ev) ty res_ty }
\end{code}
......
......@@ -95,12 +95,14 @@ solveInteractGiven loc fsks givens
-- See Note [Do not decompose given polytype equalities]
-- in TcCanonical
where
given_bag = listToBag [ mkNonCanonical loc $ CtGiven { ctev_evtm = EvId ev_id
, ctev_pred = evVarPred ev_id }
given_bag = listToBag [ mkNonCanonical $ CtGiven { ctev_evtm = EvId ev_id
, ctev_pred = evVarPred ev_id
, ctev_loc = loc }
| ev_id <- givens ]
fsk_bag = listToBag [ mkNonCanonical loc $ CtGiven { ctev_evtm = EvCoercion (mkTcReflCo tv_ty)
, ctev_pred = pred }
fsk_bag = listToBag [ mkNonCanonical $ CtGiven { ctev_evtm = EvCoercion (mkTcReflCo tv_ty)
, ctev_pred = pred
, ctev_loc = loc }
| tv <- fsks
, let FlatSkol fam_ty = tcTyVarDetails tv
tv_ty = mkTyVarTy tv
......@@ -125,7 +127,7 @@ solveInteract cts
NoWorkRemaining -- Done, successfuly (modulo frozen)
-> return ()
MaxDepthExceeded cnt ct -- Failure, depth exceeded
-> wrapErrTcS $ solverDepthErrorTcS cnt ct
-> wrapErrTcS $ solverDepthErrorTcS cnt (ctEvidence ct)
NextWorkItem ct -- More work, loop around!
-> do { runSolverPipeline thePipeline ct; solve_loop max_depth } }
......@@ -151,7 +153,7 @@ selectNextWorkItem max_depth
(Nothing,_)
-> (NoWorkRemaining,wl) -- No more work
(Just ct, new_wl)
| Just cnt <- subGoalDepthExceeded max_depth (ctLocDepth (cc_loc ct)) -- Depth exceeded
| Just cnt <- subGoalDepthExceeded max_depth (ctLocDepth (ctev_loc (ctEvidence ct))) -- Depth exceeded
-> (MaxDepthExceeded cnt ct,new_wl)
(Just ct, new_wl)
-> (NextWorkItem ct, new_wl) -- New workitem and worklist
......@@ -408,8 +410,9 @@ interactGivenIP _ wi = pprPanic "interactGivenIP" (ppr wi)
addFunDepWork :: Ct -> Ct -> TcS ()
addFunDepWork work_ct inert_ct
= do { let work_loc = cc_loc work_ct
inert_pred_loc = (ctPred inert_ct, pprArisingAt (cc_loc inert_ct))
= do { let work_loc = ctev_loc (ctEvidence work_ct)
inert_loc = ctev_loc (ctEvidence inert_ct)
inert_pred_loc = (ctPred inert_ct, pprArisingAt inert_loc)
work_item_pred_loc = (ctPred work_ct, pprArisingAt work_loc)
; let fd_eqns = improveFromAnother inert_pred_loc work_item_pred_loc
......@@ -489,13 +492,13 @@ I can think of two ways to fix this:
\begin{code}
interactFunEq :: InertCans -> Ct -> TcS (Maybe InertCans, StopNowFlag)
interactFunEq inerts workItem@(CFunEqCan { cc_ev = ev, cc_fun = tc
, cc_tyargs = args, cc_rhs = rhs, cc_loc = loc })
, cc_tyargs = args, cc_rhs = rhs })
| (CFunEqCan { cc_ev = ev_i, cc_rhs = rhs_i } : _) <- matching_inerts
, ev_i `canRewrite` ev
= do { traceTcS "interact with inerts: FunEq/FunEq" $
vcat [ text "workItem =" <+> ppr workItem
, text "inertItem=" <+> ppr ev_i ]
; solveFunEq loc ev_i rhs_i ev rhs
; solveFunEq ev_i rhs_i ev rhs
; return (Nothing, True) }
| (ev_i : _) <- [ ev_i | CFunEqCan { cc_ev = ev_i, cc_rhs = rhs_i } <- matching_inerts
......@@ -507,15 +510,15 @@ interactFunEq inerts workItem@(CFunEqCan { cc_ev = ev, cc_fun = tc
| eq_is@(eq_i : _) <- matching_inerts
, ev `canRewrite` ctEvidence eq_i -- This is unusual
= do { let solve (CFunEqCan { cc_ev = ev_i, cc_rhs = rhs_i })
= solveFunEq loc ev rhs ev_i rhs_i
= solveFunEq ev rhs ev_i rhs_i
solve ct = pprPanic "interactFunEq" (ppr ct)
; mapM_ solve eq_is
; return (Just (inerts { inert_funeqs = replaceFunEqs funeqs tc args workItem }), True) }
| (CFunEqCan { cc_rhs = rhs_i } : _) <- matching_inerts
= do { mb <- newDerived (mkTcEqPred rhs_i rhs)
= do { mb <- newDerived loc (mkTcEqPred rhs_i rhs)
; case mb of
Just x -> updWorkListTcS (extendWorkListEq (mkNonCanonical loc x))
Just x -> updWorkListTcS (extendWorkListEq (mkNonCanonical x))
Nothing -> return ()
; return (Nothing, False) }
......@@ -524,13 +527,13 @@ interactFunEq inerts workItem@(CFunEqCan { cc_ev = ev, cc_fun = tc
; traceTcS "builtInCandidates: " $ ppr is
; let interact = sfInteractInert ops args rhs
; impMbs <- sequence
[ do mb <- newDerived (mkTcEqPred lhs_ty rhs_ty)
[ do mb <- newDerived (ctev_loc iev) (mkTcEqPred lhs_ty rhs_ty)
case mb of
Just x -> return $ Just $ mkNonCanonical d x
Just x -> return $ Just $ mkNonCanonical x
Nothing -> return Nothing
| CFunEqCan { cc_tyargs = iargs
, cc_rhs = ixi
, cc_loc = d } <- is
, cc_ev = iev } <- is
, Pair lhs_ty rhs_ty <- interact iargs ixi
]
; let imps = catMaybes impMbs
......@@ -542,22 +545,22 @@ interactFunEq inerts workItem@(CFunEqCan { cc_ev = ev, cc_fun = tc
where
funeqs = inert_funeqs inerts
matching_inerts = findFunEqs funeqs tc args
loc = ctev_loc ev
interactFunEq _ wi = pprPanic "interactFunEq" (ppr wi)
solveFunEq :: CtLoc
-> CtEvidence -- From this :: F tys ~ xi1
solveFunEq :: CtEvidence -- From this :: F tys ~ xi1
-> Type
-> CtEvidence -- Solve this :: F tys ~ xi2
-> Type
-> TcS ()
solveFunEq loc from_this xi1 solve_this xi2
solveFunEq from_this xi1 solve_this xi2
= do { ctevs <- xCtFlavor solve_this [mkTcEqPred xi2 xi1] xev
-- No caching! See Note [Cache-caused loops]
-- Why not (mkTcEqPred xi1 xi2)? See Note [Efficient orientation]
; emitWorkNC loc ctevs }
; emitWorkNC ctevs }
where
from_this_co = evTermCoercion $ ctEvTerm from_this
......@@ -664,8 +667,7 @@ test when solving pairwise CFunEqCan.
\begin{code}
interactTyVarEq :: InertCans -> Ct -> TcS (Maybe InertCans, StopNowFlag)
-- CTyEqCans are always consumed, returning Stop
interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv, cc_rhs = rhs
, cc_ev = ev, cc_loc = loc })
interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv, cc_rhs = rhs , cc_ev = ev })
| (ev_i : _) <- [ ev_i | CTyEqCan { cc_ev = ev_i, cc_rhs = rhs_i }
<- findTyEqs (inert_eqs inerts) tv
, ev_i `canRewriteOrSame` ev
......@@ -689,7 +691,7 @@ interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv, cc_rhs = rhs
; return (Nothing, True) }
| otherwise
= do { mb_solved <- trySpontaneousSolve ev tv rhs loc
= do { mb_solved <- trySpontaneousSolve ev tv rhs
; case mb_solved of
SPCantSolve -- Includes givens
-> do { untch <- getUntouchables
......@@ -716,7 +718,8 @@ interactTyVarEq _ wi = pprPanic "interactTyVarEq" (ppr wi)
givenFlavour :: CtEvidence
-- Used just to pass to kickOutRewritable
givenFlavour = CtGiven { ctev_pred = panic "givenFlavour:ev"
, ctev_evtm = panic "givenFlavour:tm" }
, ctev_evtm = panic "givenFlavour:tm"
, ctev_loc = panic "givenFlavour:loc" }
ppr_kicked :: Int -> SDoc
ppr_kicked 0 = empty
......@@ -893,8 +896,8 @@ data SPSolveResult = SPCantSolve
-- @trySpontaneousSolve wi@ solves equalities where one side is a
-- touchable unification variable.
trySpontaneousSolve :: CtEvidence -> TcTyVar -> Xi -> CtLoc -> TcS SPSolveResult
trySpontaneousSolve gw tv1 xi d
trySpontaneousSolve :: CtEvidence -> TcTyVar -> Xi -> TcS SPSolveResult
trySpontaneousSolve gw tv1 xi
| isGiven gw -- See Note [Touchables and givens]
= return SPCantSolve
......@@ -902,36 +905,34 @@ trySpontaneousSolve gw tv1 xi d
= do { tch1 <- isTouchableMetaTyVarTcS tv1
; tch2 <- isTouchableMetaTyVarTcS tv2
; case (tch1, tch2) of
(True, True) -> trySpontaneousEqTwoWay d gw tv1 tv2
(True, False) -> trySpontaneousEqOneWay d gw tv1 xi
(False, True) -> trySpontaneousEqOneWay d gw tv2 (mkTyVarTy tv1)
(True, True) -> trySpontaneousEqTwoWay gw tv1 tv2
(True, False) -> trySpontaneousEqOneWay gw tv1 xi
(False, True) -> trySpontaneousEqOneWay gw tv2 (mkTyVarTy tv1)
_ -> return SPCantSolve }
| otherwise
= do { tch1 <- isTouchableMetaTyVarTcS tv1
; if tch1 then trySpontaneousEqOneWay d gw tv1 xi
; if tch1 then trySpontaneousEqOneWay gw tv1 xi
else return SPCantSolve }
----------------
trySpontaneousEqOneWay :: CtLoc -> CtEvidence
-> TcTyVar -> Xi -> TcS SPSolveResult
trySpontaneousEqOneWay :: CtEvidence -> TcTyVar -> Xi -> TcS SPSolveResult
-- tv is a MetaTyVar, not untouchable
trySpontaneousEqOneWay d gw tv xi
trySpontaneousEqOneWay gw tv xi
| not (isSigTyVar tv) || isTyVarTy xi
, typeKind xi `tcIsSubKind` tyVarKind tv
= solveWithIdentity d gw tv xi
= solveWithIdentity gw tv xi
| otherwise -- Still can't solve, sig tyvar and non-variable rhs
= return SPCantSolve
----------------
trySpontaneousEqTwoWay :: CtLoc -> CtEvidence
-> TcTyVar -> TcTyVar -> TcS SPSolveResult
trySpontaneousEqTwoWay :: CtEvidence -> TcTyVar -> TcTyVar -> TcS SPSolveResult
-- Both tyvars are *touchable* MetaTyvars so there is only a chance for kind error here
trySpontaneousEqTwoWay d gw tv1 tv2
trySpontaneousEqTwoWay gw tv1 tv2
| k1 `tcIsSubKind` k2 && nicer_to_update_tv2
= solveWithIdentity d gw tv2 (mkTyVarTy tv1)
= solveWithIdentity gw tv2 (mkTyVarTy tv1)
| k2 `tcIsSubKind` k1
= solveWithIdentity d gw tv1 (mkTyVarTy tv2)
= solveWithIdentity gw tv1 (mkTyVarTy tv2)
| otherwise
= return SPCantSolve
where
......@@ -959,7 +960,7 @@ double unifications is the main reason we disallow touchable
unification variables as RHS of type family equations: F xis ~ alpha.
\begin{code}
solveWithIdentity :: CtLoc -> CtEvidence -> TcTyVar -> Xi -> TcS SPSolveResult
solveWithIdentity :: CtEvidence -> TcTyVar -> Xi -> TcS SPSolveResult
-- Solve with the identity coercion
-- Precondition: kind(xi) is a sub-kind of kind(tv)
-- Precondition: CtEvidence is Wanted or Derived
......@@ -972,7 +973,7 @@ solveWithIdentity :: CtLoc -> CtEvidence -> TcTyVar -> Xi -> TcS SPSolveResult
-- arises from a CTyEqCan, a *canonical* constraint. Its invariants
-- say that in (a ~ xi), the type variable a does not appear in xi.
-- See TcRnTypes.Ct invariants.
solveWithIdentity _d wd tv xi
solveWithIdentity wd tv xi
= do { let tv_ty = mkTyVarTy tv
; traceTcS "Sneaky unification:" $
vcat [text "Unifies:" <+> ppr tv <+> ptext (sLit ":=") <+> ppr xi,
......@@ -1361,9 +1362,9 @@ instFunDepEqn loc (FDEqn { fd_qtvs = tvs, fd_eqs = eqs
| tcEqType sty1 sty2
= return ievs -- Return no trivial equalities
| otherwise
= do { mb_eqv <- newDerived (mkTcEqPred sty1 sty2)
= do { mb_eqv <- newDerived der_loc (mkTcEqPred sty1 sty2)
; case mb_eqv of
Just ev -> return (mkNonCanonical der_loc ev : ievs)
Just ev -> return (mkNonCanonical (ev {ctev_loc = der_loc}) : ievs)
Nothing -> return ievs }
-- We are eventually going to emit FD work back in the work list so
-- it is important that we only return the /freshly created/ and not
......@@ -1425,22 +1426,19 @@ doTopReact :: InertSet -> WorkItem -> TcS TopInteractResult
doTopReact inerts workItem
= do { traceTcS "doTopReact" (ppr workItem)
; case workItem of
CDictCan { cc_ev = fl, cc_class = cls, cc_tyargs = xis
, cc_loc = d }
-> doTopReactDict inerts fl cls xis d
CDictCan { cc_ev = fl, cc_class = cls, cc_tyargs = xis }
-> doTopReactDict inerts fl cls xis
CFunEqCan { cc_ev = fl, cc_fun = tc, cc_tyargs = args
, cc_rhs = xi, cc_loc = d }
-> doTopReactFunEq workItem fl tc args xi d
CFunEqCan { cc_ev = fl, cc_fun = tc, cc_tyargs = args , cc_rhs = xi }
-> doTopReactFunEq workItem fl tc args xi
_ -> -- Any other work item does not react with any top-level equations
return NoTopInt }
--------------------
doTopReactDict :: InertSet -> CtEvidence -> Class -> [Xi]
-> CtLoc -> TcS TopInteractResult
doTopReactDict :: InertSet -> CtEvidence -> Class -> [Xi] -> TcS TopInteractResult
-- Try to use type-class instance declarations to simplify the constraint
doTopReactDict inerts fl cls xis loc
doTopReactDict inerts fl cls xis
| not (isWanted fl) -- Never use instances for Given or Derived constraints
= try_fundeps_and_return
......@@ -1459,6 +1457,7 @@ doTopReactDict inerts fl cls xis loc
arising_sdoc = pprArisingAt loc
dict_id = ctEvId fl
pred = mkClassPred cls xis
loc = ctev_loc fl
solve_from_instance :: [CtEvidence] -> EvTerm -> TcS TopInteractResult
-- Precondition: evidence term matches the predicate workItem
......@@ -1475,8 +1474,7 @@ doTopReactDict inerts fl cls xis loc
ppr dict_id
; setEvBind dict_id ev_term
; let mk_new_wanted ev
= CNonCanonical { cc_ev = ev
, cc_loc = bumpCtLocDepth CountConstraints loc }
= mkNonCanonical (ev {ctev_loc = bumpCtLocDepth CountConstraints loc })
; updWorkListTcS (extendWorkListCts (map mk_new_wanted evs))
; return $
SomeTopInt { tir_rule = "Dict/Top (solved, more work)"
......@@ -1495,9 +1493,8 @@ doTopReactDict inerts fl cls xis loc
; return NoTopInt }
--------------------
doTopReactFunEq :: Ct -> CtEvidence -> TyCon -> [Xi] -> Xi
-> CtLoc -> TcS TopInteractResult
doTopReactFunEq _ct fl fun_tc args xi loc
doTopReactFunEq :: Ct -> CtEvidence -> TyCon -> [Xi] -> Xi -> TcS TopInteractResult
doTopReactFunEq _ct fl fun_tc args xi
= ASSERT(isSynFamilyTyCon fun_tc) -- No associated data families have
-- reached this far
-- Look in the cache of solved funeqs
......@@ -1522,13 +1519,13 @@ doTopReactFunEq _ct fl fun_tc args xi loc
; succeed_with "Fun/Top" co ty } } } } }
where
fam_ty = mkTyConApp fun_tc args
loc = ctev_loc fl
try_improvement
| Just ops <- isBuiltInSynFamTyCon_maybe fun_tc
= do { let eqns = sfInteractTop ops args xi
; impsMb <- mapM (\(Pair x y) -> newDerived (mkTcEqPred x y))
eqns
; let work = map (mkNonCanonical loc) (catMaybes impsMb)
; impsMb <- mapM (\(Pair x y) -> newDerived loc (mkTcEqPred x y)) eqns
; let work = map mkNonCanonical (catMaybes impsMb)
; unless (null work) (updWorkListTcS (extendWorkListEqs work)) }
| otherwise
= return ()
......@@ -1539,8 +1536,7 @@ doTopReactFunEq _ct fl fun_tc args xi loc
; traceTcS ("doTopReactFunEq " ++ str) (ppr ctevs)
; case ctevs of
[ctev] -> updWorkListTcS $ extendWorkListEq $
CNonCanonical { cc_ev = ctev
, cc_loc = bumpCtLocDepth CountTyFunApps loc }
mkNonCanonical (ctev { ctev_loc = bumpCtLocDepth CountTyFunApps loc })
ctevs -> -- No subgoal (because it's cached)
ASSERT( null ctevs) return ()
; return $ SomeTopInt { tir_rule = str
......@@ -1844,12 +1840,12 @@ matchClassInst _ clas [ ty ] _
_ -> panicTcS (text "Unexpected evidence for" <+> ppr (className clas)
$$ vcat (map (ppr . idType) (classMethods clas)))
matchClassInst _ clas [ _k, ty1, ty2 ] _
matchClassInst _ clas [ _k, ty1, ty2 ] loc
| clas == coercibleClass = do
traceTcS "matchClassInst for" $ ppr clas <+> ppr ty1 <+> ppr ty2
rdr_env <- getGlobalRdrEnvTcS
safeMode <- safeLanguageOn `fmap` getDynFlags
ev <- getCoercibleInst safeMode rdr_env ty1 ty2
ev <- getCoercibleInst safeMode rdr_env loc ty1 ty2
traceTcS "matchClassInst returned" $ ppr ev
return ev
......@@ -1903,7 +1899,7 @@ matchClassInst inerts clas tys loc
; if null theta then
return (GenInst [] (EvDFunApp dfun_id tys []))
else do
{ evc_vars <- instDFunConstraints theta
{ evc_vars <- instDFunConstraints loc theta
; let new_ev_vars = freshGoals evc_vars
-- new_ev_vars are only the real new variables that can be emitted
dfun_app = EvDFunApp dfun_id tys (getEvTerms evc_vars)
......@@ -1935,8 +1931,8 @@ matchClassInst inerts clas tys loc
-- See Note [Coercible Instances]
-- Changes to this logic should likely be reflected in coercible_msg in TcErrors.
getCoercibleInst :: Bool -> GlobalRdrEnv -> TcType -> TcType -> TcS LookupInstResult
getCoercibleInst safeMode rdr_env ty1 ty2
getCoercibleInst :: Bool -> GlobalRdrEnv -> CtLoc -> TcType -> TcType -> TcS LookupInstResult
getCoercibleInst safeMode rdr_env loc ty1 ty2
| ty1 `tcEqType` ty2
= do return $ GenInst []
$ EvCoercible (EvCoercibleRefl ty1)
......@@ -1952,7 +1948,7 @@ getCoercibleInst safeMode rdr_env ty1 ty2
arg_evs <- flip mapM (zip3 (tyConRoles tc1) tyArgs1 tyArgs2) $ \(r,ta1,ta2) ->
case r of Nominal -> return (Nothing, EvCoercibleArgN ta1 {- == ta2, due to nominalArgsAgree -})
Representational -> do
ct_ev <- requestCoercible ta1 ta2
ct_ev <- requestCoercible loc ta1 ta2
return (freshGoal ct_ev, EvCoercibleArgR (getEvTerm ct_ev))
Phantom -> do
return (Nothing, EvCoercibleArgP ta1 ta2)
......@@ -1966,7 +1962,7 @@ getCoercibleInst safeMode rdr_env ty1 ty2
dataConsInScope rdr_env tc -- Do noot look at all tyConsOfTyCon
= do markDataConsAsUsed rdr_env tc
let concTy = newTyConInstRhs tc tyArgs
ct_ev <- requestCoercible concTy ty2
ct_ev <- requestCoercible loc concTy ty2
return $ GenInst (freshGoals [ct_ev])
$ EvCoercible (EvCoercibleNewType CLeft tc tyArgs (getEvTerm ct_ev))
......@@ -1977,7 +1973,7 @@ getCoercibleInst safeMode rdr_env ty1 ty2
dataConsInScope rdr_env tc -- Do noot look at all tyConsOfTyCon
= do markDataConsAsUsed rdr_env tc
let concTy = newTyConInstRhs tc tyArgs
ct_ev <- requestCoercible ty1 concTy
ct_ev <- requestCoercible loc ty1 concTy
return $ GenInst (freshGoals [ct_ev])
$ EvCoercible (EvCoercibleNewType CRight tc tyArgs (getEvTerm ct_ev))
......@@ -2006,10 +2002,11 @@ markDataConsAsUsed rdr_env tc = addUsedRdrNamesTcS
, not (null gres)
, Imported (imp_spec:_) <- [gre_prov (head gres)] ]
requestCoercible :: TcType -> TcType -> TcS MaybeNew
requestCoercible ty1 ty2 =
requestCoercible :: CtLoc -> TcType -> TcType -> TcS MaybeNew
requestCoercible loc ty1 ty2 =
ASSERT2( typeKind ty1 `tcEqKind` typeKind ty2, ppr ty1 <+> ppr ty2)
newWantedEvVar (coercibleClass `mkClassPred` [typeKind ty1, ty1, ty2])
newWantedEvVar loc (coercibleClass `mkClassPred` [typeKind ty1, ty1, ty2])
\end{code}
Note [Coercible Instances]
......
......@@ -170,9 +170,10 @@ newFlatWanteds orig theta
where
inst_to_wanted loc pty
= do { v <- newWantedEvVar pty
; return $ mkNonCanonical loc $
; return $ mkNonCanonical $
CtWanted { ctev_evar = v
, ctev_pred = pty } }
, ctev_pred = pty
, ctev_loc = loc } }
\end{code}
%************************************************************************
......@@ -874,8 +875,7 @@ zonkCt ct@(CHoleCan { cc_ev = ev })
; return $ ct { cc_ev = ev' } }
zonkCt ct
= do { fl' <- zonkCtEvidence (cc_ev ct)
; return (CNonCanonical { cc_ev = fl'
, cc_loc = cc_loc ct }) }
; return (mkNonCanonical fl') }
zonkCtEvidence :: CtEvidence -> TcM CtEvidence
zonkCtEvidence ctev@(CtGiven { ctev_pred = pred })
......
......@@ -913,19 +913,16 @@ data Ct
= CDictCan { -- e.g. Num xi
cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant]
cc_class :: Class,
cc_tyargs :: [Xi],
cc_loc :: CtLoc
cc_tyargs :: [Xi]
}
| CIrredEvCan { -- These stand for yet-unusable predicates
cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant]
cc_ev :: CtEvidence -- See Note [Ct/evidence invariant]
-- The ctev_pred of the evidence is
-- of form (tv xi1 xi2 ... xin)
-- or (tv1 ~ ty2) where the CTyEqCan kind invariant fails
-- or (F tys ~ ty) where the CFunEqCan kind invariant fails
-- See Note [CIrredEvCan constraints]
cc_loc :: CtLoc
}
| CTyEqCan { -- tv ~ xi (recall xi means function free)
......@@ -936,8 +933,7 @@ data Ct
-- * We prefer unification variables on the left *JUST* for efficiency
cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant]
cc_tyvar :: TcTyVar,
cc_rhs :: Xi,
cc_loc :: CtLoc
cc_rhs :: Xi
}
| CFunEqCan { -- F xis ~ xi
......@@ -947,21 +943,17 @@ data Ct
cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant]
cc_fun :: TyCon, -- A type function
cc_tyargs :: [Xi], -- Either under-saturated or exactly saturated
cc_rhs :: Xi, -- *never* over-saturated (because if so
cc_rhs :: Xi -- *never* over-saturated (because if so
-- we should have decomposed)
cc_loc :: CtLoc
}
| CNonCanonical { -- See Note [NonCanonical Semantics]
cc_ev :: CtEvidence,
cc_loc :: CtLoc
cc_ev :: CtEvidence
}
| CHoleCan { -- Treated as an "insoluble" constraint
-- See Note [Insoluble constraints]
cc_ev :: CtEvidence,
cc_loc :: CtLoc,
cc_occ :: OccName -- The name of this hole
}
\end{code}
......@@ -1039,11 +1031,11 @@ the evidence may *not* be fully zonked; we are careful not to look at it
during constraint solving. See Note [Evidence field of CtEvidence]
\begin{code}
mkNonCanonical :: CtLoc -> CtEvidence -> Ct
mkNonCanonical loc ev = CNonCanonical { cc_ev = ev, cc_loc = loc }
mkNonCanonical :: CtEvidence -> Ct
mkNonCanonical ev = CNonCanonical { cc_ev = ev }
mkNonCanonicalCt :: Ct -> Ct
mkNonCanonicalCt ct = CNonCanonical { cc_ev = cc_ev ct, cc_loc = cc_loc ct }
mkNonCanonicalCt ct = CNonCanonical { cc_ev = cc_ev ct }
ctEvidence :: Ct -> CtEvidence