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.

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]

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

testsuite/tests/typecheck/should_compile/T12936.hs

+{-# 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

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, [''])