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)

6 files changed, 35 insertions, 3 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
 
diff --git a/testsuite/tests/quantified-constraints/T19921.stderr b/testsuite/tests/quantified-constraints/T19921.stderr
index 9c2b064204..7433fc6370 100644
--- a/testsuite/tests/quantified-constraints/T19921.stderr
+++ b/testsuite/tests/quantified-constraints/T19921.stderr
@@ -2,8 +2,8 @@
 T19921.hs:29:8: error:
     • Could not deduce r arising from a use of ‘Dict’
       from the context: (x \/ y) \/ z
-        bound by a quantified context at T19921.hs:1:1
+        bound by a quantified context at T19921.hs:29:8-11
       or from: (x ⇒ r, (y \/ z) ⇒ r)
-        bound by a quantified context at T19921.hs:1:1
+        bound by a quantified context at T19921.hs:29:8-11
     • In the expression: Dict
       In an equation for ‘dict’: dict = Dict
diff --git a/testsuite/tests/quantified-constraints/T21006.hs b/testsuite/tests/quantified-constraints/T21006.hs
new file mode 100644
index 0000000000..6c63216de0
--- /dev/null
+++ b/testsuite/tests/quantified-constraints/T21006.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE PolyKinds #-}
+
+module Err where
+
+import GHC.Exts (Constraint)
+
+class Determines b | -> b
+
+class (forall (b :: *) (c :: Constraint). (Determines b, Determines c) => c) => OpCode
+
+instance OpCode
diff --git a/testsuite/tests/quantified-constraints/T21006.stderr b/testsuite/tests/quantified-constraints/T21006.stderr
new file mode 100644
index 0000000000..aa5c5ef9a2
--- /dev/null
+++ b/testsuite/tests/quantified-constraints/T21006.stderr
@@ -0,0 +1,7 @@
+
+T21006.hs:14:10: error:
+    • Couldn't match kind ‘Constraint’ with ‘*’
+      When matching types
+        b :: *
+        c :: Constraint
+    • In the instance declaration for ‘OpCode’
diff --git a/testsuite/tests/quantified-constraints/all.T b/testsuite/tests/quantified-constraints/all.T
index 0754104319..d055adc848 100644
--- a/testsuite/tests/quantified-constraints/all.T
+++ b/testsuite/tests/quantified-constraints/all.T
@@ -32,3 +32,4 @@ test('T17458', normal, compile_fail, [''])
 test('T18432', normal, compile, [''])
 test('T19921', normal, compile_fail, [''])
 test('T16474', normal, compile_fail, [''])
+test('T21006', normal, compile_fail, [''])