threads 0.5.1.2 → 0.5.1.3

raw patch · 5 files changed

+131/−128 lines, 5 filesdep −base-unicode-symbolsdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: base-unicode-symbols

Dependency ranges changed: base

API changes (from Hackage documentation)

- Control.Concurrent.Thread: forkIO :: IO α -> IO (ThreadId, IO (Result α))

+ Control.Concurrent.Thread: forkIO :: IO a -> IO (ThreadId, IO (Result a))

- Control.Concurrent.Thread: forkIOWithUnmask :: ((forall β. IO β -> IO β) -> IO α) -> IO (ThreadId, IO (Result α))

+ Control.Concurrent.Thread: forkIOWithUnmask :: ((forall b. IO b -> IO b) -> IO a) -> IO (ThreadId, IO (Result a))

- Control.Concurrent.Thread: forkOS :: IO α -> IO (ThreadId, IO (Result α))

+ Control.Concurrent.Thread: forkOS :: IO a -> IO (ThreadId, IO (Result a))

- Control.Concurrent.Thread: forkOn :: Int -> IO α -> IO (ThreadId, IO (Result α))

+ Control.Concurrent.Thread: forkOn :: Int -> IO a -> IO (ThreadId, IO (Result a))

- Control.Concurrent.Thread: forkOnWithUnmask :: Int -> ((forall β. IO β -> IO β) -> IO α) -> IO (ThreadId, IO (Result α))

+ Control.Concurrent.Thread: forkOnWithUnmask :: Int -> ((forall b. IO b -> IO b) -> IO a) -> IO (ThreadId, IO (Result a))

- Control.Concurrent.Thread: result :: Result α -> IO α

+ Control.Concurrent.Thread: result :: Result a -> IO a

- Control.Concurrent.Thread: type Result α = Either SomeException α

+ Control.Concurrent.Thread: type Result a = Either SomeException a

- Control.Concurrent.Thread.Group: forkIO :: ThreadGroup -> IO α -> IO (ThreadId, IO (Result α))

+ Control.Concurrent.Thread.Group: forkIO :: ThreadGroup -> IO a -> IO (ThreadId, IO (Result a))

- Control.Concurrent.Thread.Group: forkIOWithUnmask :: ThreadGroup -> ((forall β. IO β -> IO β) -> IO α) -> IO (ThreadId, IO (Result α))

+ Control.Concurrent.Thread.Group: forkIOWithUnmask :: ThreadGroup -> ((forall b. IO b -> IO b) -> IO a) -> IO (ThreadId, IO (Result a))

- Control.Concurrent.Thread.Group: forkOS :: ThreadGroup -> IO α -> IO (ThreadId, IO (Result α))

+ Control.Concurrent.Thread.Group: forkOS :: ThreadGroup -> IO a -> IO (ThreadId, IO (Result a))

- Control.Concurrent.Thread.Group: forkOn :: Int -> ThreadGroup -> IO α -> IO (ThreadId, IO (Result α))

+ Control.Concurrent.Thread.Group: forkOn :: Int -> ThreadGroup -> IO a -> IO (ThreadId, IO (Result a))

- Control.Concurrent.Thread.Group: forkOnWithUnmask :: Int -> ThreadGroup -> ((forall β. IO β -> IO β) -> IO α) -> IO (ThreadId, IO (Result α))

+ Control.Concurrent.Thread.Group: forkOnWithUnmask :: Int -> ThreadGroup -> ((forall b. IO b -> IO b) -> IO a) -> IO (ThreadId, IO (Result a))

Files

Control/Concurrent/Raw.hs +7/−7
Control/Concurrent/Thread.hs +25/−25
Control/Concurrent/Thread/Group.hs +40/−31
test/test.hs +56/−60
threads.cabal +3/−5

Control/Concurrent/Raw.hs view

@@ -1,4 +1,4 @@-{-# LANGUAGE UnicodeSyntax, NoImplicitPrelude, MagicHash, UnboxedTuples #-}+{-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples #-}  module Control.Concurrent.Raw ( rawForkIO, rawForkOn ) where @@ -11,11 +11,11 @@ -- handler: saves a bit of time when we will be installing our own -- exception handler. {-# INLINE rawForkIO #-}-rawForkIO ∷ IO () → IO ThreadId-rawForkIO action = IO $ \s →-   case (fork# action s) of (# s1, tid #) → (# s1, ThreadId tid #)+rawForkIO :: IO () -> IO ThreadId+rawForkIO action = IO $ \s ->+   case (fork# action s) of (# s1, tid #) -> (# s1, ThreadId tid #)  {-# INLINE rawForkOn #-}-rawForkOn ∷ Int → IO () → IO ThreadId-rawForkOn (I# cpu) action = IO $ \s →-   case (forkOn# cpu action s) of (# s1, tid #) → (# s1, ThreadId tid #)+rawForkOn :: Int -> IO () -> IO ThreadId+rawForkOn (I# cpu) action = IO $ \s ->+   case (forkOn# cpu action s) of (# s1, tid #) -> (# s1, ThreadId tid #)

Control/Concurrent/Thread.hs view

@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, NoImplicitPrelude, UnicodeSyntax, RankNTypes, ImpredicativeTypes #-}+{-# LANGUAGE CPP, NoImplicitPrelude, RankNTypes, ImpredicativeTypes #-}  #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-}@@ -65,13 +65,10 @@ import Control.Exception            ( SomeException, try, throwIO, mask ) import Control.Monad                ( return, (>>=) ) import Data.Either                  ( Either(..), either )-import Data.Function                ( ($) )+import Data.Function                ( (.), ($) ) import Data.Int                     ( Int ) import System.IO                    ( IO ) --- from base-unicode-symbols:-import Data.Function.Unicode        ( (∘) )- -- from threads: import Control.Concurrent.Raw       ( rawForkIO, rawForkOn ) @@ -83,51 +80,54 @@ -- | Like @Control.Concurrent.'Control.Concurrent.forkIO'@ but returns -- a computation that when executed blocks until the thread terminates -- then returns the final value of the thread.-forkIO ∷ IO α → IO (ThreadId, IO (Result α))+forkIO :: IO a -> IO (ThreadId, IO (Result a)) forkIO = fork rawForkIO  -- | Like @Control.Concurrent.'Control.Concurrent.forkOS'@ but returns -- a computation that when executed blocks until the thread terminates -- then returns the final value of the thread.-forkOS ∷ IO α → IO (ThreadId, IO (Result α))+forkOS :: IO a -> IO (ThreadId, IO (Result a)) forkOS = fork Control.Concurrent.forkOS  -- | Like @Control.Concurrent.'Control.Concurrent.forkOn'@ but returns -- a computation that when executed blocks until the thread terminates -- then returns the final value of the thread.-forkOn ∷ Int → IO α → IO (ThreadId, IO (Result α))-forkOn = fork ∘ rawForkOn+forkOn :: Int -> IO a -> IO (ThreadId, IO (Result a))+forkOn = fork . rawForkOn  -- | Like @Control.Concurrent.'Control.Concurrent.forkIOWithUnmask'@ but returns -- a computation that when executed blocks until the thread terminates -- then returns the final value of the thread.-forkIOWithUnmask ∷ ((∀ β. IO β → IO β) → IO α) → IO (ThreadId, IO (Result α))+forkIOWithUnmask+    :: ((forall b. IO b -> IO b) -> IO a) -> IO (ThreadId, IO (Result a)) forkIOWithUnmask = forkWithUnmask Control.Concurrent.forkIOWithUnmask  -- | Like @Control.Concurrent.'Control.Concurrent.forkOnWithUnmask'@ but returns -- a computation that when executed blocks until the thread terminates -- then returns the final value of the thread.-forkOnWithUnmask ∷ Int → ((∀ β. IO β → IO β) → IO α) → IO (ThreadId, IO (Result α))-forkOnWithUnmask = forkWithUnmask ∘ Control.Concurrent.forkOnWithUnmask+forkOnWithUnmask+    :: Int -> ((forall b. IO b -> IO b) -> IO a) -> IO (ThreadId, IO (Result a))+forkOnWithUnmask = forkWithUnmask . Control.Concurrent.forkOnWithUnmask   -------------------------------------------------------------------------------- -- Utils -------------------------------------------------------------------------------- -fork ∷ (IO () → IO ThreadId) → (IO α → IO (ThreadId, IO (Result α)))-fork doFork = \a → do-  res ← newEmptyMVar-  tid ← mask $ \restore → doFork $ try (restore a) >>= putMVar res+fork :: (IO () -> IO ThreadId) -> (IO a -> IO (ThreadId, IO (Result a)))+fork doFork = \a -> do+  res <- newEmptyMVar+  tid <- mask $ \restore -> doFork $ try (restore a) >>= putMVar res   return (tid, readMVar res) -forkWithUnmask ∷ (((∀ β. IO β → IO β) → IO ()) → IO ThreadId)-               →  ((∀ β. IO β → IO β) → IO α)  → IO (ThreadId, IO (Result α))-forkWithUnmask doForkWithUnmask = \f → do-  res ← newEmptyMVar-  tid ← mask $ \restore →-          doForkWithUnmask $ \unmask →-            try (restore $ f unmask) >>= putMVar res+forkWithUnmask+    :: (((forall b. IO b -> IO b) -> IO ()) -> IO ThreadId)+    ->  ((forall b. IO b -> IO b) -> IO a)  -> IO (ThreadId, IO (Result a))+forkWithUnmask doForkWithUnmask = \f -> do+  res <- newEmptyMVar+  tid <- mask $ \restore ->+           doForkWithUnmask $ \unmask ->+             try (restore $ f unmask) >>= putMVar res   return (tid, readMVar res)  @@ -137,10 +137,10 @@  -- | A result of a thread is either some exception that was thrown in the thread -- and wasn't catched or the actual value that was returned by the thread.-type Result α = Either SomeException α+type Result a = Either SomeException a  -- | Retrieve the actual value from the result. -- -- When the result is 'SomeException' the exception is thrown.-result ∷ Result α → IO α+result :: Result a -> IO a result = either throwIO return

Control/Concurrent/Thread/Group.hs view

@@ -1,7 +1,6 @@ {-# LANGUAGE CPP            , DeriveDataTypeable            , NoImplicitPrelude-           , UnicodeSyntax            , ImpredicativeTypes            , RankNTypes #-} @@ -60,18 +59,15 @@ import Control.Concurrent.MVar          ( newEmptyMVar, putMVar, readMVar ) import Control.Exception                ( try, mask ) import Control.Monad                    ( return, (>>=), when )-import Data.Function                    ( ($) )+import Data.Function                    ( (.), ($) ) import Data.Functor                     ( fmap ) import Data.Eq                          ( Eq )+import Data.Ord                         ( (>=) ) import Data.Int                         ( Int ) import Data.Typeable                    ( Typeable ) import Prelude                          ( ($!), (+), subtract ) import System.IO                        ( IO ) --- from base-unicode-symbols:-import Data.Ord.Unicode                 ( (≥) )-import Data.Function.Unicode            ( (∘) )- -- from stm: import Control.Concurrent.STM.TVar      ( TVar, newTVarIO, readTVar, writeTVar ) import Control.Concurrent.STM           ( STM, atomically, retry )@@ -115,7 +111,7 @@ newtype ThreadGroup = ThreadGroup (TVar Int) deriving (Eq, Typeable)  -- | Create an empty group of threads.-new ∷ IO ThreadGroup+new :: IO ThreadGroup new = fmap ThreadGroup $ newTVarIO 0  {-| Yield a transaction that returns the number of running threads in the@@ -124,18 +120,18 @@ Note that because this function yields a 'STM' computation, the returned number is guaranteed to be consistent inside the transaction. -}-nrOfRunning ∷ ThreadGroup → STM Int+nrOfRunning :: ThreadGroup -> STM Int nrOfRunning (ThreadGroup numThreadsTV) = readTVar numThreadsTV  -- | Block until all threads in the group have terminated. -- -- Note that: @wait = 'waitN' 1@.-wait ∷ ThreadGroup → IO ()+wait :: ThreadGroup -> IO () wait = waitN 1  -- | Block until there are fewer than @N@ running threads in the group.-waitN ∷ Int -> ThreadGroup → IO ()-waitN i tg = atomically $ nrOfRunning tg >>= \n → when (n ≥ i) retry+waitN :: Int -> ThreadGroup -> IO ()+waitN i tg = atomically $ nrOfRunning tg >>= \n -> when (n >= i) retry   --------------------------------------------------------------------------------@@ -144,59 +140,72 @@  -- | Same as @Control.Concurrent.Thread.'Thread.forkIO'@ but additionaly adds -- the thread to the group.-forkIO ∷ ThreadGroup → IO α → IO (ThreadId, IO (Result α))+forkIO :: ThreadGroup -> IO a -> IO (ThreadId, IO (Result a)) forkIO = fork rawForkIO  -- | Same as @Control.Concurrent.Thread.'Thread.forkOS'@ but additionaly adds -- the thread to the group.-forkOS ∷ ThreadGroup → IO α → IO (ThreadId, IO (Result α))+forkOS :: ThreadGroup -> IO a -> IO (ThreadId, IO (Result a)) forkOS = fork Control.Concurrent.forkOS  -- | Same as @Control.Concurrent.Thread.'Thread.forkOn'@ but -- additionaly adds the thread to the group.-forkOn ∷ Int → ThreadGroup → IO α → IO (ThreadId, IO (Result α))-forkOn = fork ∘ rawForkOn+forkOn :: Int -> ThreadGroup -> IO a -> IO (ThreadId, IO (Result a))+forkOn = fork . rawForkOn  -- | Same as @Control.Concurrent.Thread.'Thread.forkIOWithUnmask'@ but -- additionaly adds the thread to the group.-forkIOWithUnmask ∷ ThreadGroup → ((∀ β. IO β → IO β) → IO α) → IO (ThreadId, IO (Result α))+forkIOWithUnmask+    :: ThreadGroup+    -> ((forall b. IO b -> IO b) -> IO a)+    -> IO (ThreadId, IO (Result a)) forkIOWithUnmask = forkWithUnmask Control.Concurrent.forkIOWithUnmask  -- | Like @Control.Concurrent.Thread.'Thread.forkOnWithUnmask'@ but -- additionaly adds the thread to the group.-forkOnWithUnmask ∷ Int → ThreadGroup → ((∀ β. IO β → IO β) → IO α) → IO (ThreadId, IO (Result α))-forkOnWithUnmask = forkWithUnmask ∘ Control.Concurrent.forkOnWithUnmask+forkOnWithUnmask+    :: Int+    -> ThreadGroup+    -> ((forall b. IO b -> IO b) -> IO a)+    -> IO (ThreadId, IO (Result a))+forkOnWithUnmask = forkWithUnmask . Control.Concurrent.forkOnWithUnmask   -------------------------------------------------------------------------------- -- Utils -------------------------------------------------------------------------------- -fork ∷ (IO () → IO ThreadId) → ThreadGroup → IO α → IO (ThreadId, IO (Result α))+fork :: (IO () -> IO ThreadId)+     -> ThreadGroup+     -> IO a+     -> IO (ThreadId, IO (Result a)) fork doFork (ThreadGroup numThreadsTV) a = do-  res ← newEmptyMVar-  tid ← mask $ \restore → do+  res <- newEmptyMVar+  tid <- mask $ \restore -> do     atomically $ modifyTVar numThreadsTV (+ 1)     doFork $ do       try (restore a) >>= putMVar res       atomically $ modifyTVar numThreadsTV (subtract 1)   return (tid, readMVar res) -forkWithUnmask ∷ (((∀ β. IO β → IO β) → IO ()) → IO ThreadId)-               → ThreadGroup → ((∀ β. IO β → IO β) → IO α) → IO (ThreadId, IO (Result α))-forkWithUnmask doForkWithUnmask = \(ThreadGroup numThreadsTV) f → do-  res ← newEmptyMVar-  tid ← mask $ \restore → do+forkWithUnmask+    :: (((forall b. IO b -> IO b) -> IO ()) -> IO ThreadId)+    -> ThreadGroup+    -> ((forall b. IO b -> IO b) -> IO a)+    -> IO (ThreadId, IO (Result a))+forkWithUnmask doForkWithUnmask = \(ThreadGroup numThreadsTV) f -> do+  res <- newEmptyMVar+  tid <- mask $ \restore -> do     atomically $ modifyTVar numThreadsTV (+ 1)-    doForkWithUnmask $ \unmask → do+    doForkWithUnmask $ \unmask -> do       try (restore $ f unmask) >>= putMVar res       atomically $ modifyTVar numThreadsTV (subtract 1)   return (tid, readMVar res)  -- | Strictly modify the contents of a 'TVar'.-modifyTVar ∷ TVar α → (α → α) → STM ()-modifyTVar tv f = readTVar tv >>= writeTVar tv ∘! f+modifyTVar :: TVar a -> (a -> a) -> STM ()+modifyTVar tv f = readTVar tv >>= writeTVar tv .! f  -- | Strict function composition-(∘!) ∷ (β → γ) → (α → β) → (α → γ)-f ∘! g = \x → f $! g x+(.!) :: (b -> c) -> (a -> b) -> (a -> c)+f .! g = \x -> f $! g x

test/test.hs view

@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude, UnicodeSyntax, DeriveDataTypeable #-}+{-# LANGUAGE NoImplicitPrelude, DeriveDataTypeable, ImpredicativeTypes #-}  module Main where @@ -17,7 +17,7 @@ import Data.Bool          ( Bool(False, True) ) import Data.Eq            ( Eq, (==) ) import Data.Either        ( either )-import Data.Function      ( ($), id, const, flip )+import Data.Function      ( (.), ($), id, const, flip ) import Data.Functor       ( Functor(fmap), (<$>) ) import Data.Int           ( Int ) import Data.Maybe         ( Maybe, maybe )@@ -26,11 +26,7 @@ import System.Timeout     ( timeout ) import System.IO          ( IO ) import Text.Show          ( Show )---- from base-unicode-symbols:-import Data.Eq.Unicode       ( (≡) )-import Prelude.Unicode       ( (⋅) )-import Data.Function.Unicode ( (∘) )+import Prelude            ( (*) )  -- from concurrent-extra: import qualified Control.Concurrent.Lock as Lock@@ -59,10 +55,10 @@ -- Tests -------------------------------------------------------------------------------- -main ∷ IO ()+main :: IO () main = defaultMain tests -tests ∷ [Test]+tests :: [Test] tests = [ testGroup "Thread" $           [ testGroup "forkIO" $             [ testCase "wait"            $ test_wait            Thread.forkIO@@ -126,22 +122,22 @@             , testCase "sync exception"    $ wrapIOWithUnmask test_sync_exception             , testCase "async exception"   $ wrapIOWithUnmask test_async_exception -            , testCase "group single wait" $ test_group_single_wait $ wrapUnmask ∘ ThreadGroup.forkIOWithUnmask-            , testCase "group nrOfRunning" $ test_group_nrOfRunning $ wrapUnmask ∘ ThreadGroup.forkIOWithUnmask+            , testCase "group single wait" $ test_group_single_wait $ wrapUnmask . ThreadGroup.forkIOWithUnmask+            , testCase "group nrOfRunning" $ test_group_nrOfRunning $ wrapUnmask . ThreadGroup.forkIOWithUnmask             ]           , testGroup "forkOnWithUnmask 0" $             [ testCase "wait"              $ wrapOnWithUnmask test_wait             , testCase "sync exception"    $ wrapOnWithUnmask test_sync_exception             , testCase "async exception"   $ wrapOnWithUnmask test_async_exception -            , testCase "group single wait" $ test_group_single_wait $ wrapUnmask ∘ ThreadGroup.forkOnWithUnmask 0-            , testCase "group nrOfRunning" $ test_group_nrOfRunning $ wrapUnmask ∘ ThreadGroup.forkOnWithUnmask 0+            , testCase "group single wait" $ test_group_single_wait $ wrapUnmask . ThreadGroup.forkOnWithUnmask 0+            , testCase "group nrOfRunning" $ test_group_nrOfRunning $ wrapUnmask . ThreadGroup.forkOnWithUnmask 0             ]           ]         ]  -- Exactly 1 moment. Currently equal to 0.005 seconds.-a_moment ∷ Int+a_moment :: Int a_moment = 5000  @@ -149,48 +145,48 @@ -- General properties -------------------------------------------------------------------------------- -type Fork α = IO α → IO (ThreadId, IO (Result α))+type Fork a = IO a -> IO (ThreadId, IO (Result a)) -wrapUnmask ∷ ((β → α) → t) → α → t+wrapUnmask :: ((b -> a) -> t) -> a -> t wrapUnmask forkWithUnmask = \m -> forkWithUnmask $ const m -test_wait ∷ Fork () → Assertion-test_wait fork = assert $ fmap isJustTrue $ timeout (10 ⋅ a_moment) $ do-  r ← newIORef False-  (_, wait) ← fork $ do-    threadDelay $ 2 ⋅ a_moment+test_wait :: Fork () -> Assertion+test_wait fork = assert $ fmap isJustTrue $ timeout (10 * a_moment) $ do+  r <- newIORef False+  (_, wait) <- fork $ do+    threadDelay $ 2 * a_moment     writeIORef r True-  _ ← wait+  _ <- wait   readIORef r -test_maskingState ∷ Fork Bool → Assertion-test_maskingState fork = do (_, wait) ← mask_ $ fork $+test_maskingState :: Fork Bool -> Assertion+test_maskingState fork = do (_, wait) <- mask_ $ fork $                               (MaskedInterruptible ==) <$> getMaskingState                             wait >>= result >>= assert -test_sync_exception ∷ Fork () → Assertion+test_sync_exception :: Fork () -> Assertion test_sync_exception fork = assert $ do-  (_, wait) ← fork $ throwIO MyException+  (_, wait) <- fork $ throwIO MyException   waitForException MyException wait -waitForException ∷ (Exception e, Eq e) ⇒ e → IO (Result α) → IO Bool-waitForException e wait = wait <$$> either (justEq e ∘ fromException)-                                           (const False)+waitForException :: (Exception e, Eq e) => e -> IO (Result a) -> IO Bool+waitForException e wait = wait <&> either (justEq e . fromException)+                                          (const False) -test_async_exception ∷ Fork () → Assertion+test_async_exception :: Fork () -> Assertion test_async_exception fork = assert $ do-  l ← Lock.newAcquired-  (tid, wait) ← fork $ Lock.acquire l+  l <- Lock.newAcquired+  (tid, wait) <- fork $ Lock.acquire l   throwTo tid MyException   waitForException MyException wait  data MyException = MyException deriving (Show, Eq, Typeable) instance Exception MyException -test_killThread ∷ Fork () → Assertion+test_killThread :: Fork () -> Assertion test_killThread fork = assert $ do-  l ← Lock.newAcquired-  (tid, wait) ← fork $ Lock.acquire l+  l <- Lock.newAcquired+  (tid, wait) <- fork $ Lock.acquire l   killThread tid   waitForException ThreadKilled wait @@ -199,46 +195,46 @@ -- ThreadGroup -------------------------------------------------------------------------------- -wrapIO ∷ (Fork α → IO β) → IO β+wrapIO :: (Fork a -> IO b) -> IO b wrapIO = wrap ThreadGroup.forkIO -wrapOS ∷ (Fork α → IO β) → IO β+wrapOS :: (Fork a -> IO b) -> IO b wrapOS = wrap ThreadGroup.forkOS -wrapOn_0 ∷ (Fork α → IO β) → IO β+wrapOn_0 :: (Fork a -> IO b) -> IO b wrapOn_0 = wrap $ ThreadGroup.forkOn 0 -wrapIOWithUnmask ∷ (Fork α → IO β) → IO β+wrapIOWithUnmask :: (Fork a -> IO b) -> IO b wrapIOWithUnmask = wrap $ \tg m -> ThreadGroup.forkIOWithUnmask tg $ const m -wrapOnWithUnmask ∷ (Fork α → IO β) → IO β+wrapOnWithUnmask :: (Fork a -> IO b) -> IO b wrapOnWithUnmask = wrap $ \tg m -> ThreadGroup.forkOnWithUnmask 0 tg $ const m -wrap ∷ (ThreadGroup → Fork α) → (Fork α → IO β) → IO β-wrap doFork test = ThreadGroup.new >>= test ∘ doFork+wrap :: (ThreadGroup -> Fork a) -> (Fork a -> IO b) -> IO b+wrap doFork test = ThreadGroup.new >>= test . doFork -test_group_single_wait ∷ (ThreadGroup → Fork ()) → Assertion-test_group_single_wait doFork = assert $ fmap isJustTrue $ timeout (10 ⋅ a_moment) $ do-  tg ← ThreadGroup.new-  r ← newIORef False-  _ ← doFork tg $ do-    threadDelay $ 2 ⋅ a_moment+test_group_single_wait :: (ThreadGroup -> Fork ()) -> Assertion+test_group_single_wait doFork = assert $ fmap isJustTrue $ timeout (10 * a_moment) $ do+  tg <- ThreadGroup.new+  r <- newIORef False+  _ <- doFork tg $ do+    threadDelay $ 2 * a_moment     writeIORef r True-  _ ← ThreadGroup.wait tg+  _ <- ThreadGroup.wait tg   readIORef r -test_group_nrOfRunning ∷ (ThreadGroup → Fork ()) → Assertion-test_group_nrOfRunning doFork = assert $ fmap isJustTrue $ timeout (10 ⋅ a_moment) $ do-  tg ← ThreadGroup.new-  l ← Lock.newAcquired+test_group_nrOfRunning :: (ThreadGroup -> Fork ()) -> Assertion+test_group_nrOfRunning doFork = assert $ fmap isJustTrue $ timeout (10 * a_moment) $ do+  tg <- ThreadGroup.new+  l <- Lock.newAcquired   replicateM_ n $ doFork tg $ Lock.acquire l-  true ← fmap (≡ n) $ (atomically $ ThreadGroup.nrOfRunning tg ∷ IO Int)+  true <- fmap (== n) $ (atomically $ ThreadGroup.nrOfRunning tg :: IO Int)   Lock.release l   return true     where       -- Don't set this number too big otherwise forkOS might throw an exception       -- indicating that too many OS threads have been created:-      n ∷ Int+      n :: Int       n = 100  @@ -247,13 +243,13 @@ --------------------------------------------------------------------------------  -- | Check if the given value equals 'Just' 'True'.-isJustTrue ∷ Maybe Bool → Bool+isJustTrue :: Maybe Bool -> Bool isJustTrue = maybe False id  -- | Check if the given value in the 'Maybe' equals the given reference value.-justEq ∷ Eq α ⇒ α → Maybe α → Bool-justEq = maybe False ∘ (≡)+justEq :: Eq a => a -> Maybe a -> Bool+justEq = maybe False . (==)  -- | A flipped '<$>'.-(<$$>) ∷ Functor f ⇒ f α → (α → β) → f β-(<$$>) = flip (<$>)+(<&>) :: (Functor f) => f a -> (a -> b) -> f b+(<&>) = flip (<$>)

threads.cabal view

@@ -1,5 +1,5 @@ name:          threads-version:       0.5.1.2+version:       0.5.1.3 cabal-version: >= 1.9.2 build-type:    Custom stability:     experimental@@ -45,8 +45,7 @@ -------------------------------------------------------------------------------  library-  build-depends: base                 >= 4.4   && < 4.8-               , base-unicode-symbols >= 0.1.1 && < 0.3+  build-depends: base                 >= 4.4   && < 4.9                , stm                  >= 2.1   && < 2.5   exposed-modules: Control.Concurrent.Thread                  , Control.Concurrent.Thread.Group@@ -62,8 +61,7 @@   ghc-options:    -Wall -threaded    build-depends: threads-               , base                 >= 4.4   && < 4.8-               , base-unicode-symbols >= 0.1.1 && < 0.3+               , base                 >= 4.4   && < 4.9                , stm                  >= 2.1   && < 2.5                , concurrent-extra     >= 0.5.1 && < 0.8                , HUnit                >= 1.2.2 && < 1.3