Skip to content

Commit

Permalink
add regression test for #33
Browse files Browse the repository at this point in the history
  • Loading branch information
mitchellwrosen committed Jul 15, 2024
1 parent 48f351f commit ea61f66
Showing 1 changed file with 21 additions and 2 deletions.
23 changes: 21 additions & 2 deletions ki/test/Tests.hs
Original file line number Diff line number Diff line change
@@ -1,9 +1,10 @@
module Main (main) where

import Control.Concurrent (newEmptyMVar, putMVar, takeMVar, threadDelay)
import Control.Concurrent (newEmptyMVar, putMVar, readMVar, takeMVar, threadDelay)
import Control.Concurrent.STM (atomically)
import Control.Exception
import Control.Monad
import Data.IORef
import GHC.IO (unsafeUnmask)
import qualified Ki
import Test.Tasty (TestTree, defaultMain, testGroup)
Expand Down Expand Up @@ -119,7 +120,25 @@ tests =
Ki.forkWith_ scope Ki.defaultThreadOptions {Ki.maskingState = MaskedInterruptible} do
putMVar ready ()
unsafeUnmask (forever (threadDelay maxBound)) `finally` throwIO A
takeMVar ready
takeMVar ready,
testCase "regression test https://github.com/awkward-squad/ki/issues/33" do
ref <- newIORef False
ready <- newEmptyMVar

handle (\A -> pure ()) do
Ki.scoped \scope1 -> do
_ <-
Ki.fork scope1 do
readMVar ready
throwIO A
Ki.scoped \scope2 -> do
_ <-
Ki.fork scope2 do
(putMVar ready () >> threadDelay 1_000_000) `catch` \(_ :: SomeException) ->
writeIORef ref True
atomically (Ki.awaitAll scope2)

readIORef ref `shouldReturn` True
]

data A = A
Expand Down

0 comments on commit ea61f66

Please sign in to comment.