summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorBrianLewis <>2009-05-08 01:38:21 (GMT)
committerLuite Stegeman <luite@luite.com>2009-05-08 01:38:21 (GMT)
commitf79f4b6078372d7834cb3c576204fe11f3671e99 (patch)
tree8801675dd211b19d22ef1e56b8e13763c3138984
version 0.10.1
-rw-r--r--LICENSE26
-rw-r--r--Setup.hs6
-rw-r--r--src/Control/Concurrent/ThreadManager.hs76
-rw-r--r--threadmanager.cabal25
4 files changed, 133 insertions, 0 deletions
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..1b6b40e
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,26 @@
+Copyright Bryan O'Sullivan, Don Stewart, John Goerzen, Brian Lewis, Ian Taylor 2009
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..a7ad455
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,6 @@
+module Main (main) where
+
+import Distribution.Simple (defaultMain)
+
+main :: IO ()
+main = defaultMain
diff --git a/src/Control/Concurrent/ThreadManager.hs b/src/Control/Concurrent/ThreadManager.hs
new file mode 100644
index 0000000..33d58cc
--- /dev/null
+++ b/src/Control/Concurrent/ThreadManager.hs
@@ -0,0 +1,76 @@
+{-|
+ A simple thread management API inspired by the one in chapter
+ 24 of /Real World Haskell/.
+
+ See <http://book.realworldhaskell.org/read/concurrent-and-multicore-programming.html>.
+
+ Intended to be imported qualified (suggestion: TM).
+ -}
+
+module Control.Concurrent.ThreadManager
+ ( ThreadManager
+ , ThreadStatus
+ , make
+ , fork, forkn, getStatus, waitFor, waitForAll
+ ) where
+
+import Control.Concurrent (ThreadId, forkIO)
+import Control.Concurrent.MVar (MVar, modifyMVar, newEmptyMVar, newMVar, putMVar, takeMVar, tryTakeMVar)
+import Control.Exception (SomeException, try)
+import Control.Monad (join, replicateM)
+import qualified Data.Map as M
+
+data ThreadStatus =
+ Running
+ | Finished
+ | Threw SomeException
+ deriving Show
+
+newtype ThreadManager = TM (MVar (M.Map ThreadId (MVar ThreadStatus)))
+ deriving Eq
+
+-- | Make a thread manager.
+make :: IO ThreadManager
+make = TM `fmap` newMVar M.empty
+
+-- | Make a managed thread.
+fork :: ThreadManager -> IO () -> IO ThreadId
+fork (TM tm) action =
+ modifyMVar tm $ \m -> do
+ state <- newEmptyMVar
+ tid <- forkIO $ do
+ r <- try action
+ putMVar state (either Threw (const Finished) r)
+ return (M.insert tid state m, tid)
+
+-- | Make the given number of managed threads.
+forkn :: ThreadManager -> Int -> IO () -> IO [ThreadId]
+forkn tm n = replicateM n . fork tm
+
+-- | Get the status of a managed thread.
+getStatus :: ThreadManager -> ThreadId -> IO (Maybe ThreadStatus)
+getStatus (TM tm) tid =
+ modifyMVar tm $ \m ->
+ case M.lookup tid m of
+ Nothing -> return (m, Nothing)
+ Just state -> tryTakeMVar state >>= \mst ->
+ return $
+ case mst of
+ Nothing -> (m, Just Running)
+ Just sth -> (M.delete tid m, Just sth)
+
+-- | Block until a specific managed thread terminates.
+waitFor :: ThreadManager -> ThreadId -> IO (Maybe ThreadStatus)
+waitFor (TM tm) tid =
+ join . modifyMVar tm $ \m ->
+ return $
+ case M.updateLookupWithKey (\_ _ -> Nothing) tid m of
+ (Nothing, _) -> (m, return Nothing)
+ (Just state, m') -> (m', Just `fmap` takeMVar state)
+
+-- | Block until all managed threads terminate.
+waitForAll :: ThreadManager -> IO ()
+waitForAll (TM tm) =
+ modifyMVar tm elems >>= mapM_ takeMVar
+ where
+ elems m = return (M.empty, M.elems m)
diff --git a/threadmanager.cabal b/threadmanager.cabal
new file mode 100644
index 0000000..44421e5
--- /dev/null
+++ b/threadmanager.cabal
@@ -0,0 +1,25 @@
+name: threadmanager
+version: 0.1
+license: BSD3
+license-file: LICENSE
+author: _Real World Haskell_, http://www.realworldhaskell.org/
+maintainer: Brian Lewis <brian@lorf.org>, Ian Taylor <ian@lorf.org>
+homepage: http://github.com/bsl/threadmanager
+
+category: Concurrency
+synopsis: Simple thread management
+description: A simple thread management API inspired by the one in chapter 24
+ of /Real World Haskell/.
+ .
+ See <http://book.realworldhaskell.org/read/concurrent-and-multicore-programming.html>.
+
+cabal-version: >= 1.6
+build-type: Simple
+
+library
+ hs-source-dirs: src
+ exposed-modules: Control.Concurrent.ThreadManager
+ build-depends: base == 4.*, containers == 0.2.*
+ ghc-options: -Wall
+ if impl(ghc >= 6.8)
+ ghc-options: -fwarn-tabs