Add two tests for #17366

7 files changed, 116 insertions, 0 deletions

diff --git a/testsuite/tests/simplCore/should_compile/T17366.hs b/testsuite/tests/simplCore/should_compile/T17366.hs
new file mode 100644
index 0000000000..13279464b8
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T17366.hs
@@ -0,0 +1,9 @@
+module T17366 where
+import Data.Functor.Identity
+import T17366a
+
+g :: Identity a -> a
+g a = f a
+
+h :: Tagged tag a -> a
+h a = f a
diff --git a/testsuite/tests/simplCore/should_compile/T17366.stderr b/testsuite/tests/simplCore/should_compile/T17366.stderr
new file mode 100644
index 0000000000..45a1425cbe
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T17366.stderr
@@ -0,0 +1,2 @@
+Rule fired: SPEC/T17366 f @Identity @_ (T17366)
+Rule fired: SPEC/T17366 f @(Tagged tag) @_ (T17366)
diff --git a/testsuite/tests/simplCore/should_compile/T17366_AR.hs b/testsuite/tests/simplCore/should_compile/T17366_AR.hs
new file mode 100644
index 0000000000..106f8109ac
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T17366_AR.hs
@@ -0,0 +1,21 @@
+{-# LANGUAGE DataKinds #-}
+module T17366_AR where
+
+import T17366_ARa
+
+--{-# SPECIALIZE test :: Eff es () #-}
+
+--testSpec :: Eff '[] () -- Specialization of 'test' works.
+testSpec :: Eff es () -- Specialization of 'test' doesn't work.
+testSpec = do
+  test
+  test
+  test
+
+-- Specialization of 'smallTest' works only if the INLINABLE pragma for 'smallTest'
+-- is commented out (!!!).
+smallTestSpec :: Eff es ()
+smallTestSpec = do
+  smallTest
+  smallTest
+  smallTest
diff --git a/testsuite/tests/simplCore/should_compile/T17366_AR.stderr b/testsuite/tests/simplCore/should_compile/T17366_AR.stderr
new file mode 100644
index 0000000000..2f1f28f568
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T17366_AR.stderr
@@ -0,0 +1,6 @@
+Rule fired: SPEC/T17366_AR test @(Eff es) (T17366_AR)
+Rule fired: SPEC/T17366_AR test @(Eff es) (T17366_AR)
+Rule fired: SPEC/T17366_AR test @(Eff es) (T17366_AR)
+Rule fired: SPEC/T17366_AR smallTest @(Eff es) (T17366_AR)
+Rule fired: SPEC/T17366_AR smallTest @(Eff es) (T17366_AR)
+Rule fired: SPEC/T17366_AR smallTest @(Eff es) (T17366_AR)
diff --git a/testsuite/tests/simplCore/should_compile/T17366_ARa.hs b/testsuite/tests/simplCore/should_compile/T17366_ARa.hs
new file mode 100644
index 0000000000..514737307a
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T17366_ARa.hs
@@ -0,0 +1,57 @@
+{-# LANGUAGE DataKinds #-}
+module T17366_ARa where
+
+import Control.Monad.IO.Class
+import Data.Kind
+
+type Effect = (Type -> Type) -> Type -> Type
+
+data Env (es :: [Effect]) = Env
+
+newtype Eff (es :: [Effect]) a = Eff { unEff :: Env es -> IO a }
+  deriving Functor
+
+instance Applicative (Eff es) where
+  pure a = Eff $ \_ -> pure a
+  f <*> a = Eff $ \es -> unEff f es <*> unEff a es
+
+instance Monad (Eff es) where
+  m >>= f = Eff $ \es -> unEff m es >>= (`unEff` es) . f
+
+instance MonadIO (Eff es) where
+  liftIO m = Eff $ \_ -> m
+
+----------------------------------------
+
+smallTest :: MonadIO m => m ()
+smallTest = do
+  liftIO $ putStrLn "test"
+  liftIO $ putStrLn "test"
+  liftIO $ putStrLn "test"
+  liftIO $ putStrLn "test"
+  liftIO $ putStrLn "test"
+{-# INLINABLE smallTest #-} -- When uncommented, smallTestSpec no longer uses specialized smallTest.
+
+test :: MonadIO m => m ()
+test = do
+  liftIO $ putStrLn "test"
+  liftIO $ putStrLn "test"
+  liftIO $ putStrLn "test"
+  liftIO $ putStrLn "test"
+  liftIO $ putStrLn "test"
+  liftIO $ putStrLn "test"
+  liftIO $ putStrLn "test"
+  liftIO $ putStrLn "test"
+  liftIO $ putStrLn "test"
+  liftIO $ putStrLn "test"
+  liftIO $ putStrLn "test"
+  liftIO $ putStrLn "test"
+  liftIO $ putStrLn "test"
+  liftIO $ putStrLn "test"
+  liftIO $ putStrLn "test"
+  liftIO $ putStrLn "test"
+  liftIO $ putStrLn "test"
+  liftIO $ putStrLn "test"
+  liftIO $ putStrLn "test"
+  liftIO $ putStrLn "test"
+{-# INLINABLE test #-}
diff --git a/testsuite/tests/simplCore/should_compile/T17366a.hs b/testsuite/tests/simplCore/should_compile/T17366a.hs
new file mode 100644
index 0000000000..ece130f31c
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T17366a.hs
@@ -0,0 +1,17 @@
+module T17366a where
+import Data.Functor.Identity
+
+class C f where
+  c :: f a -> a
+
+instance C Identity where
+  c (Identity a) = a
+
+newtype Tagged tag a = Tagged a
+
+instance C (Tagged tag) where
+  c (Tagged a) = a
+
+f :: C f => f a -> a
+f a = c a
+{-# INLINABLE[0] f #-}
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index 2e49f3aca8..52bc6379da 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -438,3 +438,7 @@ test('T22097', [grep_errmsg(r'case.*wgoEven') ], multimod_compile, ['T22097', '-
 test('T13873',  [ grep_errmsg(r'SPEC') ], compile, ['-O -ddump-rules'])
 test('T22357',  normal, compile, ['-O'])
 
+# T17366: expecting to see a rule
+#    Rule fired: SPEC/T17366 f @(Tagged tag) @_ (T17366)
+test('T17366',  normal, multimod_compile, ['T17366', '-O -v0 -ddump-rule-firings'])
+test('T17366_AR',  [grep_errmsg(r'SPEC')], multimod_compile, ['T17366_AR', '-O -v0 -ddump-rule-firings'])