summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRomanCheplyaka <>2018-04-16 08:18:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2018-04-16 08:18:00 (GMT)
commit5fe28b1d68a73d313d5f8b1f9a5ac1de3ba4b30b (patch)
tree9cdecfba39de8208d6caf665aaa1a26e09be2394
parent7f0a8aa499b487b0868b6569d6bd9d6de895e14b (diff)
version 0.3HEAD0.3master
-rw-r--r--CHANGELOG.md7
-rw-r--r--immortal.cabal17
-rw-r--r--src/Control/Immortal.hs54
-rw-r--r--tests/test.hs31
4 files changed, 34 insertions, 75 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 278673f..823d17d 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,6 +1,13 @@
CHANGES
=======
+Version 0.3
+-----------
+
+Replace monad-control with unliftio-core.
+As a result, immortal will no longer work with stateful monads like StateT,
+which is considered a feature.
+
Version 0.2.2.1
---------------
diff --git a/immortal.cabal b/immortal.cabal
index c1232e6..0b75302 100644
--- a/immortal.cabal
+++ b/immortal.cabal
@@ -1,8 +1,5 @@
--- Initial immortal.cabal generated by cabal init. For further
--- documentation, see http://haskell.org/cabal/users-guide/
-
name: immortal
-version: 0.2.2.1
+version: 0.3
synopsis: Spawn threads that never die (unless told to do so)
description: A small library to create threads that never die.
@@ -13,7 +10,7 @@ license: MIT
license-file: LICENSE
author: Roman Cheplyaka
maintainer: roma@ro-che.info
--- copyright:
+-- copyright:
category: Concurrency
build-type: Simple
extra-source-files:
@@ -27,13 +24,10 @@ source-repository head
library
exposed-modules: Control.Immortal
- -- other-modules:
build-depends:
base >=4.5 && <5,
- lifted-base >=0.2,
- transformers-base >=0.4,
- monad-control >=0.3,
- stm
+ stm,
+ unliftio-core >=0.1.1.0
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -Wall
@@ -51,8 +45,7 @@ test-suite test
base >= 4 && < 5
, tasty >= 0.8
, tasty-hunit
- , immortal
, transformers
+ , immortal
, stm
- , lifted-base
ghc-options: -Wall
diff --git a/src/Control/Immortal.hs b/src/Control/Immortal.hs
index 7ea89a9..9fbfa83 100644
--- a/src/Control/Immortal.hs
+++ b/src/Control/Immortal.hs
@@ -16,13 +16,12 @@ module Control.Immortal
, onUnexpectedFinish
) where
-import Control.Exception.Lifted
-import Control.Monad.Base
-import Control.Monad.Trans.Control
-import Control.Concurrent.Lifted
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Exception
+import Control.Monad.IO.Unlift
import Data.IORef
import GHC.Conc (labelThread)
-import Control.Concurrent.STM
-- | Immortal thread identifier (including its underlying 'ThreadId')
data Thread = Thread ThreadId (IORef Bool) (TVar Bool)
@@ -31,47 +30,38 @@ data Thread = Thread ThreadId (IORef Bool) (TVar Bool)
--
-- If the computation ever finishes (either normally or due to an exception),
-- it will be restarted (in the same thread).
---
--- The monadic «state» (captured by the 'MonadBaseControl' instance) will
--- be preserved if the computation terminates normally, and reset when the
--- exception is thrown, so be cautious when @m@ is stateful.
--- It is completely safe, however, to instantiate @m@ with
--- something like @ReaderT conf IO@ to pass configuration to the new
--- thread.
create
- :: MonadBaseControl IO m
+ :: MonadUnliftIO m
=> (Thread -> m ())
-> m Thread
-create a = uninterruptibleMask $ \restore -> do
+create a = withRunInIO $ \run -> uninterruptibleMask $ \restore -> do
-- Why use uninterruptibleMask instead of just mask? We're not using any
-- blocking operations so far, so there should be no difference. Still,
- -- 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
- finishedRef <- liftBase $ newTVarIO False
+ -- better be safe than sorry.
+ stopRef <- newIORef False
+ finishedRef <- newTVarIO False
let
go = do
-- construct a thread object from within the thread itself
pid <- myThreadId
let thread = Thread pid stopRef finishedRef
- handle (\(_ :: SomeException) -> return ()) (restore $ a thread)
+ handle (\(_ :: SomeException) -> return ()) (restore $ run $ a thread)
- stopNow <- liftBase $ readIORef stopRef
+ stopNow <- readIORef stopRef
if stopNow then
- liftBase $ atomically $ writeTVar finishedRef True
+ atomically $ writeTVar finishedRef True
else
go
- pid <- fork go
+ pid <- forkIO go
return $ Thread pid stopRef finishedRef
-- | Like 'create', but also apply the given label to the thread
-- (using 'labelThread').
-createWithLabel :: MonadBaseControl IO m => String -> (Thread -> m ()) -> m Thread
+createWithLabel :: MonadUnliftIO m => String -> (Thread -> m ()) -> m Thread
createWithLabel label a = do
thread <- create a
- liftBase $ labelThread (threadId thread) label
+ liftIO $ labelThread (threadId thread) label
return thread
-- | Make a thread mortal. Next time a mortal thread attempts to finish,
@@ -124,24 +114,24 @@ threadId (Thread pid _ _) = pid
--
-- This is nothing more than a simple wrapper around 'try'.
onFinish
- :: MonadBaseControl IO m
+ :: MonadUnliftIO m
=> (Either SomeException () -> m ())
-> m () -> m ()
-onFinish cb a = try a >>= cb
+onFinish cb a = withRunInIO $ \run -> try (run a) >>= run . 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
+ :: MonadUnliftIO m
=> Thread
-> (Either SomeException () -> m ())
-> m ()
-> m ()
-onUnexpectedFinish (Thread _ stopRef _) cb a = do
- r <- try a
- expected <- liftBase $ readIORef stopRef
+onUnexpectedFinish (Thread _ stopRef _) cb a = withRunInIO $ \run -> do
+ r <- try $ run a
+ expected <- readIORef stopRef
if expected
then return ()
- else cb r
+ else run $ cb r
diff --git a/tests/test.hs b/tests/test.hs
index c1e2d3e..bee12a3 100644
--- a/tests/test.hs
+++ b/tests/test.hs
@@ -7,7 +7,6 @@ import Control.Monad
import Control.Exception
import Control.Concurrent
import Control.Concurrent.STM
-import Control.Monad.Trans.State
import Control.Monad.IO.Class
import System.Timeout
@@ -54,28 +53,6 @@ main = defaultMain $ testGroup "Tests"
v <- atomically $ readTVar tv
assertBool "Thread did not stop" (not v)
- , testCase "state is preserved when there are no exceptions" $ do
- tv <- atomically $ newTVar 0
- pid <- flip evalStateT 0 $ Immortal.create $ const $ countToFive tv
- (do
- delay
- v <- atomically $ readTVar tv
- v @?= 5) `finally` Immortal.stop pid
-
- , testCase "state is reset when there are exceptions" $ do
- tv <- atomically $ newTVar 0
- let
- computation = do
- countToFive tv
- liftIO delay
- error "bah!"
- pid <- flip evalStateT 0 $ Immortal.create $ const computation
- (do
- threadDelay (5*10^5)
- v <- atomically $ readTVar tv
- v @?= 0)
- `finally` Immortal.stop pid
-
, testCase "onFinish detects normal exit" $ do
tv <- atomically $ newTVar Nothing
let
@@ -214,11 +191,3 @@ sleep = threadDelay (60 * 10^6) -- 1 min
delay :: IO ()
delay = threadDelay (10^5) -- 0.1 s
-
-countToFive :: TVar Int -> StateT Int IO ()
-countToFive tv = do
- n <- get
- liftIO $ atomically $ writeTVar tv n
- if n == 5
- then liftIO sleep
- else put $! n+1