Fix magicDict in ghci (and in the presence of other ticks)

The problem was that ghci inserts some ticks around the crucial bit of
the expression. Just like in some of the other rules we now strip the
ticks so that the rule fires more reliably.

It was possible to defeat magicDict by using -fhpc as well, so not just an
issue in ghci.

Fixes #19667 and related to #19673

7 files changed, 64 insertions, 1 deletions

diff --git a/testsuite/tests/ghci/scripts/T19667Ghci.hs b/testsuite/tests/ghci/scripts/T19667Ghci.hs
new file mode 100644
index 0000000000..21e484bee9
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T19667Ghci.hs
@@ -0,0 +1,29 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+module Main (main) where
+
+import Data.Proxy (Proxy(..))
+import GHC.Exts (magicDict)
+import GHC.TypeLits (Symbol)
+import GHC.Exts
+
+newtype SSymbol (s :: Symbol) = SSymbol String
+
+class KnownSymbol (n :: Symbol) where
+  symbolSing :: SSymbol n
+
+symbolVal :: forall n proxy . KnownSymbol n => proxy n -> String
+symbolVal _ = case symbolSing :: SSymbol n of SSymbol x -> x
+
+data WrapS a b = WrapS (KnownSymbol a => Proxy a -> b)
+
+-- See Note [NOINLINE someNatVal] in GHC.TypeNats
+{-# NOINLINE reifySymbol #-}
+reifySymbol :: forall r. String -> (forall (n :: Symbol). KnownSymbol n => Proxy n -> r) -> r
+reifySymbol n k = magicDict (WrapS k) (SSymbol n) (Proxy @(Any @Symbol))
+
+main :: IO ()
+main = print $ reifySymbol "Hello World" symbolVal
diff --git a/testsuite/tests/ghci/scripts/T19667Ghci.script b/testsuite/tests/ghci/scripts/T19667Ghci.script
new file mode 100644
index 0000000000..5ecc976eaa
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T19667Ghci.script
@@ -0,0 +1,2 @@
+:load T19667Ghci.hs
+:main
diff --git a/testsuite/tests/ghci/scripts/T19667Ghci.stdout b/testsuite/tests/ghci/scripts/T19667Ghci.stdout
new file mode 100644
index 0000000000..06ae699f22
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T19667Ghci.stdout
@@ -0,0 +1 @@
+"Hello World"
diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T
index 64f87bc7e2..d6f2dd567e 100755
--- a/testsuite/tests/ghci/scripts/all.T
+++ b/testsuite/tests/ghci/scripts/all.T
@@ -328,4 +328,4 @@ test('T19197', normal, ghci_script, ['T19197.script'])
 test('T19158', normal, ghci_script, ['T19158.script'])
 test('T19279', normal, ghci_script, ['T19279.script'])
 test('T19310', normal, ghci_script, ['T19310.script'])
-
+test('T19667Ghci', extra_files(['T19667Ghci.hs']), ghci_script, ['T19667Ghci.script'])
diff --git a/testsuite/tests/typecheck/should_run/T19667.hs b/testsuite/tests/typecheck/should_run/T19667.hs
new file mode 100644
index 0000000000..21e484bee9
--- /dev/null
+++ b/testsuite/tests/typecheck/should_run/T19667.hs
@@ -0,0 +1,29 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+module Main (main) where
+
+import Data.Proxy (Proxy(..))
+import GHC.Exts (magicDict)
+import GHC.TypeLits (Symbol)
+import GHC.Exts
+
+newtype SSymbol (s :: Symbol) = SSymbol String
+
+class KnownSymbol (n :: Symbol) where
+  symbolSing :: SSymbol n
+
+symbolVal :: forall n proxy . KnownSymbol n => proxy n -> String
+symbolVal _ = case symbolSing :: SSymbol n of SSymbol x -> x
+
+data WrapS a b = WrapS (KnownSymbol a => Proxy a -> b)
+
+-- See Note [NOINLINE someNatVal] in GHC.TypeNats
+{-# NOINLINE reifySymbol #-}
+reifySymbol :: forall r. String -> (forall (n :: Symbol). KnownSymbol n => Proxy n -> r) -> r
+reifySymbol n k = magicDict (WrapS k) (SSymbol n) (Proxy @(Any @Symbol))
+
+main :: IO ()
+main = print $ reifySymbol "Hello World" symbolVal
diff --git a/testsuite/tests/typecheck/should_run/T19667.stdout b/testsuite/tests/typecheck/should_run/T19667.stdout
new file mode 100644
index 0000000000..06ae699f22
--- /dev/null
+++ b/testsuite/tests/typecheck/should_run/T19667.stdout
@@ -0,0 +1 @@
+"Hello World"
diff --git a/testsuite/tests/typecheck/should_run/all.T b/testsuite/tests/typecheck/should_run/all.T
index c4005e402e..efc9fcb374 100755
--- a/testsuite/tests/typecheck/should_run/all.T
+++ b/testsuite/tests/typecheck/should_run/all.T
@@ -155,3 +155,4 @@ test('T19397M1', extra_files(['T19397S.hs']), compile_and_run, [''])
 test('T19397M2', extra_files(['T19397S.hs']), compile_and_run, ['-main-is foo'])
 test('T19397M3', extra_files(['T19397S.hs']), compile_and_run, ['-main-is foo'])
 test('T19397M4', extra_files(['T19397S.hs']), compile_and_run, ['-main-is foo'])
+test('T19667', normal, compile_and_run, ['-fhpc'])