[commit: ghc] master: Make dropDerivedSimples restore [WD] constraints (f1036ad)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/f1036ad80efb9cf80977fa234f8b9c7b23cc6835/ghc

>---------------------------------------------------------------

commit f1036ad80efb9cf80977fa234f8b9c7b23cc6835
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Fri Dec 9 17:37:28 2016 +0000

    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.


>---------------------------------------------------------------

f1036ad80efb9cf80977fa234f8b9c7b23cc6835
 compiler/typecheck/TcRnTypes.hs                    | 18 +++++++++++--
 compiler/utils/Bag.hs                              | 16 ++++++++++++
 testsuite/tests/typecheck/should_compile/T12936.hs | 30 ++++++++++++++++++++++
 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 a496d25..4833839 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 f2b1ead..5fd4ba3 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 0000000..c4f9660
--- /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 088c6fa..8d25b3a 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, [''])