From a975c6634b0d202b21e0e719efb9900e44f85392 Mon Sep 17 00:00:00 2001
From: sheaf <sam.derbyshire@gmail.com>
Date: Wed, 9 Aug 2023 17:33:44 +0200
Subject: [PATCH] Use unsatisfiable for missing methods w/ defaults
When a class instance has an Unsatisfiable constraint in its context
and the user has not explicitly provided an implementation of a method,
we now always provide a RHS of the form `unsatisfiable @msg`, even
if the method has a default definition available. This ensures that,
when deferring type errors, users get the appropriate error message
instead of a possible runtime loop, if class default methods were
defined recursively.
Fixes #23816
---
compiler/GHC/Tc/Errors.hs | 8 ++-
compiler/GHC/Tc/TyCl/Instance.hs | 62 +++++++++++----------
testsuite/tests/unsatisfiable/T23816.hs | 18 ++++++
testsuite/tests/unsatisfiable/T23816.stderr | 6 ++
testsuite/tests/unsatisfiable/all.T | 2 +
5 files changed, 65 insertions(+), 31 deletions(-)
create mode 100644 testsuite/tests/unsatisfiable/T23816.hs
create mode 100644 testsuite/tests/unsatisfiable/T23816.stderr
diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs
index e14a655f627a..611be3c5d996 100644
--- a/compiler/GHC/Tc/Errors.hs
+++ b/compiler/GHC/Tc/Errors.hs
@@ -891,8 +891,8 @@ Its implementation consists of the following:
D. Adding "meth = unsatisfiable @msg" method bindings.
When a class instance has an "Unsatisfiable msg" constraint in its context,
- and the user has omitted methods (which don't have any default implementations),
- we add method bindings of the form "meth = unsatisfiable @msg".
+ and the user has omitted methods, we add method bindings of the form
+ "meth = unsatisfiable @msg".
See GHC.Tc.TyCl.Instance.tcMethods, in particular "tc_default".
Example:
@@ -909,6 +909,10 @@ Its implementation consists of the following:
We also switch off the "missing methods" warning in this situation.
See "checkMinimalDefinition" in GHC.Tc.TyCl.Instance.tcMethods.
+ Note that we do this even when there is a default method available. This
+ ensures we run into the unsatisfiable error message when deferring type
+ errors; otherwise we could end up with a runtime loop as seen in #23816.
+
E. Switching off functional dependency coverage checks when there is
an "Unsatisfiable msg" context.
diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs
index 29608cac69df..bb98c083754e 100644
--- a/compiler/GHC/Tc/TyCl/Instance.hs
+++ b/compiler/GHC/Tc/TyCl/Instance.hs
@@ -6,7 +6,6 @@
{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
@@ -1835,46 +1834,51 @@ tcMethods skol_info dfun_id clas tyvars dfun_ev_vars inst_tys
tc_default :: Id -> DefMethInfo
-> TcM (TcId, LHsBind GhcTc, Maybe Implication)
- tc_default sel_id (Just (dm_name, _))
- = do { (meth_bind, inline_prags) <- mkDefMethBind inst_loc dfun_id clas sel_id dm_name
+ tc_default sel_id mb_dm = case mb_dm of
+
+ -- If the instance has an "Unsatisfiable msg" context,
+ -- add method bindings that use "unsatisfiable".
+ --
+ -- See Note [Implementation of Unsatisfiable constraints],
+ -- in GHC.Tc.Errors, point (D).
+ _ | (theta_id,unsat_msg) : _ <- unsat_thetas
+ -> do { (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars
+ inst_tys sel_id
+ ; unsat_id <- tcLookupId unsatisfiableIdName
+ -- Recall that unsatisfiable :: forall {rep} (msg :: ErrorMessage) (a :: TYPE rep). Unsatisfiable msg => a
+ --
+ -- So we need to instantiate the forall and pass the dictionary evidence.
+ ; let meth_rhs = L inst_loc' $
+ wrapId
+ ( mkWpEvApps [EvExpr $ Var theta_id]
+ <.> mkWpTyApps [getRuntimeRep meth_tau, unsat_msg, meth_tau])
+ unsat_id
+ meth_bind = mkVarBind meth_id $ mkLHsWrap lam_wrapper meth_rhs
+ ; return (meth_id, meth_bind, Nothing) }
+
+ Just (dm_name, _) ->
+ do { (meth_bind, inline_prags) <- mkDefMethBind inst_loc dfun_id clas sel_id dm_name
; tcMethodBody skol_info clas tyvars dfun_ev_vars inst_tys
dfun_ev_binds is_derived hs_sig_fn
spec_inst_prags inline_prags
sel_id meth_bind inst_loc }
- tc_default sel_id Nothing -- No default method at all
- = do { traceTc "tc_def: warn" (ppr sel_id)
+ -- No default method
+ Nothing ->
+ do { traceTc "tc_def: warn" (ppr sel_id)
; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars
inst_tys sel_id
; dflags <- getDynFlags
- ; meth_rhs <-
- if
- -- If the instance has an "Unsatisfiable msg" context,
- -- add method bindings that use "unsatisfiable".
- --
- -- See Note [Implementation of Unsatisfiable constraints],
- -- in GHC.Tc.Errors, point (D).
- | (theta_id,unsat_msg):_ <- unsat_thetas
- -> do { unsat_id <- tcLookupId unsatisfiableIdName
- -- Recall that unsatisfiable :: forall {rep} (msg :: ErrorMessage) (a :: TYPE rep). Unsatisfiable msg => a
- --
- -- So we need to instantiate the forall and pass the dictionary evidence.
- ; return $ L inst_loc' $
- wrapId
- ( mkWpEvApps [EvExpr $ Var theta_id]
- <.> mkWpTyApps [getRuntimeRep meth_tau, unsat_msg, meth_tau])
- unsat_id }
-
- -- Otherwise, add bindings whose RHS is an error
- -- "No explicit nor default method for class operation 'meth'".
- | otherwise
- -> return $ error_rhs dflags
- ; let meth_bind = mkVarBind meth_id $ mkLHsWrap lam_wrapper meth_rhs
+ -- Add a binding whose RHS is an error
+ -- "No explicit nor default method for class operation 'meth'".
+ ; let meth_rhs = error_rhs dflags
+ meth_bind = mkVarBind meth_id $ mkLHsWrap lam_wrapper meth_rhs
; return (meth_id, meth_bind, Nothing) }
+
where
inst_loc' = noAnnSrcSpan inst_loc
error_rhs dflags = L inst_loc'
- $ HsApp noComments error_fun (error_msg dflags)
+ $ HsApp noComments error_fun (error_msg dflags)
error_fun = L inst_loc' $
wrapId (mkWpTyApps
[ getRuntimeRep meth_tau, meth_tau])
diff --git a/testsuite/tests/unsatisfiable/T23816.hs b/testsuite/tests/unsatisfiable/T23816.hs
new file mode 100644
index 000000000000..40b902bdc955
--- /dev/null
+++ b/testsuite/tests/unsatisfiable/T23816.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE DataKinds #-}
+
+module Main where
+
+import GHC.TypeError
+
+class C a where
+ meth1 :: a -> Bool
+ meth2 :: a -> Bool
+
+ meth1 = not . meth2
+ meth2 = not . meth1
+ {-# MINIMAL meth1 | meth2 #-}
+
+instance Unsatisfiable (Text "Msg") => C a
+
+main :: IO ()
+main = print (meth1 'x')
diff --git a/testsuite/tests/unsatisfiable/T23816.stderr b/testsuite/tests/unsatisfiable/T23816.stderr
new file mode 100644
index 000000000000..0bad829d1d81
--- /dev/null
+++ b/testsuite/tests/unsatisfiable/T23816.stderr
@@ -0,0 +1,6 @@
+T23816.exe: T23816.hs:18:15: error: [GHC-22250]
+ • Msg
+ • In the first argument of ‘print’, namely ‘(meth1 'x')’
+ In the expression: print (meth1 'x')
+ In an equation for ‘main’: main = print (meth1 'x')
+(deferred type error)
diff --git a/testsuite/tests/unsatisfiable/all.T b/testsuite/tests/unsatisfiable/all.T
index 2358c7eabce1..abd6d652f364 100644
--- a/testsuite/tests/unsatisfiable/all.T
+++ b/testsuite/tests/unsatisfiable/all.T
@@ -17,3 +17,5 @@ test('T11503_Unsat', normal, compile, ['-Woverlapping-patterns -Wincomplete-patt
test('T14141_Unsat', normal, compile, ['-Woverlapping-patterns -Wincomplete-patterns'])
test('T14339_Unsat', normal, compile_fail, [''])
test('T15232_Unsat', normal, compile, ['-Wredundant-constraints'])
+
+test('T23816', exit_code(1), compile_and_run, ['-fdefer-type-errors'])
--
GitLab