Commit ff21795a authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Special-case implicit params in superclass expansion

This issue came up in Trac #11480, and is documented in
Note [When superclasses help] in TcRnTypes.

We were getting a spurious warning
  T11480.hs:1:1: warning:
     solveWanteds: too many iterations (limit = 4)

The fix is easy.  A bit of refactoring along the way.

The original bug report in Trac #11480 appears to work
fine in HEAD and the 8.0 branch but I added a regression
test in this commit as well.
parent fd6dd41c
...@@ -260,11 +260,12 @@ So here's the plan: ...@@ -260,11 +260,12 @@ So here's the plan:
in solveSimpleGivens or solveSimpleWanteds. in solveSimpleGivens or solveSimpleWanteds.
See Note [Danger of adding superclasses during solving] See Note [Danger of adding superclasses during solving]
3. If we have any remaining unsolved wanteds, try harder: 3. If we have any remaining unsolved wanteds
take both the Givens and Wanteds, and expand superclasses again. (see Note [When superclasses help] in TcRnTypes)
This may succeed in generating (a finite number of) extra Givens, try harder: take both the Givens and Wanteds, and expand
and extra Deriveds. Both may help the proof. superclasses again. This may succeed in generating (a finite
This is done in TcSimplify.expandSuperClasses. number of) extra Givens, and extra Deriveds. Both may help the
proof. This is done in TcSimplify.expandSuperClasses.
4. Go round to (2) again. This loop (2,3,4) is implemented 4. Go round to (2) again. This loop (2,3,4) is implemented
in TcSimplify.simpl_loop. in TcSimplify.simpl_loop.
......
...@@ -66,6 +66,7 @@ module TcRnTypes( ...@@ -66,6 +66,7 @@ module TcRnTypes(
Xi, Ct(..), Cts, emptyCts, andCts, andManyCts, pprCts, Xi, Ct(..), Cts, emptyCts, andCts, andManyCts, pprCts,
singleCt, listToCts, ctsElts, consCts, snocCts, extendCtsList, singleCt, listToCts, ctsElts, consCts, snocCts, extendCtsList,
isEmptyCts, isCTyEqCan, isCFunEqCan, isEmptyCts, isCTyEqCan, isCFunEqCan,
isPendingScDict, superClassesMightHelp,
isCDictCan_Maybe, isCFunEqCan_maybe, isCDictCan_Maybe, isCFunEqCan_maybe,
isCIrredEvCan, isCNonCanonical, isWantedCt, isDerivedCt, isCIrredEvCan, isCNonCanonical, isWantedCt, isDerivedCt,
isGivenCt, isHoleCt, isOutOfScopeCt, isExprHoleCt, isTypeHoleCt, isGivenCt, isHoleCt, isOutOfScopeCt, isExprHoleCt, isTypeHoleCt,
...@@ -1526,12 +1527,18 @@ ctFlavour = ctEvFlavour . ctEvidence ...@@ -1526,12 +1527,18 @@ ctFlavour = ctEvFlavour . ctEvidence
ctEqRel :: Ct -> EqRel ctEqRel :: Ct -> EqRel
ctEqRel = ctEvEqRel . ctEvidence ctEqRel = ctEvEqRel . ctEvidence
dropDerivedWC :: WantedConstraints -> WantedConstraints instance Outputable Ct where
-- See Note [Dropping derived constraints] ppr ct = ppr (cc_ev ct) <+> parens pp_sort
dropDerivedWC wc@(WC { wc_simple = simples, wc_insol = insols }) where
= wc { wc_simple = dropDerivedSimples simples pp_sort = case ct of
, wc_insol = dropDerivedInsols insols } CTyEqCan {} -> text "CTyEqCan"
-- The wc_impl implications are already (recursively) filtered CFunEqCan {} -> text "CFunEqCan"
CNonCanonical {} -> text "CNonCanonical"
CDictCan { cc_pend_sc = pend_sc }
| pend_sc -> text "CDictCan(psc)"
| otherwise -> text "CDictCan"
CIrredEvCan {} -> text "CIrredEvCan"
CHoleCan { cc_occ = occ } -> text "CHoleCan:" <+> ppr occ
{- {-
************************************************************************ ************************************************************************
...@@ -1754,6 +1761,11 @@ isUserTypeErrorCt ct = case getUserTypeErrorMsg ct of ...@@ -1754,6 +1761,11 @@ isUserTypeErrorCt ct = case getUserTypeErrorMsg ct of
Just _ -> True Just _ -> True
_ -> False _ -> False
isPendingScDict :: Ct -> Maybe Ct
isPendingScDict ct@(CDictCan { cc_pend_sc = True })
= Just (ct { cc_pend_sc = False })
isPendingScDict _ = Nothing
-- | Are we looking at an Implicit CallStack -- | Are we looking at an Implicit CallStack
-- (i.e. @IP "name" CallStack@)? -- (i.e. @IP "name" CallStack@)?
-- --
...@@ -1768,18 +1780,44 @@ isCallStackDict cls tys ...@@ -1768,18 +1780,44 @@ isCallStackDict cls tys
isCallStackDict _ _ isCallStackDict _ _
= Nothing = Nothing
instance Outputable Ct where superClassesMightHelp :: Ct -> Bool
ppr ct = ppr (cc_ev ct) <+> parens pp_sort -- ^ True if taking superclasses of givens, or of wanteds (to perhaps
where -- expose more equalities or functional dependencies) might help to
pp_sort = case ct of -- solve this constraint. See Note [When superclases help]
CTyEqCan {} -> text "CTyEqCan" superClassesMightHelp ct
CFunEqCan {} -> text "CFunEqCan" | CDictCan { cc_class = cls } <- ct
CNonCanonical {} -> text "CNonCanonical" , cls `hasKey` ipClassKey
CDictCan { cc_pend_sc = pend_sc } = False
| pend_sc -> text "CDictCan(psc)" | otherwise
| otherwise -> text "CDictCan" = True
CIrredEvCan {} -> text "CIrredEvCan"
CHoleCan { cc_occ = occ } -> text "CHoleCan:" <+> ppr occ {- Note [When superclasses help]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
First read Note [The superclass story] in TcCanonical.
We expand superclasses and iterate only if there is at unsolved wanted
for which expansion of superclasses (e.g. from given constraints)
might actually help. Usually the answer is "yes" but for implicit
paramters it is "no". If we have [W] ?x::ty, expanding superclasses
won't help:
- Superclasses can't be implicit parameters
- If we have a [G] ?x:ty2, then we'll have another unsolved
[D] ty ~ ty2 (from the functional dependency)
which will trigger superclass expansion.
It's a bit of a special case, but it's easy to do. The runtime cost
is low because the unsolved set is usually empty anyway (errors
aside), and the first non-imlicit-parameter will terminate the search.
The special case is worth it (Trac #11480, comment:2) because it
applies to CallStack constraints, which aren't type errors. If we have
f :: (C a) => blah
f x = ...undefined...
we'll get a CallStack constraint. If that's the only unsolved constraint
it'll eventually be solved by defaulting. So we don't want to emit warnings
about hitting the simplifier's iteration limit. A CallStack constraint
really isn't an unsolved constraint; it can always be solved by defaulting.
-}
singleCt :: Ct -> Cts singleCt :: Ct -> Cts
singleCt = unitBag singleCt = unitBag
...@@ -1885,6 +1923,13 @@ addInsols :: WantedConstraints -> Bag Ct -> WantedConstraints ...@@ -1885,6 +1923,13 @@ addInsols :: WantedConstraints -> Bag Ct -> WantedConstraints
addInsols wc cts addInsols wc cts
= wc { wc_insol = wc_insol wc `unionBags` cts } = wc { wc_insol = wc_insol wc `unionBags` cts }
dropDerivedWC :: WantedConstraints -> WantedConstraints
-- See Note [Dropping derived constraints]
dropDerivedWC wc@(WC { wc_simple = simples, wc_insol = insols })
= wc { wc_simple = dropDerivedSimples simples
, wc_insol = dropDerivedInsols insols }
-- The wc_impl implications are already (recursively) filtered
isInsolubleStatus :: ImplicStatus -> Bool isInsolubleStatus :: ImplicStatus -> Bool
isInsolubleStatus IC_Insoluble = True isInsolubleStatus IC_Insoluble = True
isInsolubleStatus _ = False isInsolubleStatus _ = False
......
...@@ -53,7 +53,7 @@ module TcSMonad ( ...@@ -53,7 +53,7 @@ module TcSMonad (
emptyInert, getTcSInerts, setTcSInerts, takeGivenInsolubles, emptyInert, getTcSInerts, setTcSInerts, takeGivenInsolubles,
matchableGivens, prohibitedSuperClassSolve, matchableGivens, prohibitedSuperClassSolve,
getUnsolvedInerts, getUnsolvedInerts,
removeInertCts, getPendingScDicts, isPendingScDict, removeInertCts, getPendingScDicts,
addInertCan, addInertEq, insertFunEq, addInertCan, addInertEq, insertFunEq,
emitInsoluble, emitWorkNC, emitInsoluble, emitWorkNC,
...@@ -1698,16 +1698,13 @@ getPendingScDicts = updRetInertCans get_sc_dicts ...@@ -1698,16 +1698,13 @@ getPendingScDicts = updRetInertCans get_sc_dicts
= addDict dicts cls tys ct = addDict dicts cls tys ct
add ct _ = pprPanic "getPendingScDicts" (ppr ct) add ct _ = pprPanic "getPendingScDicts" (ppr ct)
isPendingScDict :: Ct -> Maybe Ct
isPendingScDict ct@(CDictCan { cc_pend_sc = True })
= Just (ct { cc_pend_sc = False })
isPendingScDict _ = Nothing
getUnsolvedInerts :: TcS ( Bag Implication getUnsolvedInerts :: TcS ( Bag Implication
, Cts -- Tyvar eqs: a ~ ty , Cts -- Tyvar eqs: a ~ ty
, Cts -- Fun eqs: F a ~ ty , Cts -- Fun eqs: F a ~ ty
, Cts -- Insoluble , Cts -- Insoluble
, Cts ) -- All others , Cts ) -- All others
-- Return all the unsolved [Wanted] or [Derived] constraints
--
-- Post-condition: the returned simple constraints are all fully zonked -- Post-condition: the returned simple constraints are all fully zonked
-- (because they come from the inert set) -- (because they come from the inert set)
-- the unsolved implics may not be -- the unsolved implics may not be
......
...@@ -1059,20 +1059,26 @@ expandSuperClasses :: WantedConstraints -> TcS (Bool, WantedConstraints) ...@@ -1059,20 +1059,26 @@ expandSuperClasses :: WantedConstraints -> TcS (Bool, WantedConstraints)
-- unsolved wanteds or givens -- unsolved wanteds or givens
-- See Note [The superclass story] in TcCanonical -- See Note [The superclass story] in TcCanonical
expandSuperClasses wc@(WC { wc_simple = unsolved, wc_insol = insols }) expandSuperClasses wc@(WC { wc_simple = unsolved, wc_insol = insols })
| isEmptyBag unsolved -- No unsolved simple wanteds, so do not add suerpclasses | not (anyBag superClassesMightHelp unsolved)
= return (True, wc) = return (True, wc)
| otherwise | otherwise
= do { let (pending_wanted, unsolved') = mapAccumBagL get [] unsolved = do { traceTcS "expandSuperClasses {" empty
; let (pending_wanted, unsolved') = mapAccumBagL get [] unsolved
get acc ct = case isPendingScDict ct of get acc ct = case isPendingScDict ct of
Just ct' -> (ct':acc, ct') Just ct' -> (ct':acc, ct')
Nothing -> (acc, ct) Nothing -> (acc, ct)
; pending_given <- getPendingScDicts ; pending_given <- getPendingScDicts
; if null pending_given && null pending_wanted ; if null pending_given && null pending_wanted
then return (True, wc) then do { traceTcS "End expandSuperClasses no-op }" empty
; return (True, wc) }
else else
do { new_given <- makeSuperClasses pending_given do { new_given <- makeSuperClasses pending_given
; new_insols <- solveSimpleGivens new_given ; new_insols <- solveSimpleGivens new_given
; new_wanted <- makeSuperClasses pending_wanted ; new_wanted <- makeSuperClasses pending_wanted
; traceTcS "End expandSuperClasses }"
(vcat [ text "Given:" <+> ppr pending_given
, text "Insols from given:" <+> ppr new_insols
, text "Wanted:" <+> ppr new_wanted ])
; return (False, wc { wc_simple = unsolved' `unionBags` listToBag new_wanted ; return (False, wc { wc_simple = unsolved' `unionBags` listToBag new_wanted
, wc_insol = insols `unionBags` new_insols }) } } , wc_insol = insols `unionBags` new_insols }) } }
......
{-# language KindSignatures, PolyKinds, TypeFamilies,
NoImplicitPrelude, FlexibleContexts,
MultiParamTypeClasses, GADTs,
ConstraintKinds, FlexibleInstances,
FunctionalDependencies, UndecidableSuperClasses #-}
module T11480a where
import GHC.Types (Constraint)
import qualified Prelude
data Nat (c :: i -> i -> *) (d :: j -> j -> *) (f :: i -> j) (g :: i -> j)
class Functor p (Nat p (->)) p => Category (p :: i -> i -> *)
class (Category dom, Category cod)
=> Functor (dom :: i -> i -> *) (cod :: j -> j -> *) (f :: i -> j)
| f -> dom cod
instance (Category c, Category d) => Category (Nat c d)
instance (Category c, Category d) => Functor (Nat c d) (Nat (Nat c d) (->)) (Nat c d)
instance (Category c, Category d) => Functor (Nat c d) (->) (Nat c d f)
instance Category (->)
instance Functor (->) (->) ((->) e)
instance Functor (->) (Nat (->) (->)) (->)
...@@ -134,3 +134,4 @@ test('T11278', normal, compile, ['']) ...@@ -134,3 +134,4 @@ test('T11278', normal, compile, [''])
test('T11255', normal, compile, ['']) test('T11255', normal, compile, [''])
test('T11459', normal, compile_fail, ['']) test('T11459', normal, compile_fail, [''])
test('T11466', normal, compile_fail, ['']) test('T11466', normal, compile_fail, [''])
test('T11480a', normal, compile, [''])
{-# LANGUAGE FlexibleContexts, UndecidableSuperClasses #-}
module T11480 where
class C [a] => D a
class D a => C a
foo :: C a => a -> a
foo = undefined
...@@ -497,3 +497,4 @@ test('T11462', ...@@ -497,3 +497,4 @@ test('T11462',
['', [('T11462_Plugin.hs', '-package ghc'), ['', [('T11462_Plugin.hs', '-package ghc'),
('T11462.hs', '')], ('T11462.hs', '')],
'-dynamic']) '-dynamic'])
test('T11480', normal, compile, [''])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment