diff options
| author | Simon Peyton Jones <simon.peytonjones@gmail.com> | 2022-01-26 11:42:36 +0000 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2022-01-27 18:37:17 -0500 |
| commit | f9ef2d26293d7e479d83e757986adffd197af502 (patch) | |
| tree | 2a7d967b4ce6e846fd6e94fc4c2fc5f789c16afb /compiler/GHC | |
| parent | 7f8ce19eb7400ae93661b173b5fc8ee6396da632 (diff) | |
| download | haskell-f9ef2d26293d7e479d83e757986adffd197af502.tar.gz | |
Set the TcLclEnv when solving a ForAll constraint
Fix a simple omission in GHC.Tc.Solver.Canonical.solveForAll,
where we ended up with the wrong TcLclEnv captured in an implication.
Result: unhelpful error message (#21006)
Diffstat (limited to 'compiler/GHC')
| -rw-r--r-- | compiler/GHC/Tc/Solver/Canonical.hs | 4 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Solver/Monad.hs | 8 |
2 files changed, 11 insertions, 1 deletions
diff --git a/compiler/GHC/Tc/Solver/Canonical.hs b/compiler/GHC/Tc/Solver/Canonical.hs index e07f2a4633..db1c3c1652 100644 --- a/compiler/GHC/Tc/Solver/Canonical.hs +++ b/compiler/GHC/Tc/Solver/Canonical.hs @@ -871,6 +871,10 @@ solveForAll :: CtEvidence -> [TyVar] -> TcThetaType -> PredType -> Bool solveForAll ev tvs theta pred pend_sc | CtWanted { ctev_dest = dest } <- ev = -- See Note [Solving a Wanted forall-constraint] + setLclEnv (ctLocEnv loc) $ + -- This setLclEnv is important: the emitImplicationTcS uses that + -- TcLclEnv for the implication, and that in turn sets the location + -- for the Givens when solving the constraint (#21006) do { let skol_info = QuantCtxtSkol empty_subst = mkEmptyTCvSubst $ mkInScopeSet $ tyCoVarsOfTypes (pred:theta) `delVarSetList` tvs diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs index a53074fab1..25bde37642 100644 --- a/compiler/GHC/Tc/Solver/Monad.hs +++ b/compiler/GHC/Tc/Solver/Monad.hs @@ -52,7 +52,7 @@ module GHC.Tc.Solver.Monad ( getSolvedDicts, setSolvedDicts, getInstEnvs, getFamInstEnvs, -- Getting the environments - getTopEnv, getGblEnv, getLclEnv, + getTopEnv, getGblEnv, getLclEnv, setLclEnv, getTcEvBindsVar, getTcLevel, getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap, tcLookupClass, tcLookupId, @@ -1247,6 +1247,9 @@ wrapTcS :: TcM a -> TcS a -- and TcS is supposed to have limited functionality wrapTcS action = mkTcS $ \_env -> action -- a TcM action will not use the TcEvBinds +wrap2TcS :: (TcM a -> TcM a) -> TcS a -> TcS a +wrap2TcS fn (TcS thing) = mkTcS $ \env -> fn (thing env) + wrapErrTcS :: TcM a -> TcS a -- The thing wrapped should just fail -- There's no static check; it's up to the user @@ -1780,6 +1783,9 @@ getGblEnv = wrapTcS $ TcM.getGblEnv getLclEnv :: TcS TcLclEnv getLclEnv = wrapTcS $ TcM.getLclEnv +setLclEnv :: TcLclEnv -> TcS a -> TcS a +setLclEnv env = wrap2TcS (TcM.setLclEnv env) + tcLookupClass :: Name -> TcS Class tcLookupClass c = wrapTcS $ TcM.tcLookupClass c |