Fix issue #18262 by zonking constraints after solving

Zonk residual constraints in checkForExistence to reveal user type
errors.

Previously when `:instances` was used with instances that have TypeError
constraints the result would look something like:

instance [safe] s0 => Err 'A -- Defined at ../Bug2.hs:8:10

whereas after zonking, `:instances` now sees the `TypeError` and
properly eliminates the constraint from the results.

6 files changed, 50 insertions, 17 deletions

diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs
index 3755d8d84f..e88dfc3277 100644
--- a/compiler/GHC/Runtime/Eval.hs
+++ b/compiler/GHC/Runtime/Eval.hs
@@ -118,11 +118,8 @@ import GHC.Tc.Module ( runTcInteractive, tcRnType, loadUnqualIfaces )
 import GHC.Tc.Utils.Zonk ( ZonkFlexi (SkolemiseFlexi) )
 import GHC.Tc.Utils.Env (tcGetInstEnvs)
 import GHC.Tc.Utils.Instantiate (instDFunType)
-import GHC.Tc.Solver (solveWanteds)
+import GHC.Tc.Solver (simplifyWantedsTcM)
 import GHC.Tc.Utils.Monad
-import GHC.Tc.Types.Evidence
-import Data.Bifunctor (second)
-import GHC.Tc.Solver.Monad (runTcS)
 import GHC.Core.Class (classTyCon)
 
 -- -----------------------------------------------------------------------------
@@ -1069,24 +1066,22 @@ parseInstanceHead str = withSession $ \hsc_env0 -> do
   return ty
 
 -- Get all the constraints required of a dictionary binding
-getDictionaryBindings :: PredType -> TcM WantedConstraints
+getDictionaryBindings :: PredType -> TcM CtEvidence
 getDictionaryBindings theta = do
   dictName <- newName (mkDictOcc (mkVarOcc "magic"))
   let dict_var = mkVanillaGlobal dictName theta
   loc <- getCtLocM (GivenOrigin UnkSkol) Nothing
 
-  -- Generate a wanted constraint here because at the end of constraint
+  -- Generate a wanted here because at the end of constraint
   -- solving, most derived constraints get thrown away, which in certain
   -- cases, notably with quantified constraints makes it impossible to rule
   -- out instances as invalid. (See #18071)
-  let wCs = mkSimpleWC [CtWanted {
+  return CtWanted {
     ctev_pred = varType dict_var,
     ctev_dest = EvVarDest dict_var,
     ctev_nosh = WDeriv,
     ctev_loc = loc
-  }]
-
-  return wCs
+  }
 
 -- Find instances where the head unifies with the provided type
 findMatchingInstances :: Type -> TcM [(ClsInst, [DFunInstType])]
@@ -1142,17 +1137,18 @@ checkForExistence clsInst mb_inst_tys = do
   -- thetas of clsInst.
   (tys, thetas) <- instDFunType (is_dfun clsInst) mb_inst_tys
   wanteds <- mapM getDictionaryBindings thetas
-  (residuals, _) <- second evBindMapBinds <$> runTcS (solveWanteds (unionsWC wanteds))
-
-  let WC { wc_simple = simples, wc_impl = impls } = (dropDerivedWC residuals)
+  -- It's important to zonk constraints after solving in order to expose things like TypeErrors
+  -- which otherwise appear as opaque type variables. (See #18262).
+  WC { wc_simple = simples, wc_impl = impls } <- simplifyWantedsTcM wanteds
 
-  let resPreds = mapBag ctPred simples
-
-  if allBag isSatisfiablePred resPreds && solvedImplics impls
-  then return . Just $ substInstArgs tys (bagToList resPreds) clsInst
+  if allBag allowedSimple simples && solvedImplics impls
+  then return . Just $ substInstArgs tys (bagToList (mapBag ctPred simples)) clsInst
   else return Nothing
 
   where
+  allowedSimple :: Ct -> Bool
+  allowedSimple ct = isSatisfiablePred (ctPred ct)
+
   solvedImplics :: Bag Implication -> Bool
   solvedImplics impls = allBag (isSolvedStatus . ic_status) impls
 
diff --git a/docs/users_guide/ghci.rst b/docs/users_guide/ghci.rst
index ce0734cfc2..390719ff80 100644
--- a/docs/users_guide/ghci.rst
+++ b/docs/users_guide/ghci.rst
@@ -2518,6 +2518,25 @@ commonly used commands.
          instance Show _ => Show (Maybe _) -- Defined in ‘GHC.Show’
          instance Read _ => Read (Maybe _) -- Defined in ‘GHC.Read’
 
+    Only instances which could potentially be used will be displayed in the results.
+    Instances which require unsatisfiable constraints such as ``TypeError`` will not be
+    included. In the following example, the instance for ``A`` is not shown because it cannot
+    be used.
+
+    .. code-block:: none
+        ghci>:set -XDataKinds -XUndecidableInstances
+        ghci>import GHC.TypeLits
+        ghci>class A a
+        ghci>instance (TypeError (Text "Not possible")) => A Bool
+        ghci>:instances Bool
+        instance Eq Bool -- Defined in ‘GHC.Classes’
+        instance Ord Bool -- Defined in ‘GHC.Classes’
+        instance Enum Bool -- Defined in ‘GHC.Enum’
+        instance Show Bool -- Defined in ‘GHC.Show’
+        instance Read Bool -- Defined in ‘GHC.Read’
+        instance Bounded Bool -- Defined in ‘GHC.Enum’
+
+
 .. ghci-cmd:: :issafe; [⟨module⟩]
 
     Displays Safe Haskell information about the given module (or the
diff --git a/testsuite/tests/ghci/T18262/T18262.hs b/testsuite/tests/ghci/T18262/T18262.hs
new file mode 100644
index 0000000000..1734de0179
--- /dev/null
+++ b/testsuite/tests/ghci/T18262/T18262.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE TypeFamilies, FlexibleInstances, DataKinds, UndecidableInstances #-}
+
+import GHC.TypeLits
+
+data C = A | B
+
+class Err (a :: C)
+
+instance (TypeError ('Text "uh-oh")) => Err 'A
+instance Err 'B
diff --git a/testsuite/tests/ghci/T18262/T18262.script b/testsuite/tests/ghci/T18262/T18262.script
new file mode 100644
index 0000000000..9b70743fad
--- /dev/null
+++ b/testsuite/tests/ghci/T18262/T18262.script
@@ -0,0 +1,6 @@
+:load T18262.hs
+:set -XDataKinds
+-- Should report no instances
+:instances 'A
+-- Should report an instance with no constraints
+:instances 'B
diff --git a/testsuite/tests/ghci/T18262/T18262.stdout b/testsuite/tests/ghci/T18262/T18262.stdout
new file mode 100644
index 0000000000..76d7e8a596
--- /dev/null
+++ b/testsuite/tests/ghci/T18262/T18262.stdout
@@ -0,0 +1 @@
+instance [safe] Err 'B -- Defined at T18262.hs:10:10
diff --git a/testsuite/tests/ghci/T18262/all.T b/testsuite/tests/ghci/T18262/all.T
new file mode 100644
index 0000000000..fe8e28fe6d
--- /dev/null
+++ b/testsuite/tests/ghci/T18262/all.T
@@ -0,0 +1 @@
+test('T18262', [extra_files(['T18262.hs'])], ghci_script, ['T18262.script'])