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

Make dropDerivedSimples restore [WD] constraints

I'd forgotten to turn [W] + [D] constraints back into [WD]
in dropDerivedSimples; and that led to Trac #12936.

Fortunately the fix is simple.
parent 818e027e
......@@ -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]
......
......@@ -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
......
{-# 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
......@@ -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, [''])
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