summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRomanCheplyaka <>2016-03-17 10:25:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2016-03-17 10:25:00 (GMT)
commit200ed2d5a98639922d45cca2399c78500b7ad11f (patch)
tree3568c314694e3315896aa4de53033adcdbe98330
parentdbda9464da5c74add7009d8bf302658113d02213 (diff)
version 0.2.20.2.2
-rw-r--r--CHANGELOG.md10
-rw-r--r--README.md2
-rw-r--r--immortal.cabal5
-rw-r--r--src/Control/Immortal.hs52
-rw-r--r--tests/test.hs45
5 files changed, 99 insertions, 15 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index f836797..e9d758a 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,6 +1,16 @@
CHANGES
=======
+Version 0.2.2
+-------------
+
+Add `onUnexpectedFinish`
+
+Version 0.2.1
+-------------
+
+Add `wait` and `wait-stm` functions
+
Version 0.2
-----------
diff --git a/README.md b/README.md
index 21163ee..b73575f 100644
--- a/README.md
+++ b/README.md
@@ -11,7 +11,7 @@ import Control.Monad (forever)
main = do
-- start an immortal thread
- _ <- Immortal.create $ do
+ _thread <- Immortal.create $ \ _thread -> do
-- do stuff
-- in the main thread, sleep until interrupted
diff --git a/immortal.cabal b/immortal.cabal
index 0bb66b0..bec0b97 100644
--- a/immortal.cabal
+++ b/immortal.cabal
@@ -2,7 +2,7 @@
-- documentation, see http://haskell.org/cabal/users-guide/
name: immortal
-version: 0.2
+version: 0.2.2
synopsis: Spawn threads that never die (unless told to do so)
-- description:
homepage: https://github.com/feuerbach/immortal
@@ -25,7 +25,8 @@ library
base >=4.5 && <5,
lifted-base >=0.2,
transformers-base >=0.4,
- monad-control >=0.3
+ monad-control >=0.3,
+ stm
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -Wall
diff --git a/src/Control/Immortal.hs b/src/Control/Immortal.hs
index 5ca2d91..7ea89a9 100644
--- a/src/Control/Immortal.hs
+++ b/src/Control/Immortal.hs
@@ -9,20 +9,23 @@ module Control.Immortal
, mortalize
, immortalize
, stop
+ , wait
+ , waitSTM
, threadId
, onFinish
+ , onUnexpectedFinish
) where
import Control.Exception.Lifted
-import Control.Monad
import Control.Monad.Base
import Control.Monad.Trans.Control
import Control.Concurrent.Lifted
import Data.IORef
import GHC.Conc (labelThread)
+import Control.Concurrent.STM
-- | Immortal thread identifier (including its underlying 'ThreadId')
-data Thread = Thread ThreadId (IORef Bool)
+data Thread = Thread ThreadId (IORef Bool) (TVar Bool)
-- | Spawn a new immortal thread running the given computation.
--
@@ -45,19 +48,23 @@ create a = uninterruptibleMask $ \restore -> do
-- better be safe than sorry. Besides, we're using operations from
-- `MonadBaseControl` and related instances, and those could potentially
-- (though unlikely) block.
- stopRef <- liftBase $ newIORef False
+ stopRef <- liftBase $ newIORef False
+ finishedRef <- liftBase $ newTVarIO False
let
go = do
-- construct a thread object from within the thread itself
pid <- myThreadId
- let thread = Thread pid stopRef
+ let thread = Thread pid stopRef finishedRef
handle (\(_ :: SomeException) -> return ()) (restore $ a thread)
stopNow <- liftBase $ readIORef stopRef
- unless stopNow go
+ if stopNow then
+ liftBase $ atomically $ writeTVar finishedRef True
+ else
+ go
pid <- fork go
- return $ Thread pid stopRef
+ return $ Thread pid stopRef finishedRef
-- | Like 'create', but also apply the given label to the thread
-- (using 'labelThread').
@@ -72,14 +79,14 @@ createWithLabel label a = do
--
-- Calling this on an already mortalized thread has no effect.
mortalize :: Thread -> IO ()
-mortalize (Thread _ stopRef) = writeIORef stopRef True
+mortalize (Thread _ stopRef _) = writeIORef stopRef True
-- | If a thread was 'mortalize'd, this will make it immortal again. However,
-- if it finished while being in the mortal state, it won't be resurrected.
--
-- Calling this on an immortal thread has no effect.
immortalize :: Thread -> IO ()
-immortalize (Thread _ stopRef) = writeIORef stopRef False
+immortalize (Thread _ stopRef _) = writeIORef stopRef False
-- | Stop (kill) an immortal thread.
--
@@ -93,19 +100,27 @@ stop t = do
mortalize t
killThread (threadId t)
+-- | Wait for the thread to stop. Use 'stop' to stop the thread
+wait :: Thread -> IO ()
+wait = atomically . waitSTM
+
+-- | An STM version of 'wait'
+waitSTM :: Thread -> STM ()
+waitSTM (Thread _ _ finishedRef) = check =<< readTVar finishedRef
+
-- | Get the 'ThreadId' of the immortal thread.
--
-- The 'ThreadId' can be used to throw asynchronous exception to interrupt
-- the computation. This won't kill the thread, however — even if the
-- exception is not handled, the computation will be simply restarted.
threadId :: Thread -> ThreadId
-threadId (Thread pid _) = pid
+threadId (Thread pid _ _) = pid
-- | Run a callback every time the action finishes. This can be used e.g.
-- to log exceptions or attempts to exit when such attempts are
-- not expected. Example usage:
--
--- >Immortal.create $ Immortal.onFinish print myAction
+-- >Immortal.create $ \_ -> Immortal.onFinish print myAction
--
-- This is nothing more than a simple wrapper around 'try'.
onFinish
@@ -113,3 +128,20 @@ onFinish
=> (Either SomeException () -> m ())
-> m () -> m ()
onFinish cb a = try a >>= cb
+
+-- | Like 'onFinish', but the callback does not run when the thread is
+-- mortalized (i.e. when the exit is expected).
+--
+-- The 'Thread' argument is used to find out the mortality of the thread.
+onUnexpectedFinish
+ :: MonadBaseControl IO m
+ => Thread
+ -> (Either SomeException () -> m ())
+ -> m ()
+ -> m ()
+onUnexpectedFinish (Thread _ stopRef _) cb a = do
+ r <- try a
+ expected <- liftBase $ readIORef stopRef
+ if expected
+ then return ()
+ else cb r
diff --git a/tests/test.hs b/tests/test.hs
index 35e4cb3..0372fc3 100644
--- a/tests/test.hs
+++ b/tests/test.hs
@@ -9,6 +9,7 @@ import Control.Concurrent
import Control.Concurrent.STM
import Control.Monad.Trans.State
import Control.Monad.IO.Class
+import System.Timeout
-- Almost bracket, but we don't want to start a thread inside mask
-- See http://ro-che.info/articles/2014-07-30-bracket.html
@@ -17,6 +18,11 @@ withImmortal comp inner = do
thread <- Immortal.create $ const comp
inner `finally` Immortal.stop thread
+withImmortalThread :: (Immortal.Thread -> IO ()) -> (Immortal.Thread -> IO c) -> IO c
+withImmortalThread comp inner = do
+ thread <- Immortal.create comp
+ inner thread `finally` Immortal.stop thread
+
main :: IO ()
main = defaultMain $ testGroup "Tests"
[ testCase "is not killed by an exception" $ do
@@ -84,7 +90,7 @@ main = defaultMain $ testGroup "Tests"
Just (Right ()) -> return ()
_ -> assertFailure $ "unexpected result: " ++ show v
- , testCase "onFinish detects normal exit" $ do
+ , testCase "onFinish detects abnormal exit" $ do
tv <- atomically $ newTVar Nothing
let
comp =
@@ -98,6 +104,34 @@ main = defaultMain $ testGroup "Tests"
Just (Left (fromException -> Just (ErrorCall "bah!"))) -> return ()
_ -> assertFailure $ "unexpected result: " ++ show v
+ , testCase "onUnexpectedFinish fires when thread is immortal" $ do
+ tv <- atomically $ newTVar Nothing
+ let
+ comp thread =
+ Immortal.onUnexpectedFinish thread
+ (\r -> atomically $ writeTVar tv (Just r))
+ (liftIO delay)
+ withImmortalThread comp $ \_ -> do
+ threadDelay (2*10^5)
+ v <- atomically $ readTVar tv
+ case v of
+ Just (Right ()) -> return ()
+ _ -> assertFailure $ "unexpected result: " ++ show v
+
+ , testCase "onUnexpectedFinish does not fire when thread is mortal" $ do
+ tv <- atomically $ newTVar Nothing
+ let
+ comp thread =
+ Immortal.onUnexpectedFinish thread
+ (\r -> atomically $ writeTVar tv (Just r))
+ (do Immortal.mortalize thread; liftIO delay)
+ withImmortalThread comp $ \_ -> do
+ threadDelay (2*10^5)
+ v <- atomically $ readTVar tv
+ case v of
+ Nothing -> return ()
+ _ -> assertFailure $ "unexpected result: " ++ show v
+
, testCase "mortalize allows thread to finish" $ do
tv <- atomically $ newTVar True
t <- Immortal.create $ const $ keepTrue tv
@@ -137,7 +171,7 @@ main = defaultMain $ testGroup "Tests"
-- tv2 checks that the exception was thrown
tv1 <- atomically $ newTVar False
tv2 <- atomically $ newTVar False
- t <- Immortal.create $ \thread -> do
+ _ <- Immortal.create $ \thread -> do
keepTrue tv1
Immortal.stop thread
atomically $ writeTVar tv1 True
@@ -149,6 +183,13 @@ main = defaultMain $ testGroup "Tests"
v2 <- atomically $ readTVar tv2
v1 @?= False
v2 @?= False
+
+ , testCase "wait is called after the thread is stopped" $ do
+ thread <- Immortal.create $ \_ -> threadDelay maxBound
+ _ <- forkIO $ threadDelay (10^4) >> Immortal.stop thread
+ result <- timeout (10^5) $ Immortal.wait thread
+
+ result @?= Just ()
]
keepTrue :: TVar Bool -> IO ()