summaryrefslogtreecommitdiff
path: root/testsuite
diff options
context:
space:
mode:
authorSimon Peyton Jones <simonpj@microsoft.com>2022-10-31 15:44:33 +0000
committerMarge Bot <ben+marge-bot@smart-cactus.org>2022-11-01 12:51:00 -0400
commit4521f6498d09f48a775a028efdd763c874da3451 (patch)
tree1d8ae6df29c894b39f39ff8f25db282f1e315cf8 /testsuite
parent77e2490218aa8dff160b0638ee758fa61d7932f9 (diff)
downloadhaskell-4521f6498d09f48a775a028efdd763c874da3451.tar.gz
Add two tests for #17366
Diffstat (limited to 'testsuite')
-rw-r--r--testsuite/tests/simplCore/should_compile/T17366.hs9
-rw-r--r--testsuite/tests/simplCore/should_compile/T17366.stderr2
-rw-r--r--testsuite/tests/simplCore/should_compile/T17366_AR.hs21
-rw-r--r--testsuite/tests/simplCore/should_compile/T17366_AR.stderr6
-rw-r--r--testsuite/tests/simplCore/should_compile/T17366_ARa.hs57
-rw-r--r--testsuite/tests/simplCore/should_compile/T17366a.hs17
-rw-r--r--testsuite/tests/simplCore/should_compile/all.T4
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'])