[Git][ghc/ghc][wip/T16846] testsuite: Add test for #16846

[Ben Gamari]

Ben Gamari pushed to branch wip/T16846 at Glasgow Haskell Compiler / GHC


Commits:
05560cc9 by Ben Gamari at 2019-06-20T17:40:13Z
testsuite: Add test for #16846

- - - - -


2 changed files:

- + testsuite/tests/codeGen/should_run/T16846.hs
- testsuite/tests/codeGen/should_run/all.T


Changes:

=====================================
testsuite/tests/codeGen/should_run/T16846.hs
=====================================
@@ -0,0 +1,37 @@
+{-# LANGUAGE CPP  #-}
+{-# LANGUAGE ExistentialQuantification  #-}
+module Main (main) where
+
+import Control.Concurrent.STM
+
+data Free f a = Pure a | Free (f (Free f a))
+
+data SuspendF a
+  = forall r. StepSTM (STM r)
+  | forall r. StepIO (IO r)
+
+effect :: STM a -> Free SuspendF a
+effect a = Free $ StepSTM a
+
+io :: IO a -> Free SuspendF a
+io a = Free $ StepIO a
+
+comb :: [Free SuspendF a] -> Free SuspendF a
+comb vs = io $ do
+  _ <- mapM go vs
+  undefined
+
+go :: Free SuspendF a -> IO (STM ())
+go (Free (StepIO a))  = a >>= \_ -> go $ Pure undefined
+go (Free (StepSTM a)) = pure $ a >>= \_ -> pure ()
+go (Pure _)           = pure $ pure ()
+
+runWidget :: Free SuspendF a -> IO a
+runWidget w = case w of
+  Free (StepIO io) -> do
+    _ <- io
+    undefined
+
+-- Uncommenting this hid the original bug.
+--main :: IO ()
+main = runWidget $ comb $ replicate 10000000 (effect retry)


=====================================
testsuite/tests/codeGen/should_run/all.T
=====================================
@@ -197,3 +197,4 @@ test('T15892',
      compile_and_run, ['-O'])
 test('T16617', normal, compile_and_run, [''])
 test('T16449_2', exit_code(0), compile_and_run, [''])
+test('T16846', exit_code(0), compile_and_run, [''])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/05560cc9bd02f6a58dbcad5b24f3a3b10255f82e

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/05560cc9bd02f6a58dbcad5b24f3a3b10255f82e
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20190620/362bb1ae/attachment-0001.html>