Commit 13508bad authored by Simon Peyton Jones's avatar Simon Peyton Jones
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).
parent f4a14d6c
...@@ -595,7 +595,7 @@ simplifyInfer rhs_tclvl infer_mode sigs name_taus wanteds ...@@ -595,7 +595,7 @@ simplifyInfer rhs_tclvl infer_mode sigs name_taus wanteds
-- NB: must include derived errors in this test, -- NB: must include derived errors in this test,
-- hence "incl_derivs" -- hence "incl_derivs"
else do { let quant_cand = approximateWC wanted_transformed else do { let quant_cand = approximateWC False wanted_transformed
meta_tvs = filter isMetaTyVar $ meta_tvs = filter isMetaTyVar $
tyCoVarsOfCtsList quant_cand tyCoVarsOfCtsList quant_cand
...@@ -1606,10 +1606,10 @@ defaultTyVarTcS the_tv ...@@ -1606,10 +1606,10 @@ defaultTyVarTcS the_tv
| otherwise | otherwise
= return False -- the common case = return False -- the common case
approximateWC :: WantedConstraints -> Cts approximateWC :: Bool -> WantedConstraints -> Cts
-- Postcondition: Wanted or Derived Cts -- Postcondition: Wanted or Derived Cts
-- See Note [ApproximateWC] -- See Note [ApproximateWC]
approximateWC wc approximateWC float_past_equalities wc
= float_wc emptyVarSet wc = float_wc emptyVarSet wc
where where
float_wc :: TcTyCoVarSet -> WantedConstraints -> Cts float_wc :: TcTyCoVarSet -> WantedConstraints -> Cts
...@@ -1630,18 +1630,17 @@ approximateWC wc ...@@ -1630,18 +1630,17 @@ approximateWC wc
float_implic :: TcTyCoVarSet -> Implication -> Cts float_implic :: TcTyCoVarSet -> Implication -> Cts
float_implic trapping_tvs imp 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) = float_wc new_trapping_tvs (ic_wanted imp)
| otherwise -- Don't float out of equalities | otherwise -- Take care with equalities
= emptyCts -- See Note [ApproximateWC] = emptyCts -- See (1) under Note [ApproximateWC]
where where
new_trapping_tvs = trapping_tvs `extendVarSetList` ic_skols imp new_trapping_tvs = trapping_tvs `extendVarSetList` ic_skols imp
do_bag :: (a -> Bag c) -> Bag a -> Bag c do_bag :: (a -> Bag c) -> Bag a -> Bag c
do_bag f = foldrBag (unionBags.f) emptyBag do_bag f = foldrBag (unionBags.f) emptyBag
{- {- Note [ApproximateWC]
Note [ApproximateWC] ~~~~~~~~~~~~~~~~~~~~~~~
~~~~~~~~~~~~~~~~~~~~
approximateWC takes a constraint, typically arising from the RHS of a approximateWC takes a constraint, typically arising from the RHS of a
let-binding whose type we are *inferring*, and extracts from it some let-binding whose type we are *inferring*, and extracts from it some
*simple* constraints that we might plausibly abstract over. Of course *simple* constraints that we might plausibly abstract over. Of course
...@@ -1653,8 +1652,9 @@ to applyDefaultingRules) to extract constraints that that might be defaulted. ...@@ -1653,8 +1652,9 @@ to applyDefaultingRules) to extract constraints that that might be defaulted.
There are two caveats: There are two caveats:
1. We do *not* float anything out if the implication binds equality 1. When infering most-general types (in simplifyInfer), we do *not*
constraints, because that defeats the OutsideIn story. Consider float anything out if the implication binds equality constraints,
because that defeats the OutsideIn story. Consider
data T a where data T a where
TInt :: T Int TInt :: T Int
MkT :: T a MkT :: T a
...@@ -1669,6 +1669,10 @@ There are two caveats: ...@@ -1669,6 +1669,10 @@ There are two caveats:
float out of such implications, which meant it would happily infer float out of such implications, which meant it would happily infer
non-principal types.) 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 2. We do not float out an inner constraint that shares a type variable
(transitively) with one that is trapped by a skolem. Eg (transitively) with one that is trapped by a skolem. Eg
forall a. F a ~ beta, Integral beta forall a. F a ~ beta, Integral beta
...@@ -2000,7 +2004,7 @@ findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds ...@@ -2000,7 +2004,7 @@ findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds
, defaultable_tyvar tv , defaultable_tyvar tv
, defaultable_classes (map sndOf3 group) ] , defaultable_classes (map sndOf3 group) ]
where where
simples = approximateWC wanteds simples = approximateWC True wanteds
(unaries, non_unaries) = partitionWith find_unary (bagToList simples) (unaries, non_unaries) = partitionWith find_unary (bagToList simples)
unary_groups = equivClasses cmp_tv unaries 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
...@@ -551,3 +551,4 @@ test('T12507', normal, compile, ['']) ...@@ -551,3 +551,4 @@ test('T12507', normal, compile, [''])
test('T12734', normal, compile, ['']) test('T12734', normal, compile, [''])
test('T12734a', normal, compile_fail, ['']) test('T12734a', normal, compile_fail, [''])
test('T12763', normal, compile, ['']) test('T12763', 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