diff --git a/CHANGELOG.md b/CHANGELOG.md --- 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 --- 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-file: LICENSE author: Roman Cheplyaka maintainer: roma@ro-che.info --- copyright: +-- copyright: category: Concurrency build-type: Simple extra-source-files: @@ -27,13 +24,10 @@ 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 @@ 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 --- a/src/Control/Immortal.hs +++ b/src/Control/Immortal.hs @@ -16,13 +16,12 @@ , 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 @@ -- -- 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 @@ -- -- 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 --- a/tests/test.hs +++ b/tests/test.hs @@ -7,7 +7,6 @@ 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 @@ 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 @@ 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