diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs
index dcb6b98410e6642b004dc5b3e42739bb853c91b5..ed28f19ab67812edd5386e1ad4bb596a9f0b3a81 100644
--- a/compiler/GHC/Runtime/Eval.hs
+++ b/compiler/GHC/Runtime/Eval.hs
@@ -1084,7 +1084,7 @@ getDictionaryBindings theta = do
let dict_var = mkVanillaGlobal dictName theta
loc <- getCtLocM (GivenOrigin (getSkolemInfo unkSkol)) Nothing
- return CtWanted {
+ return $ CtWanted $ WantedCt {
ctev_pred = varType dict_var,
ctev_dest = EvVarDest dict_var,
ctev_loc = loc,
diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs
index 742d3f4e7050fb832a2d1a905a4dba0d5b6ab800..ef0450a62b51af048fdb1f9b4a5e7bec1769ce23 100644
--- a/compiler/GHC/Tc/Errors.hs
+++ b/compiler/GHC/Tc/Errors.hs
@@ -1,11 +1,11 @@
-
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE MultiWayIf #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE ParallelListComp #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE ParallelListComp #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
module GHC.Tc.Errors(
reportUnsolved, reportAllUnsolved, warnAllUnsolved,
@@ -470,7 +470,7 @@ mkErrorItem ct
-- For this `suppress` stuff
-- see Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint
CtGiven {} -> return (False, Nothing)
- CtWanted { ctev_rewriters = rewriters, ctev_dest = dest }
+ CtWanted (WantedCt { ctev_rewriters = rewriters, ctev_dest = dest })
-> do { rewriters' <- zonkRewriterSet rewriters
; return (not (isEmptyRewriterSet rewriters'), Just dest) }
@@ -1550,10 +1550,11 @@ validHoleFits ctxt@(CEC { cec_encl = implics
mk_wanted :: ErrorItem -> Maybe CtEvidence
mk_wanted (EI { ei_pred = pred, ei_evdest = m_dest, ei_loc = loc })
| Just dest <- m_dest
- = Just (CtWanted { ctev_pred = pred
- , ctev_dest = dest
- , ctev_loc = loc
- , ctev_rewriters = emptyRewriterSet })
+ = Just $ CtWanted $
+ WantedCt { ctev_pred = pred
+ , ctev_dest = dest
+ , ctev_loc = loc
+ , ctev_rewriters = emptyRewriterSet }
| otherwise
= Nothing -- The ErrorItem was a Given
diff --git a/compiler/GHC/Tc/Plugin.hs b/compiler/GHC/Tc/Plugin.hs
index 638e2848844149c4a2109b8f229812906ba2254b..7b6dc06ce380d81a472dda53474c941e86f65e8a 100644
--- a/compiler/GHC/Tc/Plugin.hs
+++ b/compiler/GHC/Tc/Plugin.hs
@@ -1,4 +1,3 @@
-
-- | This module provides an interface for typechecker plugins to
-- access select functions of the 'TcM', principally those to do with
-- reading parts of the state.
@@ -67,7 +66,7 @@ import GHC.Core.FamInstEnv ( FamInstEnv )
import GHC.Tc.Utils.Monad ( TcGblEnv, TcLclEnv, TcPluginM
, unsafeTcPluginTcM
, liftIO, traceTc )
-import GHC.Tc.Types.Constraint ( Ct, CtEvidence(..) )
+import GHC.Tc.Types.Constraint ( Ct, CtEvidence(..), GivenCtEvidence(..) )
import GHC.Tc.Types.CtLoc ( CtLoc )
import GHC.Tc.Utils.TcMType ( TcTyVar, TcType )
@@ -186,7 +185,8 @@ newGiven :: EvBindsVar -> CtLoc -> PredType -> EvExpr -> TcPluginM CtEvidence
newGiven tc_evbinds loc pty evtm = do
new_ev <- newEvVar pty
setEvBind tc_evbinds $ mkGivenEvBind new_ev (EvExpr evtm)
- return CtGiven { ctev_pred = pty, ctev_evar = new_ev, ctev_loc = loc }
+ return $ CtGiven $
+ GivenCt { ctev_pred = pty, ctev_evar = new_ev, ctev_loc = loc }
-- | Create a fresh evidence variable.
--
diff --git a/compiler/GHC/Tc/Solver/Default.hs b/compiler/GHC/Tc/Solver/Default.hs
index d1320e051ebfd6cbc52bd3032de175137e175934..072105f683580ec8028a145d36077940681c184f 100644
--- a/compiler/GHC/Tc/Solver/Default.hs
+++ b/compiler/GHC/Tc/Solver/Default.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE MultiWayIf #-}
module GHC.Tc.Solver.Default(
@@ -258,9 +259,9 @@ solveImplicationUsingUnsatGiven
; return $ wc { wc_simple = emptyBag, wc_impl = impls } }
go_simple :: Ct -> TcS ()
go_simple ct = case ctEvidence ct of
- CtWanted { ctev_pred = pty, ctev_dest = dst }
+ CtWanted (WantedCt { ctev_pred = pty, ctev_dest = dest })
-> do { ev_expr <- unsatisfiableEvExpr unsat_given pty
- ; setWantedEvTerm dst EvNonCanonical $ EvExpr ev_expr }
+ ; setWantedEvTerm dest EvNonCanonical $ EvExpr ev_expr }
_ -> return ()
-- | Create an evidence expression for an arbitrary constraint using
@@ -1063,14 +1064,16 @@ tryDefaultGroup wanteds (Proposal assignments)
= do { lcl_env <- TcS.getLclEnv
; tc_lvl <- TcS.getTcLevel
; let loc = mkGivenLoc tc_lvl (getSkolemInfo unkSkol) (mkCtLocEnv lcl_env)
- -- Equality constraints are possible due to type defaulting plugins
- ; wanted_evs <- sequence [ newWantedNC loc rewriters pred'
- | wanted <- wanteds
- , CtWanted { ctev_pred = pred
- , ctev_rewriters = rewriters }
- <- return (ctEvidence wanted)
- , let pred' = substTy subst pred ]
- ; residual_wc <- solveSimpleWanteds $ listToBag $ map mkNonCanonical wanted_evs
+ new_wtd_ct :: WantedCtEvidence -> TcS Ct
+ new_wtd_ct (WantedCt { ctev_pred = wtd_pred, ctev_rewriters = rws }) =
+ mkNonCanonical . CtWanted <$>
+ -- NB: equality constraints are possible,
+ -- due to type defaulting plugins
+ newWantedNC loc rws (substTy subst wtd_pred)
+ ; new_wanteds <- sequence [ new_wtd_ct wtd
+ | CtWanted wtd <- map ctEvidence wanteds
+ ]
+ ; residual_wc <- solveSimpleWanteds (listToBag new_wanteds)
; return $ if isEmptyWC residual_wc then Just (tvs, subst) else Nothing }
| otherwise
diff --git a/compiler/GHC/Tc/Solver/Dict.hs b/compiler/GHC/Tc/Solver/Dict.hs
index fd2e596b292a571afa95c180397289b4025575c4..514ea803e10bb8a7a440017df80a00f29453d5b0 100644
--- a/compiler/GHC/Tc/Solver/Dict.hs
+++ b/compiler/GHC/Tc/Solver/Dict.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE MultiWayIf #-}
-- | Solving Class constraints CDictCan
@@ -117,7 +118,7 @@ canDictCt ev cls tys
-- doNotExpand: We have already expanded superclasses for /this/ dict
-- so set the fuel to doNotExpand to avoid repeating expansion
- | CtWanted { ctev_rewriters = rewriters } <- ev
+ | CtWanted (WantedCt { ctev_rewriters = rws }) <- ev
, Just ip_name <- isCallStackPred cls tys
, Just fun_fs <- isPushCallStackOrigin_maybe orig
-- If we're given a CallStack constraint that arose from a function
@@ -134,7 +135,7 @@ canDictCt ev cls tys
-- See Note [Overview of implicit CallStacks]
-- in GHC.Tc.Types.Evidence
- ; new_ev <- newWantedEvVarNC new_loc rewriters pred
+ ; new_ev <- CtWanted <$> newWantedEvVarNC new_loc rws pred
-- Then we solve the wanted by pushing the call-site
-- onto the newly emitted CallStack
@@ -393,7 +394,7 @@ There is a bit of special treatment: search for isCTupleClass.
solveEqualityDict :: CtEvidence -> Class -> [Type] -> SolverStage Void
-- Precondition: (isEqualityClass cls) True, so cls is (~), (~~), or Coercible
solveEqualityDict ev cls tys
- | CtWanted { ctev_dest = dest } <- ev
+ | CtWanted (WantedCt { ctev_dest = dest }) <- ev
= Stage $
do { let (data_con, role, t1, t2) = matchEqualityInst cls tys
-- Unify t1~t2, putting anything that can't be solved
@@ -405,13 +406,14 @@ solveEqualityDict ev cls tys
evDataConApp data_con tys [Coercion co]
; stopWith ev "Solved wanted lifted equality" }
- | CtGiven { ctev_evar = ev_id, ctev_loc = loc } <- ev
+ | CtGiven (GivenCt { ctev_evar = ev_id }) <- ev
, [sel_id] <- classSCSelIds cls -- Equality classes have just one superclass
= Stage $
- do { let sc_pred = classMethodInstTy sel_id tys
+ do { let loc = ctEvLoc ev
+ sc_pred = classMethodInstTy sel_id tys
ev_expr = EvExpr $ Var sel_id `mkTyApps` tys `App` evId ev_id
; given_ev <- newGivenEvVar loc (sc_pred, ev_expr)
- ; startAgainWith (mkNonCanonical given_ev) }
+ ; startAgainWith (mkNonCanonical $ CtGiven given_ev) }
| otherwise
= pprPanic "solveEqualityDict" (ppr cls)
@@ -739,8 +741,8 @@ shortCutSolver :: DynFlags
-> CtEvidence -- Inert we want to try to replace
-> TcS Bool -- True <=> success
shortCutSolver dflags ev_w ev_i
- | isWanted ev_w
- , isGiven ev_i
+ | CtWanted wanted <- ev_w
+ , CtGiven {} <- ev_i
-- We are about to solve a [W] constraint from a [G] constraint. We take
-- a moment to see if we can get a better solution using an instance.
-- Note that we only do this for the sake of performance. Exactly the same
@@ -764,7 +766,7 @@ shortCutSolver dflags ev_w ev_i
; solved_dicts <- getSolvedDicts
; mb_stuff <- runMaybeT $
- try_solve_from_instance (ev_binds, solved_dicts) ev_w
+ try_solve_from_instance (ev_binds, solved_dicts) wanted
; case mb_stuff of
Nothing -> return False
@@ -782,11 +784,10 @@ shortCutSolver dflags ev_w ev_i
loc_w = ctEvLoc ev_w
try_solve_from_instance -- See Note [Shortcut try_solve_from_instance]
- :: (EvBindMap, DictMap DictCt) -> CtEvidence
+ :: (EvBindMap, DictMap DictCt) -> WantedCtEvidence
-> MaybeT TcS (EvBindMap, DictMap DictCt)
- try_solve_from_instance (ev_binds, solved_dicts) ev
- | let pred = ctEvPred ev
- , ClassPred cls tys <- classifyPredType pred
+ try_solve_from_instance (ev_binds, solved_dicts) wtd@(WantedCt { ctev_loc = loc, ctev_pred = pred })
+ | ClassPred cls tys <- classifyPredType pred
= do { inst_res <- lift $ matchGlobalInst dflags True cls tys loc_w
; lift $ warn_custom_warn_instance inst_res loc_w
-- See Note [Implementation of deprecated instances]
@@ -797,7 +798,7 @@ shortCutSolver dflags ev_w ev_i
, cir_what = what }
| safeOverlap what
, all isTyFamFree preds -- Note [Shortcut solving: type families]
- -> do { let dict_ct = DictCt { di_ev = ev, di_cls = cls
+ -> do { let dict_ct = DictCt { di_ev = CtWanted wtd, di_cls = cls
, di_tys = tys, di_pend_sc = doNotExpand }
solved_dicts' = addSolvedDict dict_ct solved_dicts
-- solved_dicts': it is important that we add our goal
@@ -805,17 +806,17 @@ shortCutSolver dflags ev_w ev_i
-- up in a loop while solving recursive dictionaries.
; lift $ traceTcS "shortCutSolver: found instance" (ppr preds)
- ; loc' <- lift $ checkInstanceOK (ctEvLoc ev) what pred
+ ; loc' <- lift $ checkInstanceOK loc what pred
; lift $ checkReductionDepth loc' pred
- ; evc_vs <- mapM (new_wanted_cached ev loc' solved_dicts') preds
+ ; evc_vs <- mapM (new_wanted_cached wtd loc' solved_dicts') preds
-- Emit work for subgoals but use our local cache
-- so we can solve recursive dictionaries.
; let ev_tm = mk_ev (map getEvExpr evc_vs)
ev_binds' = extendEvBinds ev_binds $
- mkWantedEvBind (ctEvEvId ev) canonical ev_tm
+ mkWantedEvBind (wantedCtEvEvId wtd) canonical ev_tm
; foldlM try_solve_from_instance (ev_binds', solved_dicts') $
freshGoals evc_vs }
@@ -829,13 +830,13 @@ shortCutSolver dflags ev_w ev_i
-- Use a local cache of solved dicts while emitting EvVars for new work
-- We bail out of the entire computation if we need to emit an EvVar for
-- a subgoal that isn't a ClassPred.
- new_wanted_cached :: CtEvidence -> CtLoc
+ new_wanted_cached :: WantedCtEvidence -> CtLoc
-> DictMap DictCt -> TcPredType -> MaybeT TcS MaybeNew
- new_wanted_cached ev_w loc cache pty
+ new_wanted_cached (WantedCt { ctev_rewriters = rws }) loc cache pty
| ClassPred cls tys <- classifyPredType pty
= lift $ case findDict cache loc_w cls tys of
Just dict_ct -> return $ Cached (ctEvExpr (dictCtEvidence dict_ct))
- Nothing -> Fresh <$> newWantedNC loc (ctEvRewriters ev_w) pty
+ Nothing -> Fresh <$> newWantedNC loc rws pty
| otherwise = mzero
{- *******************************************************************
@@ -888,7 +889,7 @@ chooseInstance work_item
(ppr work_item)
; evc_vars <- mapM (newWanted deeper_loc (ctEvRewriters work_item)) theta
; setEvBindIfWanted work_item canonical (mk_ev (map getEvExpr evc_vars))
- ; emitWorkNC (freshGoals evc_vars)
+ ; emitWorkNC (map CtWanted $ freshGoals evc_vars)
; stopWith work_item "Dict/Top (solved wanted)" }
where
pred = ctEvPred work_item
@@ -971,7 +972,7 @@ noMatchableGivenDicts inerts@(IS { inert_cans = inert_cans }) loc_w clas tys
matchable_given :: DictCt -> Bool
matchable_given (DictCt { di_ev = ev })
- | CtGiven { ctev_loc = loc_g, ctev_pred = pred_g } <- ev
+ | CtGiven (GivenCt { ctev_loc = loc_g, ctev_pred = pred_g }) <- ev
= isJust $ mightEqualLater inerts pred_g loc_g pred_w loc_w
| otherwise
@@ -1137,10 +1138,10 @@ nullary case of what's happening here.
matchLocalInst :: TcPredType -> CtLoc -> TcS ClsInstResult
-- Look up the predicate in Given quantified constraints,
-- which are effectively just local instance declarations.
-matchLocalInst pred loc
+matchLocalInst body_pred loc
= do { inerts@(IS { inert_cans = ics }) <- getInertSet
; case match_local_inst inerts (inert_insts ics) of
- { ([], []) -> do { traceTcS "No local instance for" (ppr pred)
+ { ([], []) -> do { traceTcS "No local instance for" (ppr body_pred)
; return NoInstance }
; (matches, unifs) ->
do { matches <- mapM mk_instDFun matches
@@ -1155,7 +1156,7 @@ matchLocalInst pred loc
, cir_canonical = EvCanonical
, cir_what = LocalInstance }
; traceTcS "Best local instance found:" $
- vcat [ text "pred:" <+> ppr pred
+ vcat [ text "body_pred:" <+> ppr body_pred
, text "result:" <+> ppr result
, text "matches:" <+> ppr matches
, text "unifs:" <+> ppr unifs ]
@@ -1163,13 +1164,13 @@ matchLocalInst pred loc
; mb_best ->
do { traceTcS "Multiple local instances; not committing to any"
- $ vcat [ text "pred:" <+> ppr pred
+ $ vcat [ text "body_pred:" <+> ppr body_pred
, text "matches:" <+> ppr matches
, text "unifs:" <+> ppr unifs
, text "best_match:" <+> ppr mb_best ]
; return NotSure }}}}}
where
- pred_tv_set = tyCoVarsOfType pred
+ body_pred_tv_set = tyCoVarsOfType body_pred
mk_instDFun :: (CtEvidence, [DFunInstType]) -> TcS InstDFun
mk_instDFun (ev, tys) =
@@ -1185,18 +1186,18 @@ matchLocalInst pred loc
match_local_inst _inerts []
= ([], [])
match_local_inst inerts (qci@(QCI { qci_tvs = qtvs
- , qci_pred = qpred
+ , qci_body = qbody
, qci_ev = qev })
:qcis)
- | let in_scope = mkInScopeSet (qtv_set `unionVarSet` pred_tv_set)
+ | let in_scope = mkInScopeSet (qtv_set `unionVarSet` body_pred_tv_set)
, Just tv_subst <- ruleMatchTyKiX qtv_set (mkRnEnv2 in_scope)
- emptyTvSubstEnv qpred pred
+ emptyTvSubstEnv qbody body_pred
, let match = (qev, map (lookupVarEnv tv_subst) qtvs)
= (match:matches, unifs)
| otherwise
- = assertPpr (disjointVarSet qtv_set (tyCoVarsOfType pred))
- (ppr qci $$ ppr pred)
+ = assertPpr (disjointVarSet qtv_set (tyCoVarsOfType body_pred))
+ (ppr qci $$ ppr body_pred)
-- ASSERT: unification relies on the
-- quantified variables being fresh
(matches, this_unif `combine` unifs)
@@ -1205,7 +1206,7 @@ matchLocalInst pred loc
qtv_set = mkVarSet qtvs
(matches, unifs) = match_local_inst inerts qcis
this_unif
- | Just subst <- mightEqualLater inerts qpred qloc pred loc
+ | Just subst <- mightEqualLater inerts qbody qloc body_pred loc
= Just (qev, map (lookupTyVar subst) qtvs)
| otherwise
= Nothing
@@ -1983,10 +1984,9 @@ makeSuperClasses cts = concatMapM go cts
go (CDictCan (DictCt { di_ev = ev, di_cls = cls, di_tys = tys, di_pend_sc = fuel }))
= assertFuelPreconditionStrict fuel $ -- fuel needs to be more than 0 always
mkStrictSuperClasses fuel ev [] [] cls tys
- go (CQuantCan (QCI { qci_pred = pred, qci_ev = ev, qci_pend_sc = fuel }))
- = assertPpr (isClassPred pred) (ppr pred) $ -- The cts should all have
- -- class pred heads
- assertFuelPreconditionStrict fuel $ -- fuel needs to be more than 0 always
+ go (CQuantCan (QCI { qci_body = body_pred, qci_ev = ev, qci_pend_sc = fuel }))
+ = assertPpr (isClassPred body_pred) (ppr body_pred) $ -- The cts should all have class pred heads
+ assertFuelPreconditionStrict fuel $ -- fuel needs to be more than 0, always
mkStrictSuperClasses fuel ev tvs theta cls tys
where
(tvs, theta, cls, tys) = tcSplitDFunTy (ctEvPred ev)
@@ -2017,13 +2017,12 @@ mk_strict_superclasses _ _ _ _ _ cls _
| isEqualityClass cls
= return []
-mk_strict_superclasses fuel rec_clss
- ev@(CtGiven { ctev_evar = evar, ctev_loc = loc })
- tvs theta cls tys
+mk_strict_superclasses fuel rec_clss ev@(CtGiven (GivenCt { ctev_evar = evar })) tvs theta cls tys
= -- Given case
do { traceTcS "mk_strict" (ppr ev $$ ppr (ctLocOrigin loc))
; concatMapM do_one_given (classSCSelIds cls) }
where
+ loc = ctEvLoc ev
dict_ids = mkTemplateLocals theta
this_size = pSizeClassPred cls tys
@@ -2038,7 +2037,7 @@ mk_strict_superclasses fuel rec_clss
= do { given_ev <- newGivenEvVar sc_loc $
mk_given_desc sel_id sc_pred
; assertFuelPrecondition fuel $
- mk_superclasses fuel rec_clss given_ev tvs theta sc_pred }
+ mk_superclasses fuel rec_clss (CtGiven given_ev) tvs theta sc_pred }
where
sc_pred = classMethodInstTy sel_id tys
@@ -2094,7 +2093,9 @@ mk_strict_superclasses fuel rec_clss
newly_blocked _ = False
-- Wanted case
-mk_strict_superclasses fuel rec_clss ev tvs theta cls tys
+mk_strict_superclasses fuel rec_clss
+ (CtWanted (WantedCt { ctev_pred = pty, ctev_loc = loc0, ctev_rewriters = rws }))
+ tvs theta cls tys
| all noFreeVarsOfType tys
= return [] -- Wanteds with no variables yield no superclass constraints.
-- See Note [Improvement from Ground Wanteds]
@@ -2104,12 +2105,12 @@ mk_strict_superclasses fuel rec_clss ev tvs theta cls tys
= assertPpr (null tvs && null theta) (ppr tvs $$ ppr theta) $
concatMapM do_one (immSuperClasses cls tys)
where
- loc = ctEvLoc ev `updateCtLocOrigin` WantedSuperclassOrigin (ctEvPred ev)
+ loc = loc0 `updateCtLocOrigin` WantedSuperclassOrigin pty
do_one sc_pred
= do { traceTcS "mk_strict_superclasses Wanted" (ppr (mkClassPred cls tys) $$ ppr sc_pred)
- ; sc_ev <- newWantedNC loc (ctEvRewriters ev) sc_pred
- ; mk_superclasses fuel rec_clss sc_ev [] [] sc_pred }
+ ; sc_ev <- newWantedNC loc rws sc_pred
+ ; mk_superclasses fuel rec_clss (CtWanted sc_ev) [] [] sc_pred }
{- Note [Improvement from Ground Wanteds]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2170,7 +2171,7 @@ mk_superclasses_of fuel rec_clss ev tvs theta cls tys
-- NB: If there is a loop, we cut off, so we have not
-- added the superclasses, hence cc_pend_sc = fuel
| otherwise
- = CQuantCan (QCI { qci_tvs = tvs, qci_pred = mkClassPred cls tys
+ = CQuantCan (QCI { qci_tvs = tvs, qci_body = mkClassPred cls tys
, qci_ev = ev, qci_pend_sc = fuel })
diff --git a/compiler/GHC/Tc/Solver/Equality.hs b/compiler/GHC/Tc/Solver/Equality.hs
index af697da65831df1e4c49d98275dbcc6cd49fce8d..126c7848915eb97a9952aba5a36b975b69420378 100644
--- a/compiler/GHC/Tc/Solver/Equality.hs
+++ b/compiler/GHC/Tc/Solver/Equality.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE MultiWayIf #-}
module GHC.Tc.Solver.Equality(
@@ -464,7 +465,7 @@ can_eq_nc_forall :: CtEvidence -> EqRel
-- See Note [Solving forall equalities]
can_eq_nc_forall ev eq_rel s1 s2
- | CtWanted { ctev_dest = orig_dest } <- ev
+ | CtWanted (WantedCt { ctev_dest = orig_dest }) <- ev
= do { let (bndrs1, phi1, bndrs2, phi2) = split_foralls s1 s2
flags1 = binderFlags bndrs1
flags2 = binderFlags bndrs2
@@ -749,7 +750,7 @@ can_eq_app :: CtEvidence -- :: s1 t1 ~N s2 t2
-- to an irreducible constraint; see typecheck/should_compile/T10494
-- See Note [Decomposing AppTy equalities]
can_eq_app ev s1 t1 s2 t2
- | CtWanted { ctev_dest = dest } <- ev
+ | CtWanted (WantedCt { ctev_dest = dest }) <- ev
= do { traceTcS "can_eq_app" (vcat [ text "s1:" <+> ppr s1, text "t1:" <+> ppr t1
, text "s2:" <+> ppr s2, text "t2:" <+> ppr t2
, text "vis:" <+> ppr (isNextArgVisible s1) ])
@@ -772,7 +773,7 @@ can_eq_app ev s1 t1 s2 t2
| s1k `mismatches` s2k
= canEqHardFailure ev (s1 `mkAppTy` t1) (s2 `mkAppTy` t2)
- | CtGiven { ctev_evar = evar } <- ev
+ | CtGiven (GivenCt { ctev_evar = evar }) <- ev
= do { let co = mkCoVarCo evar
co_s = mkLRCo CLeft co
co_t = mkLRCo CRight co
@@ -780,8 +781,8 @@ can_eq_app ev s1 t1 s2 t2
, evCoercion co_s )
; evar_t <- newGivenEvVar loc ( mkTcEqPredLikeEv ev t1 t2
, evCoercion co_t )
- ; emitWorkNC [evar_t]
- ; startAgainWith (mkNonCanonical evar_s) }
+ ; emitWorkNC [CtGiven evar_t]
+ ; startAgainWith (mkNonCanonical $ CtGiven evar_s) }
where
loc = ctEvLoc ev
@@ -1322,7 +1323,7 @@ canDecomposableTyConAppOK ev eq_rel tc (ty1,tys1) (ty2,tys2)
do { traceTcS "canDecomposableTyConAppOK"
(ppr ev $$ ppr eq_rel $$ ppr tc $$ ppr tys1 $$ ppr tys2)
; case ev of
- CtWanted { ctev_dest = dest }
+ CtWanted (WantedCt { ctev_dest = dest })
-- new_locs and tc_roles are both infinite, so we are
-- guaranteed that cos has the same length as tys1 and tys2
-- See Note [Fast path when decomposing TyConApps]
@@ -1333,7 +1334,7 @@ canDecomposableTyConAppOK ev eq_rel tc (ty1,tys1) (ty2,tys2)
; return (mkTyConAppCo role tc cos) }
; setWantedEq dest co }
- CtGiven { ctev_evar = evar }
+ CtGiven (GivenCt { ctev_evar = evar })
| let pred_ty = mkEqPred eq_rel ty1 ty2
ev_co = mkCoVarCo (setVarType evar pred_ty)
-- setVarType: satisfy Note [mkSelCo precondition] in Coercion.hs
@@ -1381,7 +1382,7 @@ canDecomposableFunTy ev eq_rel af f1@(ty1,m1,a1,r1) f2@(ty2,m2,a2,r2)
= do { traceTcS "canDecomposableFunTy"
(ppr ev $$ ppr eq_rel $$ ppr f1 $$ ppr f2)
; case ev of
- CtWanted { ctev_dest = dest }
+ CtWanted (WantedCt { ctev_dest = dest })
-> do { (co, _, _) <- wrapUnifierTcS ev Nominal $ \ uenv ->
do { let mult_env = uenv `updUEnvLoc` toInvisibleLoc
`setUEnvRole` funRole role SelMult
@@ -1391,7 +1392,7 @@ canDecomposableFunTy ev eq_rel af f1@(ty1,m1,a1,r1) f2@(ty2,m2,a2,r2)
; return (mkNakedFunCo role af mult arg res) }
; setWantedEq dest co }
- CtGiven { ctev_evar = evar }
+ CtGiven (GivenCt { ctev_evar = evar })
| let pred_ty = mkEqPred eq_rel ty1 ty2
ev_co = mkCoVarCo (setVarType evar pred_ty)
-- setVarType: satisfy Note [mkSelCo precondition] in Coercion.hs
@@ -1643,13 +1644,13 @@ canEqCanLHSHetero ev eq_rel swapped lhs1 ps_xi1 ki1 xi2 ps_xi2 ki2
-- Returned kind_co has kind (k1 ~ k2) if NotSwapped, (k2 ~ k1) if Swapped
-- Returned Bool = True if unifications happened, so we should retry
mk_kind_eq = case ev of
- CtGiven { ctev_evar = evar }
+ CtGiven (GivenCt { ctev_evar = evar, ctev_loc = loc })
-> do { let kind_co = mkKindCo (mkCoVarCo evar)
pred_ty = unSwap swapped mkNomEqPred ki1 ki2
- kind_loc = mkKindEqLoc xi1 xi2 (ctev_loc ev)
+ kind_loc = mkKindEqLoc xi1 xi2 loc
; kind_ev <- newGivenEvVar kind_loc (pred_ty, evCoercion kind_co)
- ; emitWorkNC [kind_ev]
- ; return (ctEvCoercion kind_ev, emptyRewriterSet, False) }
+ ; emitWorkNC [CtGiven kind_ev]
+ ; return (givenCtEvCoercion kind_ev, emptyRewriterSet, False) }
CtWanted {}
-> do { (kind_co, cts, unifs) <- wrapUnifierTcS ev Nominal $ \uenv ->
@@ -2536,16 +2537,15 @@ rewriteEqEvidence new_rewriters old_ev swapped (Reduction lhs_co nlhs) (Reductio
, isReflCo rhs_co
= return (setCtEvPredType old_ev new_pred)
- | CtGiven { ctev_evar = old_evar } <- old_ev
+ | CtGiven (GivenCt { ctev_evar = old_evar }) <- old_ev
= do { let new_tm = evCoercion ( mkSymCo lhs_co
`mkTransCo` maybeSymCo swapped (mkCoVarCo old_evar)
`mkTransCo` rhs_co)
- ; newGivenEvVar loc (new_pred, new_tm) }
+ ; CtGiven <$> newGivenEvVar loc (new_pred, new_tm) }
- | CtWanted { ctev_dest = dest
- , ctev_rewriters = rewriters } <- old_ev
- , let rewriters' = rewriters S.<> new_rewriters
- = do { (new_ev, hole_co) <- newWantedEq loc rewriters' (ctEvRewriteRole old_ev) nlhs nrhs
+ | CtWanted (WantedCt { ctev_dest = dest, ctev_rewriters = rewriters }) <- old_ev
+ = do { let rewriters' = rewriters S.<> new_rewriters
+ ; (new_ev, hole_co) <- newWantedEq loc rewriters' (ctEvRewriteRole old_ev) nlhs nrhs
; let co = maybeSymCo swapped $
lhs_co `mkTransCo` hole_co `mkTransCo` mkSymCo rhs_co
; setWantedEq dest co
@@ -2554,7 +2554,7 @@ rewriteEqEvidence new_rewriters old_ev swapped (Reduction lhs_co nlhs) (Reductio
, ppr nrhs
, ppr co
, ppr new_rewriters ])
- ; return new_ev }
+ ; return $ CtWanted new_ev }
where
new_pred = mkTcEqPredLikeEv old_ev nlhs nrhs
diff --git a/compiler/GHC/Tc/Solver/InertSet.hs b/compiler/GHC/Tc/Solver/InertSet.hs
index 6612cf260df3eb9f2a3095625ebbf903607c3c1c..102215a5143da802257c194beaacef0b105b0862 100644
--- a/compiler/GHC/Tc/Solver/InertSet.hs
+++ b/compiler/GHC/Tc/Solver/InertSet.hs
@@ -1940,7 +1940,7 @@ solveOneFromTheOther :: Ct -- Inert (Dict or Irred)
-- two wanteds into one by solving one from the other
solveOneFromTheOther ct_i ct_w
- | CtWanted { ctev_loc = loc_w } <- ev_w
+ | CtWanted {} <- ev_w
, prohibitedSuperClassSolve loc_i loc_w
-- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance
= -- Inert must be Given
@@ -1976,7 +1976,7 @@ solveOneFromTheOther ct_i ct_w
-- From here on the work-item is Given
- | CtWanted { ctev_loc = loc_i } <- ev_i
+ | CtWanted {} <- ev_i
, prohibitedSuperClassSolve loc_w loc_i
= KeepInert -- Just discard the un-usable Given
-- This never actually happens because
diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs
index b2854e17bc16ddb0d75ce4b3bf55c0630e69bff0..f664527cb132f9b58b2097839ea6fa7d0196e73f 100644
--- a/compiler/GHC/Tc/Solver/Monad.hs
+++ b/compiler/GHC/Tc/Solver/Monad.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RankNTypes #-}
@@ -336,10 +337,10 @@ addInertForAll new_qci
-- Update given equalities. C.f updateGivenEqs
; tclvl <- getTcLevel
- ; let pred = qci_pred new_qci
- not_equality = isClassPred pred && not (isEqClassPred pred)
+ ; let body_pred = qci_body new_qci
+ not_equality = isClassPred body_pred && not (isEqClassPred body_pred)
-- True <=> definitely not an equality
- -- A qci_pred like (f a) might be an equality
+ -- A qci_body like (f a) might be an equality
ics2 | not_equality = ics1
| otherwise = ics1 { inert_given_eq_lvl = tclvl
@@ -428,7 +429,7 @@ kickOutRewritable ko_spec new_fr
-- from the cache, too.
; let kicked_given_ev_vars = foldr add_one emptyVarSet kicked_out
add_one :: Ct -> VarSet -> VarSet
- add_one ct vs | CtGiven { ctev_evar = ev_var } <- ctEvidence ct
+ add_one ct vs | CtGiven (GivenCt { ctev_evar = ev_var }) <- ctEvidence ct
= vs `extendVarSet` ev_var
| otherwise = vs
@@ -497,7 +498,7 @@ kickOutAfterFillingCoercionHole hole
-- True: kick out; False: keep.
kick_ct ct
| IrredCt { ir_ev = ev, ir_reason = reason } <- ct
- , CtWanted { ctev_rewriters = RewriterSet rewriters } <- ev
+ , CtWanted (WantedCt { ctev_rewriters = RewriterSet rewriters }) <- ev
, NonCanonicalReason ctyeq <- reason
, ctyeq `cterHasProblem` cteCoercionHole
, hole `elementOfUniqSet` rewriters
@@ -1859,17 +1860,17 @@ tcInstSkolTyVarsX skol_info subst tvs = wrapTcS $ TcM.tcInstSkolTyVarsX skol_inf
-- Creating and setting evidence variables and CtFlavors
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-data MaybeNew = Fresh CtEvidence | Cached EvExpr
+data MaybeNew = Fresh WantedCtEvidence | Cached EvExpr
isFresh :: MaybeNew -> Bool
isFresh (Fresh {}) = True
isFresh (Cached {}) = False
-freshGoals :: [MaybeNew] -> [CtEvidence]
+freshGoals :: [MaybeNew] -> [WantedCtEvidence]
freshGoals mns = [ ctev | Fresh ctev <- mns ]
getEvExpr :: MaybeNew -> EvExpr
-getEvExpr (Fresh ctev) = ctEvExpr ctev
+getEvExpr (Fresh ctev) = ctEvExpr (CtWanted ctev)
getEvExpr (Cached evt) = evt
setEvBind :: EvBind -> TcS ()
@@ -1936,8 +1937,8 @@ fillCoercionHole hole co
setEvBindIfWanted :: CtEvidence -> CanonicalEvidence -> EvTerm -> TcS ()
setEvBindIfWanted ev canonical tm
= case ev of
- CtWanted { ctev_dest = dest } -> setWantedEvTerm dest canonical tm
- _ -> return ()
+ CtWanted (WantedCt { ctev_dest = dest }) -> setWantedEvTerm dest canonical tm
+ _ -> return ()
newTcEvBinds :: TcS EvBindsVar
newTcEvBinds = wrapTcS TcM.newTcEvBinds
@@ -1948,14 +1949,14 @@ newNoTcEvBinds = wrapTcS TcM.newNoTcEvBinds
newEvVar :: TcPredType -> TcS EvVar
newEvVar pred = wrapTcS (TcM.newEvVar pred)
-newGivenEvVar :: CtLoc -> (TcPredType, EvTerm) -> TcS CtEvidence
+newGivenEvVar :: CtLoc -> (TcPredType, EvTerm) -> TcS GivenCtEvidence
-- Make a new variable of the given PredType,
-- immediately bind it to the given term
-- and return its CtEvidence
-- See Note [Bind new Givens immediately] in GHC.Tc.Types.Constraint
newGivenEvVar loc (pred, rhs)
= do { new_ev <- newBoundEvVarId pred rhs
- ; return (CtGiven { ctev_pred = pred, ctev_evar = new_ev, ctev_loc = loc }) }
+ ; return $ GivenCt { ctev_pred = pred, ctev_evar = new_ev, ctev_loc = loc } }
-- | Make a new 'Id' of the given type, bound (in the monad's EvBinds) to the
-- given term
@@ -1968,31 +1969,31 @@ newBoundEvVarId pred rhs
emitNewGivens :: CtLoc -> [(Role,TcCoercion)] -> TcS ()
emitNewGivens loc pts
= do { traceTcS "emitNewGivens" (ppr pts)
- ; evs <- mapM (newGivenEvVar loc) $
+ ; gs <- mapM (newGivenEvVar loc) $
[ (mkEqPredRole role ty1 ty2, evCoercion co)
| (role, co) <- pts
, let Pair ty1 ty2 = coercionKind co
, not (ty1 `tcEqType` ty2) ] -- Kill reflexive Givens at birth
- ; emitWorkNC evs }
+ ; emitWorkNC (map CtGiven gs) }
emitNewWantedEq :: CtLoc -> RewriterSet -> Role -> TcType -> TcType -> TcS Coercion
-- | Emit a new Wanted equality into the work-list
emitNewWantedEq loc rewriters role ty1 ty2
- = do { (ev, co) <- newWantedEq loc rewriters role ty1 ty2
- ; updWorkListTcS (extendWorkListEq rewriters (mkNonCanonical ev))
+ = do { (wtd, co) <- newWantedEq loc rewriters role ty1 ty2
+ ; updWorkListTcS (extendWorkListEq rewriters (mkNonCanonical $ CtWanted wtd))
; return co }
-- | Create a new Wanted constraint holding a coercion hole
-- for an equality between the two types at the given 'Role'.
newWantedEq :: CtLoc -> RewriterSet -> Role -> TcType -> TcType
- -> TcS (CtEvidence, Coercion)
+ -> TcS (WantedCtEvidence, Coercion)
newWantedEq loc rewriters role ty1 ty2
= do { hole <- wrapTcS $ TcM.newCoercionHole loc pty
- ; return ( CtWanted { ctev_pred = pty
- , ctev_dest = HoleDest hole
- , ctev_loc = loc
- , ctev_rewriters = rewriters }
- , mkHoleCo hole ) }
+ ; let wtd = WantedCt { ctev_pred = pty
+ , ctev_dest = HoleDest hole
+ , ctev_loc = loc
+ , ctev_rewriters = rewriters }
+ ; return (wtd, mkHoleCo hole) }
where
pty = mkEqPredRole role ty1 ty2
@@ -2000,17 +2001,19 @@ newWantedEq loc rewriters role ty1 ty2
--
-- Don't use this for equality constraints: use 'newWantedEq' instead.
newWantedEvVarNC :: CtLoc -> RewriterSet
- -> TcPredType -> TcS CtEvidence
+ -> TcPredType -> TcS WantedCtEvidence
-- Don't look up in the solved/inerts; we know it's not there
newWantedEvVarNC loc rewriters pty
= assertPpr (not (isEqPred pty)) (ppr pty) $
do { new_ev <- newEvVar pty
; traceTcS "Emitting new wanted" (ppr new_ev <+> dcolon <+> ppr pty $$
pprCtLoc loc)
- ; return (CtWanted { ctev_pred = pty
- , ctev_dest = EvVarDest new_ev
- , ctev_loc = loc
- , ctev_rewriters = rewriters })}
+ ; return $
+ WantedCt { ctev_pred = pty
+ , ctev_dest = EvVarDest new_ev
+ , ctev_loc = loc
+ , ctev_rewriters = rewriters }
+ }
-- | Like 'newWantedEvVarNC', except it might look up in the inert set
-- to see if an inert already exists, and uses that instead of creating
@@ -2051,7 +2054,7 @@ newWanted loc rewriters pty
--
-- Does not attempt to re-use non-equality constraints that already
-- exist in the inert set.
-newWantedNC :: CtLoc -> RewriterSet -> PredType -> TcS CtEvidence
+newWantedNC :: CtLoc -> RewriterSet -> PredType -> TcS WantedCtEvidence
newWantedNC loc rewriters pty
| Just (role, ty1, ty2) <- getEqPredTys_maybe pty
= fst <$> newWantedEq loc rewriters role ty1 ty2
@@ -2370,7 +2373,7 @@ checkTypeEq ev eq_rel lhs rhs
---------------------------
mk_new_given :: (TcTyVar, TcType) -> TcS Ct
mk_new_given (new_tv, fam_app)
- = mkNonCanonical <$> newGivenEvVar cb_loc (given_pred, given_term)
+ = mkNonCanonical . CtGiven <$> newGivenEvVar cb_loc (given_pred, given_term)
where
new_ty = mkTyVarTy new_tv
given_pred = mkNomEqPred fam_app new_ty
diff --git a/compiler/GHC/Tc/Solver/Rewrite.hs b/compiler/GHC/Tc/Solver/Rewrite.hs
index 9f091b36786113890441839fd7e283dd0b5c5701..d52a4260db1f3cdeafd5cdf67109e83a95773f24 100644
--- a/compiler/GHC/Tc/Solver/Rewrite.hs
+++ b/compiler/GHC/Tc/Solver/Rewrite.hs
@@ -151,15 +151,15 @@ bumpDepth (RewriteM thing_inside)
; thing_inside env' }
-- See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint
--- Precondition: the CtEvidence is a CtWanted of an equality
-recordRewriter :: CtEvidence -> RewriteM ()
-recordRewriter (CtWanted { ctev_dest = HoleDest hole })
+-- Precondition: the WantedCtEvidence is for an equality constraint
+recordRewriter :: WantedCtEvidence -> RewriteM ()
+recordRewriter (WantedCt { ctev_dest = HoleDest hole })
= RewriteM $ \env -> updTcRef (re_rewriters env) (`addRewriter` hole)
-recordRewriter other = pprPanic "recordRewriter" (ppr other)
+recordRewriter other =
+ pprPanic "recordRewriter: non-equality constraint" (ppr other)
-{-
-Note [Rewriter EqRels]
-~~~~~~~~~~~~~~~~~~~~~~~
+{- Note [Rewriter EqRels]
+~~~~~~~~~~~~~~~~~~~~~~~~~
When rewriting, we need to know which equality relation -- nominal
or representational -- we should be respecting. This is controlled
by the `re_eq_rel` field of RewriteEnv.
@@ -1021,12 +1021,14 @@ rewrite_tyvar2 tv fr@(_, eq_rel)
| Just ct <- find can_rewrite equal_ct_list
, EqCt { eq_ev = ctev, eq_lhs = TyVarLHS tv
, eq_rhs = rhs_ty, eq_eq_rel = ct_eq_rel } <- ct
- -> do { let wrw = isWanted ctev
- ; traceRewriteM "Following inert tyvar" $
+ -> do { traceRewriteM "Following inert tyvar" $
vcat [ ppr tv <+> equals <+> ppr rhs_ty
- , ppr ctev
- , text "wanted_rewrite_wanted:" <+> ppr wrw ]
- ; when wrw $ recordRewriter ctev
+ , ppr ctev ]
+ ; case ctev of
+ CtGiven {} -> return ()
+ CtWanted wtd ->
+ -- See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint
+ recordRewriter wtd
; let rewriting_co1 = ctEvCoercion ctev
rewriting_co = case (ct_eq_rel, eq_rel) of
diff --git a/compiler/GHC/Tc/Solver/Solve.hs b/compiler/GHC/Tc/Solver/Solve.hs
index 771493bfe80b6c58567f21a1c6ea5c23abf11e46..8693dc3596e7f07451e4023cac2ae53e27f22bdc 100644
--- a/compiler/GHC/Tc/Solver/Solve.hs
+++ b/compiler/GHC/Tc/Solver/Solve.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecursiveDo #-}
@@ -1225,15 +1226,15 @@ solveForAll ev tvs theta body_pred fuel =
-- See Note [Solving a Given forall-constraint]
do { addInertForAll qci
; stopWith ev "Given forall-constraint" }
- CtWanted {} ->
+ CtWanted wtd ->
-- See Note [Solving a Wanted forall-constraint]
runSolverStage $
do { tryInertQCs qci
- ; Stage $ solveWantedForAll_implic ev tvs theta body_pred
+ ; Stage $ solveWantedForAll_implic wtd tvs theta body_pred
}
where
qci = QCI { qci_ev = ev, qci_tvs = tvs
- , qci_pred = body_pred, qci_pend_sc = fuel }
+ , qci_body = body_pred, qci_pend_sc = fuel }
tryInertQCs :: QCInst -> SolverStage ()
@@ -1260,15 +1261,15 @@ try_inert_qcs (QCI { qci_ev = ev_w }) inerts =
-- | Solve a (canonical) Wanted quantified constraint by emitting an implication.
--
-- See Note [Solving a Wanted forall-constraint]
-solveWantedForAll_implic :: CtEvidence -> [TcTyVar] -> TcThetaType -> PredType -> TcS (StopOrContinue Void)
+solveWantedForAll_implic :: WantedCtEvidence -> [TcTyVar] -> TcThetaType -> PredType -> TcS (StopOrContinue Void)
solveWantedForAll_implic
- ev@(CtWanted { ctev_dest = dest, ctev_loc = loc, ctev_rewriters = rewriters })
+ wtd@(WantedCt { ctev_dest = dest, ctev_loc = loc, ctev_rewriters = rewriters })
tvs theta body_pred =
-- We are about to do something irreversible (turning a quantified constraint
-- into an implication), so wrap the inner call in solveCompletelyIfRequired
-- to ensure we can roll back if we can't solve the implication fully.
-- See Note [TcSSpecPrag] in GHC.Tc.Solver.Monad.
- solveCompletelyIfRequired (mkNonCanonical ev) $
+ solveCompletelyIfRequired (mkNonCanonical $ CtWanted wtd) $
-- This setSrcSpan is important: the emitImplicationTcS uses that
-- TcLclEnv for the implication, and that in turn sets the location
@@ -1296,8 +1297,8 @@ solveWantedForAll_implic
-- See (QC-INV) in Note [Solving a Wanted forall-constraint]
; wanted_ev <- newWantedNC loc' rewriters inst_pred
-- NB: inst_pred can be an equality
- ; return ( ctEvEvId wanted_ev
- , unitBag (mkNonCanonical wanted_ev)) }
+ ; return ( wantedCtEvEvId wanted_ev
+ , unitBag (mkNonCanonical $ CtWanted wanted_ev)) }
; traceTcS "solveForAll" (ppr given_ev_vars $$ ppr wanteds $$ ppr w_id)
; ev_binds <- emitImplicationTcS lvl skol_info_anon skol_tvs given_ev_vars wanteds
@@ -1306,7 +1307,7 @@ solveWantedForAll_implic
EvFun { et_tvs = skol_tvs, et_given = given_ev_vars
, et_binds = ev_binds, et_body = w_id }
- ; stopWith ev "Wanted forall-constraint (implication)"
+ ; stopWith (CtWanted wtd) "Wanted forall-constraint (implication)"
}
where
-- Getting the size of the head is a bit horrible
@@ -1314,8 +1315,6 @@ solveWantedForAll_implic
get_size pred = case classifyPredType pred of
ClassPred cls tys -> pSizeClassPred cls tys
_ -> pSizeType pred
-solveWantedForAll_implic (CtGiven {}) _ _ _ =
- panic "solveWantedForAll_implic: CtGiven"
{- Note [Solving a Wanted forall-constraint]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1450,33 +1449,35 @@ finish_rewrite old_ev (Reduction co new_pred) rewriters
= assert (isEmptyRewriterSet rewriters) $
continueWith (setCtEvPredType old_ev new_pred)
-finish_rewrite ev@(CtGiven { ctev_evar = old_evar, ctev_loc = loc })
- (Reduction co new_pred) rewriters
+finish_rewrite
+ ev@(CtGiven (GivenCt { ctev_evar = old_evar }))
+ (Reduction co new_pred)
+ rewriters
= assert (isEmptyRewriterSet rewriters) $ -- this is a Given, not a wanted
- do { new_ev <- newGivenEvVar loc (new_pred, new_tm)
- ; continueWith new_ev }
- where
- -- mkEvCast optimises ReflCo
- ev_rw_role = ctEvRewriteRole ev
- new_tm = assert (coercionRole co == ev_rw_role)
- mkEvCast (evId old_evar)
- (downgradeRole Representational ev_rw_role co)
-
-finish_rewrite ev@(CtWanted { ctev_dest = dest
- , ctev_loc = loc
- , ctev_rewriters = rewriters })
- (Reduction co new_pred) new_rewriters
- = do { mb_new_ev <- newWanted loc rewriters' new_pred
- ; let ev_rw_role = ctEvRewriteRole ev
+ do { let loc = ctEvLoc ev
+ -- mkEvCast optimises ReflCo
+ ev_rw_role = ctEvRewriteRole ev
+ new_tm = assert (coercionRole co == ev_rw_role)
+ mkEvCast (evId old_evar)
+ (downgradeRole Representational ev_rw_role co)
+ ; new_ev <- newGivenEvVar loc (new_pred, new_tm)
+ ; continueWith $ CtGiven new_ev }
+
+finish_rewrite
+ ev@(CtWanted (WantedCt { ctev_rewriters = rewriters, ctev_dest = dest }))
+ (Reduction co new_pred)
+ new_rewriters
+ = do { let loc = ctEvLoc ev
+ rewriters' = rewriters S.<> new_rewriters
+ ev_rw_role = ctEvRewriteRole ev
+ ; mb_new_ev <- newWanted loc rewriters' new_pred
; massert (coercionRole co == ev_rw_role)
; setWantedEvTerm dest EvCanonical $
mkEvCast (getEvExpr mb_new_ev)
(downgradeRole Representational ev_rw_role (mkSymCo co))
; case mb_new_ev of
- Fresh new_ev -> continueWith new_ev
+ Fresh new_ev -> continueWith $ CtWanted new_ev
Cached _ -> stopWith ev "Cached wanted" }
- where
- rewriters' = rewriters S.<> new_rewriters
{- *******************************************************************
* *
@@ -1544,7 +1545,7 @@ runTcPluginsWanted wc@(WC { wc_simple = simples1 })
where
setEv :: (EvTerm,Ct) -> TcS ()
setEv (ev,ct) = case ctEvidence ct of
- CtWanted { ctev_dest = dest } -> setWantedEvTerm dest EvCanonical ev
+ CtWanted (WantedCt { ctev_dest = dest }) -> setWantedEvTerm dest EvCanonical ev
-- TODO: plugins should be able to signal non-canonicity
_ -> panic "runTcPluginsWanted.setEv: attempt to solve non-wanted!"
diff --git a/compiler/GHC/Tc/Types/Constraint.hs b/compiler/GHC/Tc/Types/Constraint.hs
index 695be54d85994c5883b72c749577dd0a342b7505..76274bad0f6e56ffae7abb44bd734138300e9c76 100644
--- a/compiler/GHC/Tc/Types/Constraint.hs
+++ b/compiler/GHC/Tc/Types/Constraint.hs
@@ -1,5 +1,5 @@
-
{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeApplications #-}
@@ -75,11 +75,16 @@ module GHC.Tc.Types.Constraint (
CtEvidence(..), TcEvDest(..),
isWanted, isGiven,
ctEvPred, ctEvLoc, ctEvOrigin, ctEvEqRel,
- ctEvExpr, ctEvTerm, ctEvCoercion, ctEvEvId,
- ctEvRewriters, ctEvUnique, tcEvDestUnique,
+ ctEvExpr, ctEvTerm,
+ ctEvCoercion, givenCtEvCoercion,
+ ctEvEvId, wantedCtEvEvId,
+ ctEvRewriters, setWantedCtEvRewriters, ctEvUnique, tcEvDestUnique,
ctEvRewriteRole, ctEvRewriteEqRel, setCtEvPredType, setCtEvLoc,
tyCoVarsOfCtEvList, tyCoVarsOfCtEv, tyCoVarsOfCtEvsList,
+ -- CtEvidence constructors
+ GivenCtEvidence(..), WantedCtEvidence(..),
+
-- RewriterSet
RewriterSet(..), emptyRewriterSet, isEmptyRewriterSet,
-- exported concretely only for zonkRewriterSet
@@ -189,15 +194,24 @@ assertFuelPreconditionStrict :: ExpansionFuel -> a -> a
{-# INLINE assertFuelPreconditionStrict #-}
assertFuelPreconditionStrict fuel = assertPpr (pendingFuel fuel) insufficientFuelError
+-- | Constraint
data Ct
+ -- | A dictionary constraint (canonical)
= CDictCan DictCt
- | CIrredCan IrredCt -- A "irreducible" constraint (non-canonical)
- | CEqCan EqCt -- A canonical equality constraint
- | CQuantCan QCInst -- A quantified constraint
- | CNonCanonical CtEvidence -- See Note [NonCanonical Semantics] in GHC.Tc.Solver.Monad
+ -- | An irreducible constraint (non-canonical)
+ | CIrredCan IrredCt
+ -- | An equality constraint (canonical)
+ | CEqCan EqCt
+ -- | A quantified constraint (canonical)
+ | CQuantCan QCInst
+ -- | A non-canonical constraint
+ --
+ -- See Note [NonCanonical Semantics] in GHC.Tc.Solver.Monad
+ | CNonCanonical CtEvidence
--------------- DictCt --------------
+-- | A canonical dictionary constraint
data DictCt -- e.g. Num ty
= DictCt { di_ev :: CtEvidence -- See Note [Ct/evidence invariant]
@@ -279,7 +293,10 @@ and forms condition T3 in Note [Extending the inert equalities]
in GHC.Tc.Solver.InertSet.
-}
-data EqCt -- An equality constraint; see Note [Canonical equalities]
+-- | A canonical equality constraint.
+--
+-- See Note [Canonical equalities] in GHC.Tc.Types.Constraint.
+data EqCt
= EqCt { -- CanEqLHS ~ rhs
eq_ev :: CtEvidence, -- See Note [Ct/evidence invariant]
eq_lhs :: CanEqLHS,
@@ -319,18 +336,23 @@ instance Outputable IrredCt where
--------------- QCInst --------------
-data QCInst -- A much simplified version of ClsInst
- -- See Note [Quantified constraints] in GHC.Tc.Solver.Solve
- = QCI { qci_ev :: CtEvidence -- Always of type forall tvs. context => ty
- -- Always Given
- , qci_tvs :: [TcTyVar] -- The tvs
- , qci_pred :: TcPredType -- The ty
+-- | A quantified constraint, also called a "local instance"
+-- (a simplified version of 'ClsInst').
+--
+-- See Note [Quantified constraints] in GHC.Tc.Solver.Solve
+data QCInst
+ -- | A quantified constraint, of type @forall tvs. context => ty@
+ = QCI { qci_ev :: CtEvidence
+ , qci_tvs :: [TcTyVar] -- ^ @tvs@
+ , qci_body :: TcPredType -- ^ the body of the @forall@, i.e. @ty@
, qci_pend_sc :: ExpansionFuel
- -- Invariants: qci_pend_sc > 0 =>
- -- (a) qci_pred is a ClassPred
- -- (b) this class has superclass(es), and
- -- (c) the superclass(es) are not explored yet
- -- Same as di_pend_sc flag in DictCt
+ -- ^ Invariants: qci_pend_sc > 0 =>
+ --
+ -- (a) 'qci_body' is a ClassPred
+ -- (b) this class has superclass(es), and
+ -- (c) the superclass(es) are not explored yet
+ --
+ -- Same as 'di_pend_sc' flag in 'DictCt'
-- See Note [Expanding Recursive Superclasses and ExpansionFuel] in GHC.Tc.Solver
}
@@ -682,9 +704,9 @@ mkGivens :: CtLoc -> [EvId] -> [Ct]
mkGivens loc ev_ids
= map mk ev_ids
where
- mk ev_id = mkNonCanonical (CtGiven { ctev_evar = ev_id
- , ctev_pred = evVarPred ev_id
- , ctev_loc = loc })
+ mk ev_id = mkNonCanonical (CtGiven (GivenCt { ctev_evar = ev_id
+ , ctev_pred = evVarPred ev_id
+ , ctev_loc = loc }))
ctEvidence :: Ct -> CtEvidence
ctEvidence (CQuantCan (QCI { qci_ev = ev })) = ev
@@ -1279,7 +1301,7 @@ insolubleWantedCt ct
| CIrredCan ir_ct <- ct
-- CIrredCan: see (IW1) in Note [Insoluble Wanteds]
, IrredCt { ir_ev = ev } <- ir_ct
- , CtWanted { ctev_loc = loc, ctev_rewriters = rewriters } <- ev
+ , CtWanted (WantedCt { ctev_loc = loc, ctev_rewriters = rewriters }) <- ev
-- It's a Wanted
, insolubleIrredCt ir_ct
-- It's insoluble
@@ -2180,24 +2202,32 @@ data TcEvDest
-- See Note [Coercion holes] in GHC.Core.TyCo.Rep
data CtEvidence
- = CtGiven -- Truly given, not depending on subgoals
- { ctev_pred :: TcPredType -- See Note [Ct/evidence invariant]
- , ctev_evar :: EvVar -- See Note [CtEvidence invariants]
- , ctev_loc :: CtLoc }
-
-
- | CtWanted -- Wanted goal
- { ctev_pred :: TcPredType -- See Note [Ct/evidence invariant]
- , ctev_dest :: TcEvDest -- See Note [CtEvidence invariants]
- , ctev_loc :: CtLoc
- , ctev_rewriters :: RewriterSet } -- See Note [Wanteds rewrite Wanteds]
+ = CtGiven GivenCtEvidence
+ | CtWanted WantedCtEvidence
+
+-- | Evidence for a Given constraint
+data GivenCtEvidence =
+ GivenCt
+ { ctev_pred :: TcPredType -- See Note [Ct/evidence invariant]
+ , ctev_evar :: EvVar -- See Note [CtEvidence invariants]
+ , ctev_loc :: CtLoc }
+
+-- | Evidence for a Wanted constraint
+data WantedCtEvidence =
+ WantedCt
+ { ctev_pred :: TcPredType -- See Note [Ct/evidence invariant]
+ , ctev_dest :: TcEvDest -- See Note [CtEvidence invariants]
+ , ctev_loc :: CtLoc
+ , ctev_rewriters :: RewriterSet } -- See Note [Wanteds rewrite Wanteds]
ctEvPred :: CtEvidence -> TcPredType
-- The predicate of a flavor
-ctEvPred = ctev_pred
+ctEvPred (CtGiven (GivenCt { ctev_pred = pred })) = pred
+ctEvPred (CtWanted (WantedCt { ctev_pred = pred })) = pred
ctEvLoc :: CtEvidence -> CtLoc
-ctEvLoc = ctev_loc
+ctEvLoc (CtGiven (GivenCt { ctev_loc = loc })) = loc
+ctEvLoc (CtWanted (WantedCt { ctev_loc = loc })) = loc
ctEvOrigin :: CtEvidence -> CtOrigin
ctEvOrigin = ctLocOrigin . ctEvLoc
@@ -2225,20 +2255,30 @@ ctEvTerm ev = EvExpr (ctEvExpr ev)
-- If the provided CtEvidence is not for a Wanted, just
-- return an empty set.
ctEvRewriters :: CtEvidence -> RewriterSet
-ctEvRewriters (CtWanted { ctev_rewriters = rewriters }) = rewriters
-ctEvRewriters (CtGiven {}) = emptyRewriterSet
+ctEvRewriters (CtWanted (WantedCt { ctev_rewriters = rws })) = rws
+ctEvRewriters (CtGiven {}) = emptyRewriterSet
+
+-- | Set the rewriter set of a Wanted constraint.
+setWantedCtEvRewriters :: WantedCtEvidence -> RewriterSet -> WantedCtEvidence
+setWantedCtEvRewriters ev rs = ev { ctev_rewriters = rs }
ctEvExpr :: HasDebugCallStack => CtEvidence -> EvExpr
-ctEvExpr ev@(CtWanted { ctev_dest = HoleDest _ })
- = Coercion $ ctEvCoercion ev
+ctEvExpr (CtWanted ev@(WantedCt { ctev_dest = HoleDest _ }))
+ = Coercion $ ctEvCoercion (CtWanted ev)
ctEvExpr ev = evId (ctEvEvId ev)
+givenCtEvCoercion :: GivenCtEvidence -> TcCoercion
+givenCtEvCoercion _given@(GivenCt { ctev_evar = ev_id })
+ = assertPpr (isCoVar ev_id)
+ (text "givenCtEvCoercion used on non-equality Given constraint:" <+> ppr _given)
+ $ mkCoVarCo ev_id
+
ctEvCoercion :: HasDebugCallStack => CtEvidence -> TcCoercion
-ctEvCoercion _given@(CtGiven { ctev_evar = ev_id })
+ctEvCoercion (CtGiven _given@(GivenCt { ctev_evar = ev_id }))
= assertPpr (isCoVar ev_id)
- (text "ctEvCoercion used on non-equality Given constraint:" <+> ppr _given)
+ (text "ctEvCoercion used on non-equality Given constraint:" <+> ppr (CtGiven _given))
$ mkCoVarCo ev_id
-ctEvCoercion (CtWanted { ctev_dest = dest })
+ctEvCoercion (CtWanted (WantedCt { ctev_dest = dest }))
| HoleDest hole <- dest
= -- ctEvCoercion is only called on type equalities
-- and they always have HoleDests
@@ -2247,20 +2287,24 @@ ctEvCoercion ev
= pprPanic "ctEvCoercion" (ppr ev)
ctEvEvId :: CtEvidence -> EvVar
-ctEvEvId (CtWanted { ctev_dest = EvVarDest ev }) = ev
-ctEvEvId (CtWanted { ctev_dest = HoleDest h }) = coHoleCoVar h
-ctEvEvId (CtGiven { ctev_evar = ev }) = ev
+ctEvEvId (CtWanted wtd) = wantedCtEvEvId wtd
+ctEvEvId (CtGiven (GivenCt { ctev_evar = ev })) = ev
+
+wantedCtEvEvId :: WantedCtEvidence -> EvVar
+wantedCtEvEvId (WantedCt { ctev_dest = EvVarDest ev }) = ev
+wantedCtEvEvId (WantedCt { ctev_dest = HoleDest h }) = coHoleCoVar h
ctEvUnique :: CtEvidence -> Unique
-ctEvUnique (CtGiven { ctev_evar = ev }) = varUnique ev
-ctEvUnique (CtWanted { ctev_dest = dest }) = tcEvDestUnique dest
+ctEvUnique (CtGiven (GivenCt { ctev_evar = ev })) = varUnique ev
+ctEvUnique (CtWanted (WantedCt { ctev_dest = dest })) = tcEvDestUnique dest
tcEvDestUnique :: TcEvDest -> Unique
tcEvDestUnique (EvVarDest ev_var) = varUnique ev_var
tcEvDestUnique (HoleDest co_hole) = varUnique (coHoleCoVar co_hole)
setCtEvLoc :: CtEvidence -> CtLoc -> CtEvidence
-setCtEvLoc ctev loc = ctev { ctev_loc = loc }
+setCtEvLoc (CtGiven (GivenCt pred evar _)) loc = CtGiven (GivenCt pred evar loc)
+setCtEvLoc (CtWanted (WantedCt pred dest _ rwrs)) loc = CtWanted (WantedCt pred dest loc rwrs)
-- | Set the type of CtEvidence.
--
@@ -2268,13 +2312,13 @@ setCtEvLoc ctev loc = ctev { ctev_loc = loc }
-- the evidence and the ctev_pred in sync with each other.
-- See Note [CtEvidence invariants].
setCtEvPredType :: HasDebugCallStack => CtEvidence -> Type -> CtEvidence
-setCtEvPredType old_ctev@(CtGiven { ctev_evar = ev }) new_pred
- = old_ctev { ctev_pred = new_pred
- , ctev_evar = setVarType ev new_pred }
+setCtEvPredType (CtGiven old_ev@(GivenCt { ctev_evar = ev })) new_pred
+ = CtGiven (old_ev { ctev_pred = new_pred
+ , ctev_evar = setVarType ev new_pred })
-setCtEvPredType old_ctev@(CtWanted { ctev_dest = dest }) new_pred
- = old_ctev { ctev_pred = new_pred
- , ctev_dest = new_dest }
+setCtEvPredType (CtWanted old_ev@(WantedCt { ctev_dest = dest })) new_pred
+ = CtWanted (old_ev { ctev_pred = new_pred
+ , ctev_dest = new_dest })
where
new_dest = case dest of
EvVarDest ev -> EvVarDest (setVarType ev new_pred)
@@ -2284,6 +2328,11 @@ instance Outputable TcEvDest where
ppr (HoleDest h) = text "hole" <> ppr h
ppr (EvVarDest ev) = ppr ev
+instance Outputable GivenCtEvidence where
+ ppr = ppr . CtGiven
+instance Outputable WantedCtEvidence where
+ ppr = ppr . CtWanted
+
instance Outputable CtEvidence where
ppr ev = ppr (ctEvFlavour ev)
<+> pp_ev <+> braces (ppr (ctl_depth (ctEvLoc ev)) <> pp_rewriters)
@@ -2291,8 +2340,8 @@ instance Outputable CtEvidence where
<> dcolon <+> ppr (ctEvPred ev)
where
pp_ev = case ev of
- CtGiven { ctev_evar = v } -> ppr v
- CtWanted {ctev_dest = d } -> ppr d
+ CtGiven ev -> ppr (ctev_evar ev)
+ CtWanted ev -> ppr (ctev_dest ev)
rewriters = ctEvRewriters ev
pp_rewriters | isEmptyRewriterSet rewriters = empty
@@ -2339,9 +2388,10 @@ rewriterSetFromCts :: Bag Ct -> RewriterSet
rewriterSetFromCts cts
= foldr add emptyRewriterSet cts
where
- add ct rw_set = case ctEvidence ct of
- CtWanted { ctev_dest = HoleDest hole } -> rw_set `addRewriter` hole
- _ -> rw_set
+ add ct rw_set =
+ case ctEvidence ct of
+ CtWanted (WantedCt { ctev_dest = HoleDest hole }) -> rw_set `addRewriter` hole
+ _ -> rw_set
{-
************************************************************************
@@ -2618,4 +2668,3 @@ eqCanRewriteFR (Given, r1) (_, r2) = eqCanRewrite r1 r2
eqCanRewriteFR (Wanted, NomEq) (Wanted, ReprEq) = False
eqCanRewriteFR (Wanted, r1) (Wanted, r2) = eqCanRewrite r1 r2
eqCanRewriteFR (Wanted, _) (Given, _) = False
-
diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs
index 0ff3bc528c12f1926c0f423a81b51ff7a8412b39..73c5719c580065a05cf1529d7c5572c34fc94033 100644
--- a/compiler/GHC/Tc/Utils/Backpack.hs
+++ b/compiler/GHC/Tc/Utils/Backpack.hs
@@ -1,4 +1,5 @@
+{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
@@ -221,7 +222,8 @@ check_inst sig_inst@(ClsInst { is_dfun = dfun_id }) = do
(tclvl,cts) <- pushTcLevelM $ do
given_ids <- mapM newEvVar inst_theta
let given_loc = mkGivenLoc topTcLevel skol_info (mkCtLocEnv lcl_env)
- givens = [ CtGiven { ctev_pred = idType given_id
+ givens = [ CtGiven $
+ GivenCt { ctev_pred = idType given_id
-- Doesn't matter, make something up
, ctev_evar = given_id
, ctev_loc = given_loc }
diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs
index 0bba873b65c12dc48bae08e566a9b29c3939d839..ea7c6cfff3517967918f453be56b9660b6a883c7 100644
--- a/compiler/GHC/Tc/Utils/TcMType.hs
+++ b/compiler/GHC/Tc/Utils/TcMType.hs
@@ -1,7 +1,8 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE MultiWayIf #-}
-{-# LANGUAGE RecursiveDo #-}
-{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE RecursiveDo #-}
+{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
{-
@@ -203,10 +204,11 @@ newWantedWithLoc loc pty
= do dst <- case classifyPredType pty of
EqPred {} -> HoleDest <$> newCoercionHole loc pty
_ -> EvVarDest <$> newEvVar pty
- return $ CtWanted { ctev_dest = dst
- , ctev_pred = pty
- , ctev_loc = loc
- , ctev_rewriters = emptyRewriterSet }
+ return $ CtWanted $
+ WantedCt { ctev_dest = dst
+ , ctev_pred = pty
+ , ctev_loc = loc
+ , ctev_rewriters = emptyRewriterSet }
-- | Create a new Wanted constraint with the given 'CtOrigin', and
-- location information taken from the 'TcM' environment.
@@ -226,10 +228,10 @@ newWanteds orig = mapM (newWanted orig Nothing)
----------------------------------------------
cloneWantedCtEv :: CtEvidence -> TcM CtEvidence
-cloneWantedCtEv ctev@(CtWanted { ctev_pred = pty, ctev_dest = HoleDest _, ctev_loc = loc })
+cloneWantedCtEv (CtWanted ctev@(WantedCt { ctev_pred = pty, ctev_dest = HoleDest _, ctev_loc = loc }))
| isEqPred pty
= do { co_hole <- newCoercionHole loc pty
- ; return (ctev { ctev_dest = HoleDest co_hole }) }
+ ; return $ CtWanted (ctev { ctev_dest = HoleDest co_hole }) }
| otherwise
= pprPanic "cloneWantedCtEv" (ppr pty)
cloneWantedCtEv ctev = return ctev
@@ -278,11 +280,11 @@ emitWantedEq :: CtOrigin -> TypeOrKind -> Role -> TcType -> TcType -> TcM Coerci
emitWantedEq origin t_or_k role ty1 ty2
= do { hole <- newCoercionHoleO origin pty
; loc <- getCtLocM origin (Just t_or_k)
- ; emitSimple $ mkNonCanonical $
- CtWanted { ctev_pred = pty
- , ctev_dest = HoleDest hole
- , ctev_loc = loc
- , ctev_rewriters = emptyRewriterSet }
+ ; emitSimple $ mkNonCanonical $ CtWanted $
+ WantedCt { ctev_pred = pty
+ , ctev_dest = HoleDest hole
+ , ctev_loc = loc
+ , ctev_rewriters = emptyRewriterSet }
; return (HoleCo hole) }
where
pty = mkEqPredRole role ty1 ty2
@@ -293,11 +295,11 @@ emitWantedEvVar :: CtOrigin -> TcPredType -> TcM EvVar
emitWantedEvVar origin ty
= do { new_cv <- newEvVar ty
; loc <- getCtLocM origin Nothing
- ; let ctev = CtWanted { ctev_pred = ty
+ ; let ctev = WantedCt { ctev_pred = ty
, ctev_dest = EvVarDest new_cv
, ctev_loc = loc
, ctev_rewriters = emptyRewriterSet }
- ; emitSimple $ mkNonCanonical ctev
+ ; emitSimple $ mkNonCanonical $ CtWanted ctev
; return new_cv }
emitWantedEvVars :: CtOrigin -> [TcPredType] -> TcM [EvVar]
diff --git a/compiler/GHC/Tc/Utils/Unify.hs b/compiler/GHC/Tc/Utils/Unify.hs
index 839ad4f54f4620e795bf987fef0ebc316f34d431..806b0678d2ec12a7ffbba9c2c44c1f25c8fc13f3 100644
--- a/compiler/GHC/Tc/Utils/Unify.hs
+++ b/compiler/GHC/Tc/Utils/Unify.hs
@@ -2145,11 +2145,11 @@ uType_defer (UE { u_loc = loc, u_defer = ref
ty1 ty2 -- ty1 is "actual", ty2 is "expected"
= do { let pred_ty = mkEqPredRole role ty1 ty2
; hole <- newCoercionHole loc pred_ty
- ; let ct = mkNonCanonical $
- CtWanted { ctev_pred = pred_ty
- , ctev_dest = HoleDest hole
- , ctev_loc = loc
- , ctev_rewriters = rewriters }
+ ; let ct = mkNonCanonical $ CtWanted $
+ WantedCt { ctev_pred = pred_ty
+ , ctev_dest = HoleDest hole
+ , ctev_loc = loc
+ , ctev_rewriters = rewriters }
co = HoleCo hole
; updTcRef ref (`snocBag` ct)
-- snocBag: see Note [Work-list ordering] in GHC.Tc.Solver.Equality
@@ -3403,11 +3403,11 @@ famAppBreaker (BreakWanted ev lhs_tv) fam_app
; let pty = mkNomEqPred fam_app new_tv_ty
; hole <- TcM.newVanillaCoercionHole pty
- ; let new_ev = CtWanted { ctev_pred = pty
+ ; let new_ev = WantedCt { ctev_pred = pty
, ctev_dest = HoleDest hole
, ctev_loc = cb_loc
, ctev_rewriters = ctEvRewriters ev }
- ; return (PuOK (singleCt (mkNonCanonical new_ev))
+ ; return (PuOK (singleCt (mkNonCanonical $ CtWanted new_ev))
(mkReduction (HoleCo hole) new_tv_ty)) } }
where
(lhs_tv_info, lhs_tv_lvl) =
@@ -4114,8 +4114,8 @@ makeTypeConcrete occ_fs conc_orig ty =
pty = mkEqPredRole Nominal ty' conc_ty
; hole <- newCoercionHoleO orig pty
; loc <- getCtLocM orig (Just KindLevel)
- ; let ct = mkNonCanonical
- $ CtWanted { ctev_pred = pty
+ ; let ct = mkNonCanonical $ CtWanted
+ $ WantedCt { ctev_pred = pty
, ctev_dest = HoleDest hole
, ctev_loc = loc
, ctev_rewriters = emptyRewriterSet }
diff --git a/compiler/GHC/Tc/Zonk/TcType.hs b/compiler/GHC/Tc/Zonk/TcType.hs
index 68d957bac07ebec152c82e6c4a427aabb1f94b0d..ab8ba3db7215a6199d38989d9c5ac9609323d620 100644
--- a/compiler/GHC/Tc/Zonk/TcType.hs
+++ b/compiler/GHC/Tc/Zonk/TcType.hs
@@ -1,4 +1,3 @@
-
{-
(c) The University of Glasgow 2006
(c) The AQUA Project, Glasgow University, 1996-1998
@@ -496,8 +495,7 @@ zonkCt ct
zonkCtEvidence :: CtEvidence -> ZonkM CtEvidence
zonkCtEvidence ctev
- = do { let pred = ctev_pred ctev
- ; pred' <- zonkTcType pred
+ = do { pred' <- zonkTcType (ctEvPred ctev)
; return (setCtEvPredType ctev pred') }
zonkSkolemInfo :: SkolemInfo -> ZonkM SkolemInfo
@@ -661,7 +659,7 @@ tidyCtEvidence :: TidyEnv -> CtEvidence -> CtEvidence
-- NB: we do not tidy the ctev_evar field because we don't
-- show it in error messages
tidyCtEvidence env ctev
- = ctev { ctev_pred = tidyOpenType env $ ctev_pred ctev }
+ = setCtEvPredType ctev (tidyOpenType env (ctEvPred ctev))
-- tidyOpenType: for (beta ~ (forall a. a->a), don't gratuitously
-- rename the 'forall a' just because of an 'a' in scope somewhere
-- else entirely.
diff --git a/compiler/GHC/Tc/Zonk/Type.hs b/compiler/GHC/Tc/Zonk/Type.hs
index e4c98454cf44bb8c5492e56f9ad4e5e7ccc25c85..88266d69578874a1948206e12948e43b2fc2c1f3 100644
--- a/compiler/GHC/Tc/Zonk/Type.hs
+++ b/compiler/GHC/Tc/Zonk/Type.hs
@@ -2002,9 +2002,9 @@ zonkCtRewriterSet ct
zonkCtEvRewriterSet :: CtEvidence -> TcM CtEvidence
zonkCtEvRewriterSet ev@(CtGiven {})
= return ev
-zonkCtEvRewriterSet ev@(CtWanted { ctev_rewriters = rewriters })
- = do { rewriters' <- zonkRewriterSet rewriters
- ; return (ev { ctev_rewriters = rewriters' }) }
+zonkCtEvRewriterSet ev@(CtWanted wtd)
+ = do { rewriters' <- zonkRewriterSet (ctEvRewriters ev)
+ ; return (CtWanted $ setWantedCtEvRewriters wtd rewriters') }
-- | Check whether any coercion hole in a RewriterSet is still unsolved.
-- Does this by recursively looking through filled coercion holes until