diff options
| -rw-r--r-- | compiler/typecheck/TcRnTypes.hs | 18 | ||||
| -rw-r--r-- | compiler/utils/Bag.hs | 16 | ||||
| -rw-r--r-- | testsuite/tests/typecheck/should_compile/T12936.hs | 30 | ||||
| -rw-r--r-- | testsuite/tests/typecheck/should_compile/all.T | 1 |
4 files changed, 63 insertions, 2 deletions
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index a496d259ec..4833839bd5 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -1740,8 +1740,22 @@ tyCoFVsOfBag tvs_of = foldrBag (unionFV . tvs_of) emptyFV -------------------------- dropDerivedSimples :: Cts -> Cts -dropDerivedSimples simples = filterBag isWantedCt simples - -- simples are all Wanted or Derived +-- Drop all Derived constraints, but make [W] back into [WD], +-- so that if we re-simplify these constraints we will get all +-- the right derived constraints re-generated. Forgetting this +-- step led to #12936 +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 + _ -> ASSERT( isDerivedCt ct ) Nothing + -- simples are all Wanted or Derived + where + ev = ctEvidence ct + ev_wd = ev { ctev_nosh = WDeriv } dropDerivedInsols :: Cts -> Cts -- See Note [Dropping derived constraints] diff --git a/compiler/utils/Bag.hs b/compiler/utils/Bag.hs index f2b1ead4d8..5fd4ba3b83 100644 --- a/compiler/utils/Bag.hs +++ b/compiler/utils/Bag.hs @@ -18,6 +18,7 @@ module Bag ( concatBag, catBagMaybes, foldBag, foldrBag, foldlBag, isEmptyBag, isSingletonBag, consBag, snocBag, anyBag, listToBag, bagToList, mapAccumBagL, + concatMapBag, mapMaybeBag, foldrBagM, foldlBagM, mapBagM, mapBagM_, flatMapBagM, flatMapBagPairM, mapAndUnzipBagM, mapAccumBagLM, @@ -30,6 +31,7 @@ import Util import MonadUtils import Control.Monad import Data.Data +import Data.Maybe( mapMaybe ) import Data.List ( partition, mapAccumL ) import qualified Data.Foldable as Foldable @@ -216,6 +218,20 @@ mapBag f (UnitBag x) = UnitBag (f x) mapBag f (TwoBags b1 b2) = TwoBags (mapBag f b1) (mapBag f b2) mapBag f (ListBag xs) = ListBag (map f xs) +concatMapBag :: (a -> Bag b) -> Bag a -> Bag b +concatMapBag _ EmptyBag = EmptyBag +concatMapBag f (UnitBag x) = f x +concatMapBag f (TwoBags b1 b2) = unionBags (concatMapBag f b1) (concatMapBag f b2) +concatMapBag f (ListBag xs) = foldr (unionBags . f) emptyBag xs + +mapMaybeBag :: (a -> Maybe b) -> Bag a -> Bag b +mapMaybeBag _ EmptyBag = EmptyBag +mapMaybeBag f (UnitBag x) = case f x of + Nothing -> EmptyBag + Just y -> UnitBag y +mapMaybeBag f (TwoBags b1 b2) = unionBags (mapMaybeBag f b1) (mapMaybeBag f b2) +mapMaybeBag f (ListBag xs) = ListBag (mapMaybe f xs) + mapBagM :: Monad m => (a -> m b) -> Bag a -> m (Bag b) mapBagM _ EmptyBag = return EmptyBag mapBagM f (UnitBag x) = do r <- f x diff --git a/testsuite/tests/typecheck/should_compile/T12936.hs b/testsuite/tests/typecheck/should_compile/T12936.hs new file mode 100644 index 0000000000..c4f966093f --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T12936.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MonomorphismRestriction #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Token where + +class S s t | s -> t + +m :: forall s t . S s t => s +m = undefined + +o :: forall s t . S s t => s -> s +o = undefined + +c :: forall s . s -> s -> s +c = undefined + +p :: forall s . S s () => s -> s +p d = f + where + + -- declaring either of these type signatures will cause the bug to go away + + -- f :: s + f = c d (o e) + + -- e :: s + e = c m m diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T index 088c6fa5d3..8d25b3a55a 100644 --- a/testsuite/tests/typecheck/should_compile/all.T +++ b/testsuite/tests/typecheck/should_compile/all.T @@ -557,3 +557,4 @@ test('T12763', normal, compile, ['']) test('T12797', normal, compile, ['']) test('T12925', normal, compile, ['']) test('T12919', expect_broken(12919), compile, ['']) +test('T12936', normal, compile, ['']) |