Commit 28c62bb5 authored by Simon Peyton Jones's avatar Simon Peyton Jones Committed by Ben Gamari
Browse files

Fix Trac #12797: approximateWC

This patch makes approximateWC a bit more gung-ho when called
from the defaulting code.  See Note [ApproximateWC], item (1).

(cherry picked from commit 13508bad)
parent 4227f3ea
......@@ -581,7 +581,7 @@ simplifyInfer rhs_tclvl apply_mr sigs name_taus wanteds
-- NB: must include derived errors in this test,
-- hence "incl_derivs"
else do { let quant_cand = approximateWC wanted_transformed
else do { let quant_cand = approximateWC False wanted_transformed
meta_tvs = filter isMetaTyVar $
tyCoVarsOfCtsList quant_cand
......@@ -1567,10 +1567,10 @@ defaultTyVarTcS the_tv
| otherwise
= return False -- the common case
approximateWC :: WantedConstraints -> Cts
approximateWC :: Bool -> WantedConstraints -> Cts
-- Postcondition: Wanted or Derived Cts
-- See Note [ApproximateWC]
approximateWC wc
approximateWC float_past_equalities wc
= float_wc emptyVarSet wc
where
float_wc :: TcTyCoVarSet -> WantedConstraints -> Cts
......@@ -1591,18 +1591,17 @@ approximateWC wc
float_implic :: TcTyCoVarSet -> Implication -> Cts
float_implic trapping_tvs imp
| ic_no_eqs imp -- No equalities, so float
| float_past_equalities || ic_no_eqs imp
= float_wc new_trapping_tvs (ic_wanted imp)
| otherwise -- Don't float out of equalities
= emptyCts -- See Note [ApproximateWC]
| otherwise -- Take care with equalities
= emptyCts -- See (1) under Note [ApproximateWC]
where
new_trapping_tvs = trapping_tvs `extendVarSetList` ic_skols imp
do_bag :: (a -> Bag c) -> Bag a -> Bag c
do_bag f = foldrBag (unionBags.f) emptyBag
{-
Note [ApproximateWC]
~~~~~~~~~~~~~~~~~~~~
{- Note [ApproximateWC]
~~~~~~~~~~~~~~~~~~~~~~~
approximateWC takes a constraint, typically arising from the RHS of a
let-binding whose type we are *inferring*, and extracts from it some
*simple* constraints that we might plausibly abstract over. Of course
......@@ -1614,8 +1613,9 @@ to applyDefaultingRules) to extract constraints that that might be defaulted.
There are two caveats:
1. We do *not* float anything out if the implication binds equality
constraints, because that defeats the OutsideIn story. Consider
1. When infering most-general types (in simplifyInfer), we do *not*
float anything out if the implication binds equality constraints,
because that defeats the OutsideIn story. Consider
data T a where
TInt :: T Int
MkT :: T a
......@@ -1630,6 +1630,10 @@ There are two caveats:
float out of such implications, which meant it would happily infer
non-principal types.)
HOWEVER (Trac #12797) in findDefaultableGroups we are not worried about
the most-general type; and we /do/ want to float out of equalities.
Hence the boolean flag to approximateWC.
2. We do not float out an inner constraint that shares a type variable
(transitively) with one that is trapped by a skolem. Eg
forall a. F a ~ beta, Integral beta
......@@ -1961,7 +1965,7 @@ findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds
, defaultable_tyvar tv
, defaultable_classes (map sndOf3 group) ]
where
simples = approximateWC wanteds
simples = approximateWC True wanteds
(unaries, non_unaries) = partitionWith find_unary (bagToList simples)
unary_groups = equivClasses cmp_tv unaries
......
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExtendedDefaultRules #-}
module T12797 where
import Prelude
import Control.Monad.IO.Class
type family FuncArg (m :: (* -> *)) :: Maybe *
test2 :: (MonadIO m, FuncArg m ~ 'Nothing) => m ()
test2 = liftIO $ print 6
......@@ -522,3 +522,4 @@ test('T12170b', normal, compile, [''])
test('T12466', normal, compile, [''])
test('T12466a', normal, compile, [''])
test('T12644', normal, compile, [''])
test('T12797', 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