Fix bad interaction between withDict and the Specialiser

This MR fixes a bad bug, where the withDict was inlined too
vigorously, which in turn made the type-class Specialiser generate
a bogus specialisation, because it saw the same overloaded function
applied to two /different/ dictionaries.

Solution: inline `withDict` later.  See (WD8) of Note [withDict]
in GHC.HsToCore.Expr

See #21575, which is fixed by this change.

3 files changed, 109 insertions, 0 deletions

diff --git a/testsuite/tests/simplCore/should_run/T21575.hs b/testsuite/tests/simplCore/should_run/T21575.hs
new file mode 100644
index 0000000000..976483f963
--- /dev/null
+++ b/testsuite/tests/simplCore/should_run/T21575.hs
@@ -0,0 +1,107 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+-- 0 => use unsafeCoerce
+-- 1 => use withDict
+#define WITH_DICT 1
+
+module Main (main) where
+
+import Control.Monad (unless)
+import qualified Data.Map as M
+import Data.Map (Map)
+
+#if WITH_DICT
+import GHC.Exts (withDict)
+#else
+import Unsafe.Coerce (unsafeCoerce)
+#endif
+
+main :: IO ()
+main = do
+  testCase (give Normal (toJSON (Foo Bar)))
+           (Object (M.fromList [("Foo",String "Bar")]))
+  testCase (give ViaShow (toJSON (Foo Bar)))
+           (Object (M.fromList [("Foo",String "SHOWBAR")]))
+  putStrLn "All tests passed!"
+
+{-
+toJSONBar :: Given Style => Bar -> Value
+
+  give Normal (\gd -> toJSONBar gd e)
+  --> withDict @Style @(Given Style) Normal (toJSON e)
+  --> toJSONBar ((Normal |> co) :: Given Style) e
+
+  give Normal (\gd -> toJSONBar gd e')
+  --> toJSONBar ((ViaShow |> co) :: Given Style) e'
+
+--------- With new cast ------------
+
+  give Normal (\gd -> toJSONBar gd e)
+  --> withDict @Style @(Given Style) Normal (\gd -> toJSONBar gd e)
+  --> ((\gd -> toJSONBar gd e) |> co) Normal
+  --> (\gd' -> toJSonBar (gd' |> sym (co[1])) e) Normal
+  --> toJSONBar (Normal |> co') e   -- Boo!
+
+-}
+
+testCase :: (Eq a, Show a) => a -> a -> IO ()
+testCase expected actual =
+  unless (expected == actual) $
+    error $ unlines
+      [ ""
+      , "Expected: " ++ show expected
+      , "Actual:   " ++ show actual
+      ]
+
+class Given a where
+  given :: a
+
+give :: forall a r. a -> (Given a => r) -> r
+#if WITH_DICT
+give = withDict @a @(Given a)
+#else
+give a k = unsafeCoerce (Gift k :: Gift a r) a
+
+newtype Gift a r = Gift (Given a => r)
+#endif
+
+data Foo = Foo Bar
+
+instance Show Foo where
+  show _ = "SHOWFOO"
+
+data Bar = Bar | BarBar
+
+instance Show Bar where
+  show _ = "SHOWBAR"
+
+----------------------------------------------------------------------------
+-- ToJSON instances
+----------------------------------------------------------------------------
+
+instance Given Style => ToJSON Foo where
+  toJSON (Foo x) = Object $ M.singleton "Foo" (toJSON x)
+
+instance Given Style => ToJSON Bar where
+  toJSON x = case given of
+    Normal -> String $ case x of
+                Bar    -> "Bar"
+                BarBar -> "BarBar"
+    ViaShow -> String $ show x
+
+data Style = Normal | ViaShow
+
+----------------------------------------------------------------------------
+-- Minimized aeson
+----------------------------------------------------------------------------
+
+class ToJSON a where
+  toJSON :: a -> Value
+
+data Value
+  = Object !(Map String Value)
+  | String !String
+  deriving (Eq, Show)
diff --git a/testsuite/tests/simplCore/should_run/T21575.stdout b/testsuite/tests/simplCore/should_run/T21575.stdout
new file mode 100644
index 0000000000..14332104f6
--- /dev/null
+++ b/testsuite/tests/simplCore/should_run/T21575.stdout
@@ -0,0 +1 @@
+All tests passed!
diff --git a/testsuite/tests/simplCore/should_run/all.T b/testsuite/tests/simplCore/should_run/all.T
index 52a1af40a8..53bcde5169 100644
--- a/testsuite/tests/simplCore/should_run/all.T
+++ b/testsuite/tests/simplCore/should_run/all.T
@@ -102,3 +102,4 @@ test('T20203', normal, compile, ['-O -dsuppress-all -dsuppress-uniques -dno-type
 test('T19313', normal, compile_and_run, [''])
 test('UnliftedArgRule', normal, compile_and_run, [''])
 test('T21229', normal, compile_and_run, ['-O'])
+test('T21575', normal, compile_and_run, ['-O'])