diff options
| -rw-r--r-- | compiler/typecheck/TcCanonical.hs | 25 | ||||
| -rw-r--r-- | compiler/typecheck/TcRnTypes.hs | 41 | ||||
| -rw-r--r-- | testsuite/tests/indexed-types/should_compile/T13662.hs | 25 | ||||
| -rw-r--r-- | testsuite/tests/indexed-types/should_compile/all.T | 1 |
4 files changed, 72 insertions, 20 deletions
diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs index 10f871f8e9..b623541e0c 100644 --- a/compiler/typecheck/TcCanonical.hs +++ b/compiler/typecheck/TcCanonical.hs @@ -161,18 +161,19 @@ canClass ev cls tys pend_sc ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We need to add superclass constraints for two reasons: -* For givens, they give us a route to to proof. E.g. +* For givens [G], they give us a route to to proof. E.g. f :: Ord a => a -> Bool f x = x == x We get a Wanted (Eq a), which can only be solved from the superclass of the Given (Ord a). -* For wanteds, they may give useful functional dependencies. E.g. +* For wanteds [W], and deriveds [WD], [D], they may give useful + functional dependencies. E.g. class C a b | a -> b where ... class C a b => D a b where ... - Now a Wanted constraint (D Int beta) has (C Int beta) as a superclass + Now a [W] constraint (D Int beta) has (C Int beta) as a superclass and that might tell us about beta, via C's fundeps. We can get this - by generateing a Derived (C Int beta) constraint. It's derived because + by generating a [D] (C Int beta) constraint. It's derived because we don't actually have to cough up any evidence for it; it's only there to generate fundep equalities. @@ -227,12 +228,20 @@ So here's the plan: 4. Go round to (2) again. This loop (2,3,4) is implemented in TcSimplify.simpl_loop. -We try to terminate the loop by flagging which class constraints -(given or wanted) are potentially un-expanded. This is what the -cc_pend_sc flag is for in CDictCan. So in Step 3 we only expand -superclasses for constraints with cc_pend_sc set to true (i.e. +The cc_pend_sc flag in a CDictCan records whether the superclasses of +this constraint have been expanded. Specifically, in Step 3 we only +expand superclasses for constraints with cc_pend_sc set to true (i.e. isPendingScDict holds). +Why do we do this? Two reasons: + +* To avoid repeated work, by repeatedly expanding the superclasses of + same constraint, + +* To terminate the above loop, at least in the -XNoRecursiveSuperClasses + case. If there are recursive superclasses we could, in principle, + expand forever, always encountering new constraints. + When we take a CNonCanonical or CIrredCan, but end up classifying it as a CDictCan, we set the cc_pend_sc flag to False. diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index ba7c44feba..7aef4bb8a4 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -1523,14 +1523,14 @@ data Ct -- Atomic canonical constraints = CDictCan { -- e.g. Num xi cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] + cc_class :: Class, - cc_tyargs :: [Xi], -- cc_tyargs are function-free, hence Xi - cc_pend_sc :: Bool -- True <=> (a) cc_class has superclasses - -- (b) we have not (yet) added those - -- superclasses as Givens - -- NB: cc_pend_sc is used for G/W/D. For W/D the reason - -- we need superclasses is to expose possible improvement - -- via fundeps + cc_tyargs :: [Xi], -- cc_tyargs are function-free, hence Xi + + cc_pend_sc :: Bool -- See Note [The superclass story] in TcCanonical + -- True <=> (a) cc_class has superclasses + -- (b) we have not (yet) added those + -- superclasses as Givens } | CIrredEvCan { -- These stand for yet-unusable predicates @@ -1608,9 +1608,8 @@ holeOcc :: Hole -> OccName holeOcc (ExprHole uv) = unboundVarOcc uv holeOcc (TypeHole occ) = occ -{- -Note [Hole constraints] -~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Hole constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~ CHoleCan constraints are used for two kinds of holes, distinguished by cc_hole: @@ -1805,13 +1804,25 @@ dropDerivedSimples simples = mapMaybeBag dropDerivedCt simples dropDerivedCt :: Ct -> Maybe Ct dropDerivedCt ct = case ctEvFlavour ev of - Wanted WOnly -> Just (ct { cc_ev = ev_wd }) - Wanted _ -> Just ct + Wanted WOnly -> Just (ct' { cc_ev = ev_wd }) + Wanted _ -> Just ct' _ -> ASSERT( isDerivedCt ct ) Nothing -- simples are all Wanted or Derived where ev = ctEvidence ct ev_wd = ev { ctev_nosh = WDeriv } + ct' = setPendingScDict ct -- See Note [Resetting cc_pend_sc] + +{- Note [Resetting cc_pend_sc] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we discard Derived constraints, in dropDerivedSimples, we must +set the cc_pend_sc flag to True, so that if we re-process this +CDictCan we will re-generate its derived superclasses. Otherwise +we might miss some fundeps. Trac #13662 showed this up. + +See Note [The superclass story] in TcCanonical. +-} + dropDerivedInsols :: Cts -> Cts -- See Note [Dropping derived constraints] @@ -2011,6 +2022,12 @@ isPendingScDict ct@(CDictCan { cc_pend_sc = True }) = Just (ct { cc_pend_sc = False }) isPendingScDict _ = Nothing +setPendingScDict :: Ct -> Ct +-- Set the cc_pend_sc flag to True +setPendingScDict ct@(CDictCan { cc_pend_sc = False }) + = ct { cc_pend_sc = True } +setPendingScDict ct = ct + superClassesMightHelp :: Ct -> Bool -- ^ True if taking superclasses of givens, or of wanteds (to perhaps -- expose more equalities or functional dependencies) might help to diff --git a/testsuite/tests/indexed-types/should_compile/T13662.hs b/testsuite/tests/indexed-types/should_compile/T13662.hs new file mode 100644 index 0000000000..5898f25d12 --- /dev/null +++ b/testsuite/tests/indexed-types/should_compile/T13662.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module T13662 (run) where + +newtype Value a = Value a + +type family Repr (f :: * -> *) a :: * +type instance Repr f Int = f Int + +class (Repr Value i ~ Value ir) => Native i ir where + +instance Native Int Int where + + +fromInt :: (Native i ir) => i -> a +fromInt = undefined + +apply :: (Int -> a -> a) -> a -> a +apply weight = id + +run :: Float -> Float +run = + let weight = \clip v -> fromInt clip * v + in apply weight + diff --git a/testsuite/tests/indexed-types/should_compile/all.T b/testsuite/tests/indexed-types/should_compile/all.T index 529f7defda..00d40ce2ac 100644 --- a/testsuite/tests/indexed-types/should_compile/all.T +++ b/testsuite/tests/indexed-types/should_compile/all.T @@ -263,3 +263,4 @@ test('T12538', normal, compile_fail, ['']) test('T13244', normal, compile, ['']) test('T13398a', normal, compile, ['']) test('T13398b', normal, compile, ['']) +test('T13662', normal, compile, ['']) |