shelly-extra 0.2.3.1 → 0.3

raw patch · 2 files changed

+33/−37 lines, 2 filesdep +asyncdep +mtldep ~shelly

Dependencies added: async, mtl

Dependency ranges changed: shelly

Files

• Shelly/Background.hs +29/−35
• shelly-extra.cabal +4/−2

@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, ExistentialQuantification #-} -- | A futures implementation that integrates with shelly --  -- > jobs 5 (\job -> background job (sleep 2) >> background job (sleep 1))@@ -8,14 +8,15 @@ -- Generally shell scripts contain a lot of quick commands, but when you have the occasional command that is noticeably long and independent of other commands, you can easily run it concurrently. module Shelly.Background (    -- * Running external commands asynchronously.-   jobs, background, getBgResult, BgResult+   jobs, background, killAllJobs ) where  import Shelly-import Control.Concurrent-import Control.Exception (finally, catch, throwIO, SomeException)-import Prelude hiding (catch) import qualified Control.Concurrent.MSemN as Sem+import Data.IORef+import Control.Concurrent.Async+import Control.Monad.Trans ( MonadIO )+import Control.Monad ( void )  -- | Create a 'BgJobManager' that has a 'limit' on the max number of background tasks. -- an invocation of jobs is independent of any others, and not tied to the Sh monad in any way.@@ -24,45 +25,38 @@ jobs limit action = do     unless (limit > 0) $ terror "expected limit to be > 0"     availableJobsSem <- liftIO $ Sem.new limit-    res <- action $ BgJobManager availableJobsSem+    res <- liftIO (newIORef []) >>= action . BgJobManager availableJobsSem     liftIO $ Sem.wait availableJobsSem limit     return res  -- | The manager tracks the number of jobs. Register your 'background' jobs with it.-newtype BgJobManager = BgJobManager (Sem.MSemN Int)---- | Type returned by tasks run asynchronously in the background.-newtype BgResult a = BgResult (MVar a)+data BgJobManager = BgJobManager (Sem.MSemN Int) (IORef [Async ()]) --- | Returns the promised result from a backgrounded task.  Blocks until--- the task completes.-getBgResult :: BgResult a -> Sh a-getBgResult (BgResult mvar) = liftIO $ takeMVar mvar+killAllJobs :: MonadIO m => BgJobManager -> m ()+killAllJobs man = getJobs man >>= mapM_ (liftIO . cancel)+  where+    getJobs :: MonadIO m => BgJobManager -> m [Async ()]+    getJobs (BgJobManager _ asyncs) = liftIO $ readIORef asyncs --- | Run the `Sh` task asynchronously in the background, returns--- the `BgResult a`, a promise immediately. Run "getBgResult" to wait for the result.+-- | Run the 'Sh' task asynchronously in the background,+-- immediately returns the 'Async' promise. -- The background task will inherit the current Sh context -- The 'BgJobManager' ensures the max jobs limit must be sufficient for the parent and all children.-background :: BgJobManager -> Sh a -> Sh (BgResult a)-background (BgJobManager manager) proc = do-  state <- get-  liftIO $ do+background :: BgJobManager -> Sh a -> Sh (Async a)+background (BgJobManager manager asyncs) proc = do     -- take up a spot     -- It is important to do this before forkIO:     -- It ensures that that jobs will block and the program won't exit before our jobs are done     -- On the other hand, a user might not expect 'jobs' to block-    Sem.wait manager 1-    mvar <- newEmptyMVar -- future result--    -- probably should use async package rather than manually handling exception stuff-    mainTid <- myThreadId-    _<- forkIO $ do-      result <--        finally (-            shelly (put state >> proc) `catch`-              (\(e::SomeException) -> throwTo mainTid e >> throwIO e)-          )-          (Sem.signal manager 1) -- open a spot back up-      putMVar mvar result-    return $ BgResult mvar-+    liftIO $ Sem.wait manager 1+    a <- asyncSh $ finally_sh proc (liftIO $ Sem.signal manager 1)+    liftIO $ do+        link a+        -- to make our types easier,+        -- we want [Async ()] for killall+        -- since killall doesn't care about return types+        -- perhaps there is a more elegant way to accomplish this?+        b <- async $ void $ wait a+        link2 a b+        atomicModifyIORef' asyncs (\as -> (b:as, ()))+        return a

@@ -1,6 +1,6 @@ Name:       shelly-extra -Version:     0.2.3.1+Version:     0.3 Synopsis:    shelly features that require extra dependencies  Description: A background job implementation for performing tasks in parallel.@@ -28,7 +28,9 @@ Library   Exposed-modules:     Shelly.Background -  Build-depends: base >= 4 && < 5, shelly >= 0.13, SafeSemaphore >= 0.7+  Build-depends: base >= 4 && < 5, shelly >= 1.4.3, SafeSemaphore >= 0.7+               , async+               , mtl                       >= 2    ghc-options: -Wall