summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--compiler/GHC/Driver/Flags.hs3
-rw-r--r--compiler/GHC/Tc/Errors/Ppr.hs23
-rw-r--r--compiler/GHC/Tc/Errors/Types.hs17
-rw-r--r--compiler/GHC/Tc/Solver/InertSet.hs15
-rw-r--r--compiler/GHC/Tc/Solver/Interact.hs103
-rw-r--r--compiler/GHC/Tc/Solver/Monad.hs28
-rw-r--r--compiler/GHC/Tc/TyCl/Instance.hs14
-rw-r--r--compiler/GHC/Tc/Types/Origin.hs-boot4
-rw-r--r--compiler/GHC/Types/Error/Codes.hs1
-rw-r--r--compiler/GHC/Types/Hint.hs4
-rw-r--r--compiler/GHC/Types/Hint/Ppr.hs9
-rw-r--r--docs/users_guide/9.6.1-notes.rst28
-rw-r--r--docs/users_guide/using-warnings.rst16
-rw-r--r--testsuite/tests/quantified-constraints/all.T1
-rw-r--r--testsuite/tests/typecheck/should_compile/T20666b.hs12
-rw-r--r--testsuite/tests/typecheck/should_compile/T20666b.stderr10
-rw-r--r--testsuite/tests/typecheck/should_compile/T22891.hs9
-rw-r--r--testsuite/tests/typecheck/should_compile/T22891.stderr10
-rw-r--r--testsuite/tests/typecheck/should_compile/T22912.hs26
-rw-r--r--testsuite/tests/typecheck/should_compile/T22912.stderr12
-rw-r--r--testsuite/tests/typecheck/should_compile/all.T3
-rw-r--r--testsuite/tests/typecheck/should_fail/T20666.stderr36
-rw-r--r--testsuite/tests/typecheck/should_fail/T20666a.stderr18
-rw-r--r--testsuite/tests/typecheck/should_fail/T6161.stderr15
-rw-r--r--testsuite/tests/typecheck/should_fail/all.T8
-rw-r--r--testsuite/tests/typecheck/should_fail/tcfail223.stderr17
26 files changed, 342 insertions, 100 deletions
diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs
index 982d2e2f45..756d75f630 100644
--- a/compiler/GHC/Driver/Flags.hs
+++ b/compiler/GHC/Driver/Flags.hs
@@ -631,6 +631,7 @@ data WarningFlag =
| Opt_WarnGADTMonoLocalBinds -- Since 9.4
| Opt_WarnTypeEqualityOutOfScope -- Since 9.4
| Opt_WarnTypeEqualityRequiresOperators -- Since 9.4
+ | Opt_WarnLoopySuperclassSolve -- Since 9.6
| Opt_WarnTermVariableCapture -- Since 9.8
deriving (Eq, Ord, Show, Enum)
@@ -737,6 +738,7 @@ warnFlagNames wflag = case wflag of
Opt_WarnUnicodeBidirectionalFormatCharacters -> "unicode-bidirectional-format-characters" :| []
Opt_WarnGADTMonoLocalBinds -> "gadt-mono-local-binds" :| []
Opt_WarnTypeEqualityOutOfScope -> "type-equality-out-of-scope" :| []
+ Opt_WarnLoopySuperclassSolve -> "loopy-superclass-solve" :| []
Opt_WarnTypeEqualityRequiresOperators -> "type-equality-requires-operators" :| []
-- -----------------------------------------------------------------------------
@@ -853,6 +855,7 @@ standardWarnings -- see Note [Documenting warning flags]
Opt_WarnForallIdentifier,
Opt_WarnUnicodeBidirectionalFormatCharacters,
Opt_WarnGADTMonoLocalBinds,
+ Opt_WarnLoopySuperclassSolve,
Opt_WarnTypeEqualityRequiresOperators
]
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index 9880c13a9c..10d1c60fb1 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -8,6 +8,7 @@
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic TcRnMessage
+{-# LANGUAGE InstanceSigs #-}
module GHC.Tc.Errors.Ppr
( pprTypeDoesNotHaveFixedRuntimeRep
@@ -1305,7 +1306,18 @@ instance Diagnostic TcRnMessage where
, text "Combine alternative minimal complete definitions with `|'" ]
where
sigs = sig1 : sig2 : otherSigs
-
+ TcRnLoopySuperclassSolve wtd_loc wtd_pty ->
+ mkSimpleDecorated $ vcat [ header, warning, user_manual ]
+ where
+ header, warning, user_manual :: SDoc
+ header
+ = vcat [ text "I am solving the constraint" <+> quotes (ppr wtd_pty) <> comma
+ , nest 2 $ pprCtOrigin (ctLocOrigin wtd_loc) <> comma
+ , text "in a way that might turn out to loop at runtime." ]
+ warning
+ = vcat [ text "Future versions of GHC will turn this warning into an error." ]
+ user_manual =
+ vcat [ text "See the user manual, § Undecidable instances and loopy superclasses." ]
diagnosticReason = \case
TcRnUnknownMessage m
@@ -1734,6 +1746,8 @@ instance Diagnostic TcRnMessage where
-> ErrorWithoutFlag
TcRnDuplicateMinimalSig{}
-> ErrorWithoutFlag
+ TcRnLoopySuperclassSolve{}
+ -> WarningWithFlag Opt_WarnLoopySuperclassSolve
diagnosticHints = \case
TcRnUnknownMessage m
@@ -2173,6 +2187,13 @@ instance Diagnostic TcRnMessage where
-> noHints
TcRnDuplicateMinimalSig{}
-> noHints
+ TcRnLoopySuperclassSolve wtd_loc wtd_pty
+ -> [LoopySuperclassSolveHint wtd_pty cls_or_qc]
+ where
+ cls_or_qc :: ClsInstOrQC
+ cls_or_qc = case ctLocOrigin wtd_loc of
+ ScOrigin c_or_q _ -> c_or_q
+ _ -> IsClsInst -- shouldn't happen
diagnosticCode = constructorCode
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index c1b8461839..e2707b4aa4 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -2924,6 +2924,23 @@ data TcRnMessage where
-}
TcRnDuplicateMinimalSig :: LSig GhcPs -> LSig GhcPs -> [LSig GhcPs] -> TcRnMessage
+ {-| TcRnLoopySuperclassSolve is a warning, controlled by @-Wloopy-superclass-solve@,
+ that is triggered when GHC solves a constraint in a possibly-loopy way,
+ violating the class instance termination rules described in the section
+ "Undecidable instances and loopy superclasses" of the user's guide.
+
+ Example:
+
+ class Foo f
+ class Foo f => Bar f g
+ instance Bar f f => Bar f (h k)
+
+ Test cases: T20666, T20666{a,b}, T22891, T22912.
+ -}
+ TcRnLoopySuperclassSolve :: CtLoc -- ^ Wanted 'CtLoc'
+ -> PredType -- ^ Wanted 'PredType'
+ -> TcRnMessage
+
deriving Generic
-- | Things forbidden in @type data@ declarations.
diff --git a/compiler/GHC/Tc/Solver/InertSet.hs b/compiler/GHC/Tc/Solver/InertSet.hs
index 5dc3431b9a..60b422e1fc 100644
--- a/compiler/GHC/Tc/Solver/InertSet.hs
+++ b/compiler/GHC/Tc/Solver/InertSet.hs
@@ -1633,10 +1633,17 @@ mightEqualLater inert_set given_pred given_loc wanted_pred wanted_loc
= False
can_unify lhs_tv _other _rhs_ty = mentions_meta_ty_var lhs_tv
-prohibitedSuperClassSolve :: CtLoc -- ^ is it loopy to use this one ...
- -> CtLoc -- ^ ... to solve this one?
- -> Bool -- ^ True ==> don't solve it
--- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance, (sc2)
+-- | Is it (potentially) loopy to use the first @ct1@ to solve @ct2@?
+--
+-- Necessary (but not sufficient) conditions for this function to return @True@:
+--
+-- - @ct1@ and @ct2@ both arise from superclass expansion,
+-- - @ct1@ is a Given and @ct2@ is a Wanted.
+--
+-- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance, (sc2).
+prohibitedSuperClassSolve :: CtLoc -- ^ is it loopy to use this one ...
+ -> CtLoc -- ^ ... to solve this one?
+ -> Bool -- ^ True ==> don't solve it
prohibitedSuperClassSolve given_loc wanted_loc
| GivenSCOrigin _ _ blocked <- ctLocOrigin given_loc
, blocked
diff --git a/compiler/GHC/Tc/Solver/Interact.hs b/compiler/GHC/Tc/Solver/Interact.hs
index e69e7ae0fe..df53e39fcd 100644
--- a/compiler/GHC/Tc/Solver/Interact.hs
+++ b/compiler/GHC/Tc/Solver/Interact.hs
@@ -449,7 +449,7 @@ instance Outputable InteractResult where
solveOneFromTheOther :: Ct -- Inert (Dict or Irred)
-> Ct -- WorkItem (same predicate as inert)
- -> TcS InteractResult
+ -> InteractResult
-- Precondition:
-- * inert and work item represent evidence for the /same/ predicate
-- * Both are CDictCan or CIrredCan
@@ -461,28 +461,28 @@ solveOneFromTheOther :: Ct -- Inert (Dict or Irred)
solveOneFromTheOther ct_i ct_w
| CtWanted { ctev_loc = loc_w } <- ev_w
, prohibitedSuperClassSolve loc_i loc_w
+ -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance
= -- Inert must be Given
- do { traceTcS "prohibitedClassSolve1" (ppr ev_i $$ ppr ev_w)
- ; return KeepWork }
+ KeepWork
| CtWanted {} <- ev_w
= -- Inert is Given or Wanted
case ev_i of
- CtGiven {} -> return KeepInert
+ CtGiven {} -> KeepInert
-- work is Wanted; inert is Given: easy choice.
CtWanted {} -- Both are Wanted
-- If only one has no pending superclasses, use it
-- Otherwise we can get infinite superclass expansion (#22516)
-- in silly cases like class C T b => C a b where ...
- | not is_psc_i, is_psc_w -> return KeepInert
- | is_psc_i, not is_psc_w -> return KeepWork
+ | not is_psc_i, is_psc_w -> KeepInert
+ | is_psc_i, not is_psc_w -> KeepWork
-- If only one is a WantedSuperclassOrigin (arising from expanding
-- a Wanted class constraint), keep the other: wanted superclasses
-- may be unexpected by users
- | not is_wsc_orig_i, is_wsc_orig_w -> return KeepInert
- | is_wsc_orig_i, not is_wsc_orig_w -> return KeepWork
+ | not is_wsc_orig_i, is_wsc_orig_w -> KeepInert
+ | is_wsc_orig_i, not is_wsc_orig_w -> KeepWork
-- otherwise, just choose the lower span
-- reason: if we have something like (abs 1) (where the
@@ -490,29 +490,28 @@ solveOneFromTheOther ct_i ct_w
-- get an error about abs than about 1.
-- This test might become more elaborate if we see an
-- opportunity to improve the error messages
- | ((<) `on` ctLocSpan) loc_i loc_w -> return KeepInert
- | otherwise -> return KeepWork
+ | ((<) `on` ctLocSpan) loc_i loc_w -> KeepInert
+ | otherwise -> KeepWork
-- From here on the work-item is Given
| CtWanted { ctev_loc = loc_i } <- ev_i
, prohibitedSuperClassSolve loc_w loc_i
- = do { traceTcS "prohibitedClassSolve2" (ppr ev_i $$ ppr ev_w)
- ; return KeepInert } -- Just discard the un-usable Given
- -- This never actually happens because
- -- Givens get processed first
+ = KeepInert -- Just discard the un-usable Given
+ -- This never actually happens because
+ -- Givens get processed first
| CtWanted {} <- ev_i
- = return KeepWork
+ = KeepWork
-- From here on both are Given
-- See Note [Replacement vs keeping]
| lvl_i == lvl_w
- = return same_level_strategy
+ = same_level_strategy
| otherwise -- Both are Given, levels differ
- = return different_level_strategy
+ = different_level_strategy
where
ev_i = ctEvidence ct_i
ev_w = ctEvidence ct_w
@@ -662,14 +661,12 @@ interactIrred inerts ct_w@(CIrredCan { cc_ev = ev_w, cc_reason = reason })
, ((ct_i, swap) : _rest) <- bagToList matching_irreds
-- See Note [Multiple matching irreds]
, let ev_i = ctEvidence ct_i
- = do { what_next <- solveOneFromTheOther ct_i ct_w
- ; traceTcS "iteractIrred" $
+ = do { traceTcS "iteractIrred" $
vcat [ text "wanted:" <+> (ppr ct_w $$ ppr (ctOrigin ct_w))
- , text "inert: " <+> (ppr ct_i $$ ppr (ctOrigin ct_i))
- , ppr what_next ]
- ; case what_next of
+ , text "inert: " <+> (ppr ct_i $$ ppr (ctOrigin ct_i)) ]
+ ; case solveOneFromTheOther ct_i ct_w of
KeepInert -> do { setEvBindIfWanted ev_w (swap_me swap ev_i)
- ; return (Stop ev_w (text "Irred equal" <+> parens (ppr what_next))) }
+ ; return (Stop ev_w (text "Irred equal:KeepInert" <+> ppr ct_w)) }
KeepWork -> do { setEvBindIfWanted ev_i (swap_me swap ev_w)
; updInertIrreds (\_ -> others)
; continueWith ct_w } }
@@ -1007,7 +1004,9 @@ and Given/instance fundeps entirely.
interactDict :: InertCans -> Ct -> TcS (StopOrContinue Ct)
interactDict inerts ct_w@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs = tys })
| Just ct_i <- lookupInertDict inerts (ctEvLoc ev_w) cls tys
- , let ev_i = ctEvidence ct_i
+ , let ev_i = ctEvidence ct_i
+ loc_i = ctEvLoc ev_i
+ loc_w = ctEvLoc ev_w
= -- There is a matching dictionary in the inert set
do { -- First to try to solve it /completely/ from top level instances
-- See Note [Shortcut solving]
@@ -1015,16 +1014,24 @@ interactDict inerts ct_w@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs = t
; short_cut_worked <- shortCutSolver dflags ev_w ev_i
; if short_cut_worked
then stopWith ev_w "interactDict/solved from instance"
- else
- do { -- Ths short-cut solver didn't fire, so we
- -- solve ev_w from the matching inert ev_i we found
- what_next <- solveOneFromTheOther ct_i ct_w
- ; traceTcS "lookupInertDict" (ppr what_next)
- ; case what_next of
- KeepInert -> do { setEvBindIfWanted ev_w (ctEvTerm ev_i)
- ; return $ Stop ev_w (text "Dict equal" <+> parens (ppr what_next)) }
- KeepWork -> do { setEvBindIfWanted ev_i (ctEvTerm ev_w)
+ -- Next see if we are in "loopy-superclass" land. If so,
+ -- we don't want to replace the (Given) inert with the
+ -- (Wanted) work-item, or vice versa; we want to hang on
+ -- to both, and try to solve the work-item via an instance.
+ -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance
+ else if prohibitedSuperClassSolve loc_i loc_w
+ then continueWith ct_w
+ else
+ do { -- The short-cut solver didn't fire, and loopy superclasses
+ -- are dealt with, so we can either solve
+ -- the inert from the work-item or vice-versa.
+ ; case solveOneFromTheOther ct_i ct_w of
+ KeepInert -> do { traceTcS "lookupInertDict:KeepInert" (ppr ct_w)
+ ; setEvBindIfWanted ev_w (ctEvTerm ev_i)
+ ; return $ Stop ev_w (text "Dict equal" <+> ppr ct_w) }
+ KeepWork -> do { traceTcS "lookupInertDict:KeepWork" (ppr ct_w)
+ ; setEvBindIfWanted ev_i (ctEvTerm ev_w)
; updInertDicts $ \ ds -> delDict ds cls tys
; continueWith ct_w } } }
@@ -1894,7 +1901,7 @@ as the fundeps.
#7875 is a case in point.
-}
-doTopFundepImprovement :: Ct -> TcS (StopOrContinue Ct)
+doTopFundepImprovement :: Ct -> TcS ()
-- Try to functional-dependency improvement between the constraint
-- and the top-level instance declarations
-- See Note [Fundeps with instances, and equality orientation]
@@ -1904,8 +1911,7 @@ doTopFundepImprovement work_item@(CDictCan { cc_ev = ev, cc_class = cls
= do { traceTcS "try_fundeps" (ppr work_item)
; instEnvs <- getInstEnvs
; let fundep_eqns = improveFromInstEnv instEnvs mk_ct_loc cls xis
- ; emitFunDepWanteds (ctEvRewriters ev) fundep_eqns
- ; continueWith work_item }
+ ; emitFunDepWanteds (ctEvRewriters ev) fundep_eqns }
where
dict_pred = mkClassPred cls xis
dict_loc = ctEvLoc ev
@@ -2276,14 +2282,35 @@ doTopReactDict inerts work_item@(CDictCan { cc_ev = ev, cc_class = cls
; chooseInstance work_item lkup_res }
_ -> -- NoInstance or NotSure
-- We didn't solve it; so try functional dependencies with
- -- the instance environment, and return
- doTopFundepImprovement work_item }
+ -- the instance environment
+ do { doTopFundepImprovement work_item
+ ; tryLastResortProhibitedSuperclass inerts work_item } }
where
dict_loc = ctEvLoc ev
doTopReactDict _ w = pprPanic "doTopReactDict" (ppr w)
+-- | As a last resort, we TEMPORARILY allow a prohibited superclass solve,
+-- emitting a loud warning when doing so: we might be creating non-terminating
+-- evidence (as we are in T22912 for example).
+--
+-- See Note [Migrating away from loopy superclass solving] in GHC.Tc.TyCl.Instance.
+tryLastResortProhibitedSuperclass :: InertSet -> Ct -> TcS (StopOrContinue Ct)
+tryLastResortProhibitedSuperclass inerts
+ work_item@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs = xis })
+ | let loc_w = ctEvLoc ev_w
+ orig_w = ctLocOrigin loc_w
+ , ScOrigin _ NakedSc <- orig_w -- work_item is definitely Wanted
+ , Just ct_i <- lookupInertDict (inert_cans inerts) loc_w cls xis
+ , let ev_i = ctEvidence ct_i
+ , isGiven ev_i
+ = do { setEvBindIfWanted ev_w (ctEvTerm ev_i)
+ ; ctLocWarnTcS loc_w $
+ TcRnLoopySuperclassSolve loc_w (ctPred work_item)
+ ; return $ Stop ev_w (text "Loopy superclass") }
+tryLastResortProhibitedSuperclass _ work_item
+ = continueWith work_item
chooseInstance :: Ct -> ClsInstResult -> TcS (StopOrContinue Ct)
chooseInstance work_item
diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs
index b9a9354eff..7ff59baf4e 100644
--- a/compiler/GHC/Tc/Solver/Monad.hs
+++ b/compiler/GHC/Tc/Solver/Monad.hs
@@ -15,7 +15,7 @@ module GHC.Tc.Solver.Monad (
-- The TcS monad
TcS, runTcS, runTcSEarlyAbort, runTcSWithEvBinds, runTcSInerts,
- failTcS, warnTcS, addErrTcS, wrapTcS,
+ failTcS, warnTcS, addErrTcS, wrapTcS, ctLocWarnTcS,
runTcSEqualities,
nestTcS, nestImplicTcS, setEvBindsTcS,
emitImplicationTcS, emitTvImplicationTcS,
@@ -673,16 +673,18 @@ lookupInInerts :: CtLoc -> TcPredType -> TcS (Maybe CtEvidence)
lookupInInerts loc pty
| ClassPred cls tys <- classifyPredType pty
= do { inerts <- getTcSInerts
- ; return $ -- Maybe monad
- do { found_ev <-
- lookupSolvedDict inerts loc cls tys `mplus`
- fmap ctEvidence (lookupInertDict (inert_cans inerts) loc cls tys)
- ; guard (not (prohibitedSuperClassSolve (ctEvLoc found_ev) loc))
- -- We're about to "solve" the wanted we're looking up, so we
- -- must make sure doing so wouldn't run afoul of
- -- Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance.
- -- Forgetting this led to #20666.
- ; return found_ev }}
+ ; let mb_solved = lookupSolvedDict inerts loc cls tys
+ mb_inert = fmap ctEvidence (lookupInertDict (inert_cans inerts) loc cls tys)
+ ; return $ do -- Maybe monad
+ found_ev <- mb_solved `mplus` mb_inert
+
+ -- We're about to "solve" the wanted we're looking up, so we
+ -- must make sure doing so wouldn't run afoul of
+ -- Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance.
+ -- Forgetting this led to #20666.
+ guard $ not (prohibitedSuperClassSolve (ctEvLoc found_ev) loc)
+
+ return found_ev }
| otherwise -- NB: No caching for equalities, IPs, holes, or errors
= return Nothing
@@ -855,6 +857,10 @@ warnTcS msg = wrapTcS (TcM.addDiagnostic msg)
addErrTcS = wrapTcS . TcM.addErr
panicTcS doc = pprPanic "GHC.Tc.Solver.Canonical" doc
+-- | Emit a warning within the 'TcS' monad at the location given by the 'CtLoc'.
+ctLocWarnTcS :: CtLoc -> TcRnMessage -> TcS ()
+ctLocWarnTcS loc msg = wrapTcS $ TcM.setCtLocM loc $ TcM.addDiagnostic msg
+
traceTcS :: String -> SDoc -> TcS ()
traceTcS herald doc = wrapTcS (TcM.traceTc herald doc)
{-# INLINE traceTcS #-} -- see Note [INLINE conditional tracing utilities]
diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs
index 3d9b5dd550..9213ceeab2 100644
--- a/compiler/GHC/Tc/TyCl/Instance.hs
+++ b/compiler/GHC/Tc/TyCl/Instance.hs
@@ -1661,6 +1661,20 @@ Answer:
superclass selection, except at a smaller type. This test is
implemented by GHC.Tc.Solver.InertSet.prohibitedSuperClassSolve
+Note [Migrating away from loopy superclass solving]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The logic from Note [Solving superclass constraints] was implemented in GHC 9.6.
+However, we want to provide a migration strategy for users, to avoid suddenly
+breaking their code going when upgrading to GHC 9.6. To this effect, we temporarily
+continue to allow the constraint solver to create these potentially non-terminating
+solutions, but emit a loud warning when doing so: see
+GHC.Tc.Solver.Interact.tryLastResortProhibitedSuperclass.
+
+Users can silence the warning by manually adding the necessary constraint to the
+context. GHC will then keep this user-written Given, dropping the Given arising
+from superclass expansion which has greater SC depth, as explained in
+Note [Replacement vs keeping] in GHC.Tc.Solver.Interact.
+
Note [Silent superclass arguments] (historical interest only)
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
NB1: this note describes our *old* solution to the
diff --git a/compiler/GHC/Tc/Types/Origin.hs-boot b/compiler/GHC/Tc/Types/Origin.hs-boot
index eecb8cb490..a84c44cf4a 100644
--- a/compiler/GHC/Tc/Types/Origin.hs-boot
+++ b/compiler/GHC/Tc/Types/Origin.hs-boot
@@ -7,4 +7,8 @@ data SkolemInfo
data FixedRuntimeRepContext
data FixedRuntimeRepOrigin
+data CtOrigin
+data ClsInstOrQC = IsClsInst
+ | IsQC CtOrigin
+
unkSkol :: HasCallStack => SkolemInfo
diff --git a/compiler/GHC/Types/Error/Codes.hs b/compiler/GHC/Types/Error/Codes.hs
index d7b57113ee..bae5e1ccfb 100644
--- a/compiler/GHC/Types/Error/Codes.hs
+++ b/compiler/GHC/Types/Error/Codes.hs
@@ -512,6 +512,7 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "TcRnUnexpectedDefaultSig" = 40700
GhcDiagnosticCode "TcRnBindInBootFile" = 11247
GhcDiagnosticCode "TcRnDuplicateMinimalSig" = 85346
+ GhcDiagnosticCode "TcRnLoopySuperclassSolve" = 36038
-- IllegalNewtypeReason
GhcDiagnosticCode "DoesNotHaveSingleField" = 23517
diff --git a/compiler/GHC/Types/Hint.hs b/compiler/GHC/Types/Hint.hs
index 9f897feb7f..654d798ef7 100644
--- a/compiler/GHC/Types/Hint.hs
+++ b/compiler/GHC/Types/Hint.hs
@@ -32,11 +32,13 @@ import GHC.Unit.Module (ModuleName, Module)
import GHC.Hs.Extension (GhcTc)
import GHC.Core.Coercion
import GHC.Core.FamInstEnv (FamFlavor)
+import GHC.Core.Type (PredType)
import GHC.Types.Fixity (LexicalFixity(..))
import GHC.Types.Name (Name, NameSpace, OccName (occNameFS), isSymOcc, nameOccName)
import GHC.Types.Name.Reader (RdrName (Unqual), ImpDeclSpec)
import GHC.Types.SrcLoc (SrcSpan)
import GHC.Types.Basic (Activation, RuleName)
+import {-# SOURCE #-} GHC.Tc.Types.Origin ( ClsInstOrQC(..) )
import GHC.Parser.Errors.Basic
import {-# SOURCE #-} Language.Haskell.Syntax.Expr
import GHC.Unit.Module.Imported (ImportedModsVal)
@@ -429,6 +431,8 @@ data GhcHint
-}
| SuggestRenameTypeVariable
+ | LoopySuperclassSolveHint PredType ClsInstOrQC
+
-- | An 'InstantiationSuggestion' for a '.hsig' file. This is generated
-- by GHC in case of a 'DriverUnexpectedSignature' and suggests a way
-- to instantiate a particular signature, where the first argument is
diff --git a/compiler/GHC/Types/Hint/Ppr.hs b/compiler/GHC/Types/Hint/Ppr.hs
index 96fbd9f74f..32e1b38bb2 100644
--- a/compiler/GHC/Types/Hint/Ppr.hs
+++ b/compiler/GHC/Types/Hint/Ppr.hs
@@ -14,6 +14,7 @@ import GHC.Types.Hint
import GHC.Core.FamInstEnv (FamFlavor(..))
import GHC.Hs.Expr () -- instance Outputable
+import {-# SOURCE #-} GHC.Tc.Types.Origin ( ClsInstOrQC(..) )
import GHC.Types.Id
import GHC.Types.Name (NameSpace, pprDefinedAt, occNameSpace, pprNameSpace, isValNameSpace, nameModule)
import GHC.Types.Name.Reader (RdrName,ImpDeclSpec (..), rdrNameOcc, rdrNameSpace)
@@ -214,6 +215,14 @@ instance Outputable GhcHint where
mod = nameModule name
SuggestRenameTypeVariable
-> text "Consider renaming the type variable."
+ LoopySuperclassSolveHint pty cls_or_qc
+ -> vcat [ text "Add the constraint" <+> quotes (ppr pty) <+> text "to the" <+> what <> comma
+ , text "even though it seems logically implied by other constraints in the context." ]
+ where
+ what :: SDoc
+ what = case cls_or_qc of
+ IsClsInst -> text "instance context"
+ IsQC {} -> text "context of the quantified constraint"
perhapsAsPat :: SDoc
perhapsAsPat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace"
diff --git a/docs/users_guide/9.6.1-notes.rst b/docs/users_guide/9.6.1-notes.rst
index 34e7723092..36067df41c 100644
--- a/docs/users_guide/9.6.1-notes.rst
+++ b/docs/users_guide/9.6.1-notes.rst
@@ -3,10 +3,36 @@
Version 9.6.1
==============
-
Language
~~~~~~~~
+- GHC is now more conservative when solving constraints that arise from
+ superclass expansion in terms of other constraints that also arise from
+ superclass expansion.
+
+ For example: ::
+
+ class C a
+ class C a => D a b
+ instance D a a => D a b
+
+ When typechecking the instance, we need to also solve the constraints arising
+ from the superclasses of ``D``; in this case, we need ``C a``. We could obtain
+ evidence for this constraint by expanding the superclasses of the context,
+ as ``D a a`` also has a superclass context of ``C a``.
+ However, is it unsound to do so in general, as we might be assuming precisely
+ the predicate we want to prove! This can lead to programs that loop at runtime.
+
+ When such potentially-loopy situations arise, GHC now emits a warning.
+ In future releases, this behaviour will no longer be supported, and the
+ typechecker will outright refuse to solve these constraints, emitting a
+ ``Could not deduce`` error.
+
+ In practice, you should be able to fix these issues by adding the necessary
+ constraint to the context, e.g. for the above example: ::
+
+ instance (C a, D a a) => D a b
+
- Record updates for GADTs and other existential datatypes are now
fully supported.
diff --git a/docs/users_guide/using-warnings.rst b/docs/users_guide/using-warnings.rst
index 2c70006a7c..3624a63384 100644
--- a/docs/users_guide/using-warnings.rst
+++ b/docs/users_guide/using-warnings.rst
@@ -2319,6 +2319,22 @@ of ``-W(no-)*``.
triggered whenever this happens, and can be addressed by enabling the
extension.
+.. ghc-flag:: -Wloopy-superclass-solve
+ :shortdesc: warn when creating potentially-loopy superclass constraint evidence
+ :type: dynamic
+ :reverse: -Wno-loopy-superclass-solve
+
+ :since: 9.6.1
+
+ As explained in :ref:`undecidable_instances`, when using
+ :extension:`UndecidableInstances` it is possible for GHC to construct
+ non-terminating evidence for certain superclass constraints.
+
+ This behaviour is scheduled to be removed in a future GHC version.
+ In the meantime, GHC emits this warning to inform users of potential
+ non-termination. Users can manually add the required constraint to the context
+ to avoid the problem (thus silencing the warning).
+
.. ghc-flag:: -Wterm-variable-capture
:shortdesc: warn when an implicitly quantified type variable captures a term's name
:type: dynamic
diff --git a/testsuite/tests/quantified-constraints/all.T b/testsuite/tests/quantified-constraints/all.T
index b3d0eb920f..d3bfe6e07e 100644
--- a/testsuite/tests/quantified-constraints/all.T
+++ b/testsuite/tests/quantified-constraints/all.T
@@ -41,3 +41,4 @@ test('T22216d', normal, compile, [''])
test('T22216e', normal, compile, [''])
test('T22223', normal, compile, [''])
test('T19690', normal, compile_fail, [''])
+
diff --git a/testsuite/tests/typecheck/should_compile/T20666b.hs b/testsuite/tests/typecheck/should_compile/T20666b.hs
new file mode 100644
index 0000000000..7a655b73c9
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T20666b.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module T20666b where
+
+type family F a
+
+class Eq (F a) => D a
+class Eq (F a) => C a
+
+instance D [a] => C [a]
+
diff --git a/testsuite/tests/typecheck/should_compile/T20666b.stderr b/testsuite/tests/typecheck/should_compile/T20666b.stderr
new file mode 100644
index 0000000000..322c6850ea
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T20666b.stderr
@@ -0,0 +1,10 @@
+
+T20666b.hs:11:10: warning: [GHC-36038] [-Wloopy-superclass-solve (in -Wdefault)]
+ I am solving the constraint ‘Eq (F [a])’,
+ arising from the superclasses of an instance declaration,
+ in a way that might turn out to loop at runtime.
+ Future versions of GHC will turn this warning into an error.
+ See the user manual, § Undecidable instances and loopy superclasses.
+ Suggested fix:
+ Add the constraint ‘Eq (F [a])’ to the instance context,
+ even though it seems logically implied by other constraints in the context.
diff --git a/testsuite/tests/typecheck/should_compile/T22891.hs b/testsuite/tests/typecheck/should_compile/T22891.hs
new file mode 100644
index 0000000000..ad6b473395
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T22891.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE UndecidableInstances #-}
+
+module T22891 where
+
+class Foo f
+
+class Foo f => Bar f g
+
+instance Bar f f => Bar f (h k)
diff --git a/testsuite/tests/typecheck/should_compile/T22891.stderr b/testsuite/tests/typecheck/should_compile/T22891.stderr
new file mode 100644
index 0000000000..a0bdc1649b
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T22891.stderr
@@ -0,0 +1,10 @@
+
+T22891.hs:9:10: warning: [GHC-36038] [-Wloopy-superclass-solve (in -Wdefault)]
+ I am solving the constraint ‘Foo f’,
+ arising from the superclasses of an instance declaration,
+ in a way that might turn out to loop at runtime.
+ Future versions of GHC will turn this warning into an error.
+ See the user manual, § Undecidable instances and loopy superclasses.
+ Suggested fix:
+ Add the constraint ‘Foo f’ to the instance context,
+ even though it seems logically implied by other constraints in the context.
diff --git a/testsuite/tests/typecheck/should_compile/T22912.hs b/testsuite/tests/typecheck/should_compile/T22912.hs
new file mode 100644
index 0000000000..994a8022ef
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T22912.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE MonoLocalBinds #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE UndecidableSuperClasses #-}
+
+module T22912 where
+
+
+class c => Exactly c
+instance c => Exactly c
+class c => Implies c
+
+data Dict c = c => Dict
+
+anythingDict :: forall c. Dict c
+anythingDict = go
+ where
+ go :: (Exactly (Implies c) => Implies c) => Dict c
+ go = Dict
+
+-- This is clearly wrong: we shouldn't be able to produce evidence
+-- for any constraint whatsoever! However, GHC can be tricked into
+-- producing a bottom dictionary.
+-- This test checks that it emits an appropriate warning when doing so,
+-- to allow users to adapt their code before we plug the hole completely.
diff --git a/testsuite/tests/typecheck/should_compile/T22912.stderr b/testsuite/tests/typecheck/should_compile/T22912.stderr
new file mode 100644
index 0000000000..b53614baff
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T22912.stderr
@@ -0,0 +1,12 @@
+
+T22912.hs:17:16: warning: [GHC-36038] [-Wloopy-superclass-solve (in -Wdefault)]
+ I am solving the constraint ‘Implies c’,
+ arising from the head of a quantified constraint
+ arising from a use of ‘go’,
+ in a way that might turn out to loop at runtime.
+ Future versions of GHC will turn this warning into an error.
+ See the user manual, § Undecidable instances and loopy superclasses.
+ Suggested fix:
+ Add the constraint ‘Implies
+ c’ to the context of the quantified constraint,
+ even though it seems logically implied by other constraints in the context.
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index 07d39cebd3..ff603bbcf3 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -857,3 +857,6 @@ test('T22647', normal, compile, [''])
test('T19577', normal, compile, [''])
test('T22383', normal, compile, [''])
test('T21501', normal, compile, [''])
+test('T20666b', normal, compile, [''])
+test('T22891', normal, compile, [''])
+test('T22912', normal, compile, [''])
diff --git a/testsuite/tests/typecheck/should_fail/T20666.stderr b/testsuite/tests/typecheck/should_fail/T20666.stderr
index bc2aad5497..46d0fafcc4 100644
--- a/testsuite/tests/typecheck/should_fail/T20666.stderr
+++ b/testsuite/tests/typecheck/should_fail/T20666.stderr
@@ -1,20 +1,20 @@
-T20666.hs:13:10: error: [GHC-39999]
- • Could not deduce ‘Show (T c)’
- arising from the superclasses of an instance declaration
- from the context: (D d, c ~ S d)
- bound by the instance declaration at T20666.hs:13:10-31
- Possible fix:
- If the constraint looks soluble from a superclass of the instance context,
- read 'Undecidable instances and loopy superclasses' in the user manual
- • In the instance declaration for ‘C1 c’
+T20666.hs:13:10: warning: [GHC-36038] [-Wloopy-superclass-solve (in -Wdefault)]
+ I am solving the constraint ‘Show (T c)’,
+ arising from the superclasses of an instance declaration,
+ in a way that might turn out to loop at runtime.
+ Future versions of GHC will turn this warning into an error.
+ See the user manual, § Undecidable instances and loopy superclasses.
+ Suggested fix:
+ Add the constraint ‘Show (T c)’ to the instance context,
+ even though it seems logically implied by other constraints in the context.
-T20666.hs:17:10: error: [GHC-39999]
- • Could not deduce ‘Show (T c)’
- arising from the superclasses of an instance declaration
- from the context: (D d, c ~ S d, c' ~ c)
- bound by the instance declaration at T20666.hs:17:10-40
- Possible fix:
- If the constraint looks soluble from a superclass of the instance context,
- read 'Undecidable instances and loopy superclasses' in the user manual
- • In the instance declaration for ‘C2 c'’
+T20666.hs:17:10: warning: [GHC-36038] [-Wloopy-superclass-solve (in -Wdefault)]
+ I am solving the constraint ‘Show (T c)’,
+ arising from the superclasses of an instance declaration,
+ in a way that might turn out to loop at runtime.
+ Future versions of GHC will turn this warning into an error.
+ See the user manual, § Undecidable instances and loopy superclasses.
+ Suggested fix:
+ Add the constraint ‘Show (T c)’ to the instance context,
+ even though it seems logically implied by other constraints in the context.
diff --git a/testsuite/tests/typecheck/should_fail/T20666a.stderr b/testsuite/tests/typecheck/should_fail/T20666a.stderr
index 4192b88807..bed585dcd2 100644
--- a/testsuite/tests/typecheck/should_fail/T20666a.stderr
+++ b/testsuite/tests/typecheck/should_fail/T20666a.stderr
@@ -1,10 +1,10 @@
-T20666a.hs:11:10: error: [GHC-39999]
- • Could not deduce ‘Eq (F [a])’
- arising from the superclasses of an instance declaration
- from the context: D [a]
- bound by the instance declaration at T20666a.hs:11:10-23
- Possible fix:
- If the constraint looks soluble from a superclass of the instance context,
- read 'Undecidable instances and loopy superclasses' in the user manual
- • In the instance declaration for ‘C [a]’
+T20666a.hs:11:10: warning: [GHC-36038] [-Wloopy-superclass-solve (in -Wdefault)]
+ I am solving the constraint ‘Eq (F [a])’,
+ arising from the superclasses of an instance declaration,
+ in a way that might turn out to loop at runtime.
+ Future versions of GHC will turn this warning into an error.
+ See the user manual, § Undecidable instances and loopy superclasses.
+ Suggested fix:
+ Add the constraint ‘Eq (F [a])’ to the instance context,
+ even though it seems logically implied by other constraints in the context.
diff --git a/testsuite/tests/typecheck/should_fail/T6161.stderr b/testsuite/tests/typecheck/should_fail/T6161.stderr
index 71c7455abd..c1daab09df 100644
--- a/testsuite/tests/typecheck/should_fail/T6161.stderr
+++ b/testsuite/tests/typecheck/should_fail/T6161.stderr
@@ -1,7 +1,10 @@
-T6161.hs:19:10: error: [GHC-39999]
- • Could not deduce ‘Super (Fam a)’
- arising from the superclasses of an instance declaration
- from the context: Foo a
- bound by the instance declaration at T6161.hs:19:10-31
- • In the instance declaration for ‘Duper (Fam a)’
+T6161.hs:19:10: warning: [GHC-36038] [-Wloopy-superclass-solve (in -Wdefault)]
+ I am solving the constraint ‘Super (Fam a)’,
+ arising from the superclasses of an instance declaration,
+ in a way that might turn out to loop at runtime.
+ Future versions of GHC will turn this warning into an error.
+ See the user manual, § Undecidable instances and loopy superclasses.
+ Suggested fix:
+ Add the constraint ‘Super (Fam a)’ to the instance context,
+ even though it seems logically implied by other constraints in the context.
diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T
index a7e9f6a678..f8a3db350c 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -241,7 +241,7 @@ test('tcfail215', normal, compile_fail, [''])
test('tcfail216', normal, compile_fail, [''])
test('tcfail217', normal, compile_fail, [''])
test('tcfail218', normal, compile_fail, [''])
-test('tcfail223', normal, compile_fail, [''])
+test('tcfail223', normal, compile, ['']) # To become compile_fail after migration period (see #22912)
test('tcfail224', normal, compile_fail, [''])
test('tcfail225', normal, compile_fail, [''])
@@ -294,7 +294,7 @@ test('T19187a', normal, compile_fail, [''])
test('T2534', normal, compile_fail, [''])
test('T7175', normal, compile_fail, [''])
test('T7210', normal, compile_fail, [''])
-test('T6161', normal, compile_fail, [''])
+test('T6161', normal, compile, ['']) # To become compile_fail after migration period (see #22912)
test('T7368', normal, compile_fail, [''])
test('T7264', normal, compile_fail, [''])
test('T6069', normal, compile_fail, [''])
@@ -665,5 +665,5 @@ test('T21530a', normal, compile_fail, [''])
test('T21530b', normal, compile_fail, [''])
test('T22570', normal, compile_fail, [''])
test('T22645', normal, compile_fail, [''])
-test('T20666', normal, compile_fail, [''])
-test('T20666a', normal, compile_fail, [''])
+test('T20666', normal, compile, ['']) # To become compile_fail after migration period (see #22912)
+test('T20666a', normal, compile, ['']) # To become compile_fail after migration period (see #22912)
diff --git a/testsuite/tests/typecheck/should_fail/tcfail223.stderr b/testsuite/tests/typecheck/should_fail/tcfail223.stderr
index d3173adde7..8201c8839f 100644
--- a/testsuite/tests/typecheck/should_fail/tcfail223.stderr
+++ b/testsuite/tests/typecheck/should_fail/tcfail223.stderr
@@ -1,9 +1,10 @@
-tcfail223.hs:10:10: error: [GHC-39999]
- • Could not deduce ‘Class1 a’
- arising from the superclasses of an instance declaration
- from the context: Class3 a
- bound by the instance declaration at tcfail223.hs:10:10-29
- Possible fix:
- add (Class1 a) to the context of the instance declaration
- • In the instance declaration for ‘Class2 a’
+tcfail223.hs:10:10: warning: [GHC-36038] [-Wloopy-superclass-solve (in -Wdefault)]
+ I am solving the constraint ‘Class1 a’,
+ arising from the superclasses of an instance declaration,
+ in a way that might turn out to loop at runtime.
+ Future versions of GHC will turn this warning into an error.
+ See the user manual, § Undecidable instances and loopy superclasses.
+ Suggested fix:
+ Add the constraint ‘Class1 a’ to the instance context,
+ even though it seems logically implied by other constraints in the context.