From b9c2aa3ff9acbdb80ee61519bb6ec74b5090413f Mon Sep 17 00:00:00 2001
From: sheaf <sam.derbyshire@gmail.com>
Date: Tue, 11 Jul 2023 13:40:13 +0200
Subject: [PATCH] Valid hole fits: don't panic on a Given
The function GHC.Tc.Errors.validHoleFits would end up panicking when
encountering a Given constraint. To fix this, it suffices to filter out
the Givens before continuing.
Fixes #22684
(cherry picked from commit 630e302617a4a3e00d86d0650cb86fa9e6913e44)
---
compiler/GHC/Tc/Errors.hs | 19 +++++-----
compiler/GHC/Tc/Errors/Types.hs | 4 ++-
.../tests/typecheck/should_fail/T22684.hs | 19 ++++++++++
.../tests/typecheck/should_fail/T22684.stderr | 35 +++++++++++++++++++
testsuite/tests/typecheck/should_fail/all.T | 1 +
5 files changed, 69 insertions(+), 9 deletions(-)
create mode 100644 testsuite/tests/typecheck/should_fail/T22684.hs
create mode 100644 testsuite/tests/typecheck/should_fail/T22684.stderr
diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs
index ec166205155..969fade07a5 100644
--- a/compiler/GHC/Tc/Errors.hs
+++ b/compiler/GHC/Tc/Errors.hs
@@ -1563,16 +1563,19 @@ validHoleFits :: SolverReportErrCtxt -- ^ The context we're in, i.e. the
-- the valid hole fits.
validHoleFits ctxt@(CEC { cec_encl = implics
, cec_tidy = lcl_env}) simps hole
- = do { (tidy_env, fits) <- findValidHoleFits lcl_env implics (map mk_wanted simps) hole
+ = do { (tidy_env, fits) <- findValidHoleFits lcl_env implics (mapMaybe mk_wanted simps) hole
; return (ctxt {cec_tidy = tidy_env}, fits) }
where
- mk_wanted :: ErrorItem -> CtEvidence
- mk_wanted (EI { ei_pred = pred, ei_evdest = Just dest, ei_loc = loc })
- = CtWanted { ctev_pred = pred
- , ctev_dest = dest
- , ctev_loc = loc
- , ctev_rewriters = emptyRewriterSet }
- mk_wanted item = pprPanic "validHoleFits no evdest" (ppr item)
+ 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 })
+ | otherwise
+ = Nothing -- The ErrorItem was a Given
+
-- See Note [Constraints include ...]
givenConstraints :: SolverReportErrCtxt -> [(Type, RealSrcSpan)]
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index 5da28d80880..d55b13f6834 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -4863,7 +4863,9 @@ data ErrorItem
= EI { ei_pred :: PredType -- report about this
-- The ei_pred field will never be an unboxed equality with
-- a (casted) tyvar on the right; this is guaranteed by the solver
- , ei_evdest :: Maybe TcEvDest -- for Wanteds, where to put evidence
+ , ei_evdest :: Maybe TcEvDest
+ -- ^ for Wanteds, where to put the evidence
+ -- for Givens, Nothing
, ei_flavour :: CtFlavour
, ei_loc :: CtLoc
, ei_m_reason :: Maybe CtIrredReason -- if this ErrorItem was made from a
diff --git a/testsuite/tests/typecheck/should_fail/T22684.hs b/testsuite/tests/typecheck/should_fail/T22684.hs
new file mode 100644
index 00000000000..60a95f3e14b
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T22684.hs
@@ -0,0 +1,19 @@
+module T22684 where
+
+-- Example 1 from #22684
+p :: (Int ~ Bool => r) -> r
+p _ = undefined
+
+q :: r
+q = p _
+
+-- Example 3 from #22684
+class Category k where
+ (.) :: k b c -> k a b -> k a c
+
+data Free p a b where
+ Prod :: Free p a (b, c)
+ Sum :: Free p (Either a b) c
+
+instance Category (Free p) where
+ Sum . Prod = _
diff --git a/testsuite/tests/typecheck/should_fail/T22684.stderr b/testsuite/tests/typecheck/should_fail/T22684.stderr
new file mode 100644
index 00000000000..cead5f8d902
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T22684.stderr
@@ -0,0 +1,35 @@
+
+T22684.hs:8:7: error: [GHC-88464]
+ • Found hole: _ :: r
+ Where: ‘r’ is a rigid type variable bound by
+ the type signature for:
+ q :: forall r. r
+ at T22684.hs:7:1-6
+ • In the first argument of ‘p’, namely ‘_’
+ In the expression: p _
+ In an equation for ‘q’: q = p _
+ • Relevant bindings include q :: r (bound at T22684.hs:8:1)
+ Constraints include Int ~ Bool (from T22684.hs:8:7)
+ Valid hole fits include q :: r (bound at T22684.hs:8:1)
+
+T22684.hs:19:16: error: [GHC-88464]
+ • Found hole: _ :: Free p a c
+ Where: ‘k’, ‘p’ are rigid type variables bound by
+ the instance declaration
+ at T22684.hs:18:10-26
+ ‘a’, ‘c’ are rigid type variables bound by
+ the type signature for:
+ (T22684..) :: forall b c a. Free p b c -> Free p a b -> Free p a c
+ at T22684.hs:19:7
+ • In an equation for ‘T22684..’: Sum T22684.. Prod = _
+ In the instance declaration for ‘Category (Free p)’
+ • Relevant bindings include
+ (.) :: Free p b c -> Free p a b -> Free p a c
+ (bound at T22684.hs:19:7)
+ Constraints include
+ b ~ (b2, c1) (from T22684.hs:19:9-12)
+ b ~ Either a1 b1 (from T22684.hs:19:3-5)
+ Valid hole fits include
+ q :: forall r. r
+ with q @(Free p a c)
+ (bound at T22684.hs:8:1)
diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T
index a1805014c85..d1d77f90536 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -696,3 +696,4 @@ test('VisFlag2', normal, compile_fail, [''])
test('VisFlag3', normal, compile_fail, [''])
test('VisFlag4', normal, compile_fail, [''])
test('VisFlag5', normal, compile_fail, [''])
+test('T22684', normal, compile_fail, [''])
--
GitLab