From d3e00ea7265e2c27d6098a64e399c1f100d4439a Mon Sep 17 00:00:00 2001
From: Matthew Pickering <matthewtpickering@gmail.com>
Date: Wed, 26 Oct 2022 12:16:07 +0100
Subject: testsuite: Add tests for T22347

These are fixed in recent versions but might as well add regression
tests.

See #22347
---
 testsuite/tests/simplCore/should_compile/T22347.hs  | 20 ++++++++++++++++++++
 testsuite/tests/simplCore/should_compile/T22347a.hs | 20 ++++++++++++++++++++
 testsuite/tests/simplCore/should_compile/all.T      |  2 ++
 3 files changed, 42 insertions(+)
 create mode 100644 testsuite/tests/simplCore/should_compile/T22347.hs
 create mode 100644 testsuite/tests/simplCore/should_compile/T22347a.hs

diff --git a/testsuite/tests/simplCore/should_compile/T22347.hs b/testsuite/tests/simplCore/should_compile/T22347.hs
new file mode 100644
index 0000000000..727eedf8db
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T22347.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+module M where
+
+import Control.Monad.ST
+import Data.Array.ST
+import Data.Array.Unboxed
+
+bfs :: Array Int [Int] -> ST s (STArray s Int ())
+bfs g = do
+    vis :: STArray s Int () <- newArray (bounds g) ()
+    ch :: STArray s Int () <- newArray (bounds g) ()
+    let go [] = pure () :: ST s ()
+        go q = do
+            flip mapM_ q $ \u -> do
+                readArray vis (head (g!u))
+                readArray ch u
+                writeArray ch u ()
+            go []
+    go []
+    pure ch
diff --git a/testsuite/tests/simplCore/should_compile/T22347a.hs b/testsuite/tests/simplCore/should_compile/T22347a.hs
new file mode 100644
index 0000000000..727eedf8db
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T22347a.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+module M where
+
+import Control.Monad.ST
+import Data.Array.ST
+import Data.Array.Unboxed
+
+bfs :: Array Int [Int] -> ST s (STArray s Int ())
+bfs g = do
+    vis :: STArray s Int () <- newArray (bounds g) ()
+    ch :: STArray s Int () <- newArray (bounds g) ()
+    let go [] = pure () :: ST s ()
+        go q = do
+            flip mapM_ q $ \u -> do
+                readArray vis (head (g!u))
+                readArray ch u
+                writeArray ch u ()
+            go []
+    go []
+    pure ch
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index 52bc6379da..29d3866167 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -437,6 +437,8 @@ 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'])
+test('T22347',  normal, compile, ['-O -fno-full-laziness'])
+test('T22347a', normal, compile, ['-O2 -fno-full-laziness'])
 
 # T17366: expecting to see a rule
 #    Rule fired: SPEC/T17366 f @(Tagged tag) @_ (T17366)
-- 
cgit v1.2.1