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

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:
in solveSimpleGivens or solveSimpleWanteds.
See Note [Danger of adding superclasses during solving]
3. If we have any remaining unsolved wanteds, try harder:
take both the Givens and Wanteds, and expand superclasses again.
This may succeed in generating (a finite number of) extra Givens,
and extra Deriveds. Both may help the proof.
This is done in TcSimplify.expandSuperClasses.
3. If we have any remaining unsolved wanteds
(see Note [When superclasses help] in TcRnTypes)
try harder: take both the Givens and Wanteds, and expand
superclasses again. This may succeed in generating (a finite
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
in TcSimplify.simpl_loop.
......
......@@ -66,6 +66,7 @@ module TcRnTypes(
Xi, Ct(..), Cts, emptyCts, andCts, andManyCts, pprCts,
singleCt, listToCts, ctsElts, consCts, snocCts, extendCtsList,
isEmptyCts, isCTyEqCan, isCFunEqCan,
isPendingScDict, superClassesMightHelp,
isCDictCan_Maybe, isCFunEqCan_maybe,
isCIrredEvCan, isCNonCanonical, isWantedCt, isDerivedCt,
isGivenCt, isHoleCt, isOutOfScopeCt, isExprHoleCt, isTypeHoleCt,
......@@ -1526,12 +1527,18 @@ ctFlavour = ctEvFlavour . ctEvidence
ctEqRel :: Ct -> EqRel
ctEqRel = ctEvEqRel . ctEvidence
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
instance Outputable Ct where
ppr ct = ppr (cc_ev ct) <+> parens pp_sort
where
pp_sort = case ct of
CTyEqCan {} -> text "CTyEqCan"
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
Just _ -> True
_ -> 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
-- (i.e. @IP "name" CallStack@)?
--
......@@ -1768,18 +1780,44 @@ isCallStackDict cls tys
isCallStackDict _ _
= Nothing
instance Outputable Ct where
ppr ct = ppr (cc_ev ct) <+> parens pp_sort
where
pp_sort = case ct of
CTyEqCan {} -> text "CTyEqCan"
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
superClassesMightHelp :: Ct -> Bool
-- ^ True if taking superclasses of givens, or of wanteds (to perhaps
-- expose more equalities or functional dependencies) might help to
-- solve this constraint. See Note [When superclases help]
superClassesMightHelp ct
| CDictCan { cc_class = cls } <- ct
, cls `hasKey` ipClassKey
= False
| otherwise
= True
{- 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 = unitBag
......@@ -1885,6 +1923,13 @@ addInsols :: WantedConstraints -> Bag Ct -> WantedConstraints
addInsols wc 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 IC_Insoluble = True
isInsolubleStatus _ = False
......
......@@ -53,7 +53,7 @@ module TcSMonad (
emptyInert, getTcSInerts, setTcSInerts, takeGivenInsolubles,
matchableGivens, prohibitedSuperClassSolve,
getUnsolvedInerts,
removeInertCts, getPendingScDicts, isPendingScDict,
removeInertCts, getPendingScDicts,
addInertCan, addInertEq, insertFunEq,
emitInsoluble, emitWorkNC,
......@@ -1698,16 +1698,13 @@ getPendingScDicts = updRetInertCans get_sc_dicts
= addDict dicts cls tys 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
, Cts -- Tyvar eqs: a ~ ty
, Cts -- Fun eqs: F a ~ ty
, Cts -- Insoluble
, Cts ) -- All others
-- Return all the unsolved [Wanted] or [Derived] constraints
--
-- Post-condition: the returned simple constraints are all fully zonked
-- (because they come from the inert set)
-- the unsolved implics may not be
......
......@@ -1059,20 +1059,26 @@ expandSuperClasses :: WantedConstraints -> TcS (Bool, WantedConstraints)
-- unsolved wanteds or givens
-- See Note [The superclass story] in TcCanonical
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)
| 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
Just ct' -> (ct':acc, ct')
Nothing -> (acc, ct)
; pending_given <- getPendingScDicts
; if null pending_given && null pending_wanted
then return (True, wc)
then do { traceTcS "End expandSuperClasses no-op }" empty
; return (True, wc) }
else
do { new_given <- makeSuperClasses pending_given
; new_insols <- solveSimpleGivens new_given
; 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
, 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, [''])
test('T11255', normal, compile, [''])
test('T11459', 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',
['', [('T11462_Plugin.hs', '-package ghc'),
('T11462.hs', '')],
'-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