monad-schedule 0.2.0.2 → 1.6
raw patch · 3 files changed
+46/−54 lines, 3 filesdep ~basedep ~time-domainsetup-changed
Dependency ranges changed: base, time-domain
Files
- Setup.hs +0/−2
- monad-schedule.cabal +33/−40
- src/Control/Monad/Schedule/FreeAsync.hs +13/−12
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
monad-schedule.cabal view
@@ -1,11 +1,11 @@-cabal-version: 2.4-name: monad-schedule-version: 0.2.0.2-license: MIT-license-file: LICENSE-author: Manuel Bärenz-maintainer: programming@manuelbaerenz.de-synopsis: A new, simple, composable concurrency abstraction.+cabal-version: 2.4+name: monad-schedule+version: 1.6+license: MIT+license-file: LICENSE+author: Manuel Bärenz+maintainer: programming@manuelbaerenz.de+synopsis: A new, simple, composable concurrency abstraction. description: A monad @m@ is said to allow scheduling if you can pass a number of actions @m a@ to it, and those can be executed at the same time concurrently.@@ -14,36 +14,30 @@ Other actions are still running, and for these you will receive continuations of type @m a@, which you can further run or schedule to completion as you like. -category: Concurrency+category: Concurrency extra-doc-files: CHANGELOG.md -tested-with:- GHC == 9.2.5- GHC == 9.4.5- GHC == 9.6.2- GHC == 9.8.1- GHC == 9.10.1- source-repository head- type: git- location: https://github.com/turion/monad-schedule+ type: git+ location: https://github.com/turion/rhine common deps build-depends:- , base >=4.16.0 && <4.21.0- , base-compat >=0.13 && < 0.15- , free >=5.1 && < 5.3- , stm ^>=2.5- , time-domain ^>=0.1- , transformers >=0.5 && < 0.7- , operational ^>=0.2.4+ base >=4.16.0 && <4.22,+ base-compat >=0.13 && <0.15,+ free >=5.1 && <5.3,+ operational ^>=0.2.4,+ stm ^>=2.5,+ time-domain ^>=1.6,+ transformers >=0.5 && <0.7,+ if flag(dev) ghc-options: -Werror ghc-options: -W library- import: deps+ import: deps exposed-modules: Control.Monad.Schedule.Class Control.Monad.Schedule.FreeAsync@@ -53,31 +47,30 @@ Control.Monad.Schedule.Trans Control.Monad.Schedule.Yield - hs-source-dirs: src+ hs-source-dirs: src default-language: Haskell2010 test-suite test- import: deps- type: exitcode-stdio-1.0- main-is: Main.hs+ import: deps+ type: exitcode-stdio-1.0+ main-is: Main.hs other-modules: FreeAsync Trans Yield - hs-source-dirs: test+ hs-source-dirs: test build-depends:- , HUnit ^>=1.6- , monad-schedule- , QuickCheck >=2.14 && <2.16- , test-framework ^>=0.8- , test-framework-hunit ^>=0.3- , test-framework-quickcheck2 ^>=0.3- , generic-arbitrary ^>=1.0- , time >=1.9+ HUnit ^>=1.6,+ QuickCheck >=2.14 && <2.16,+ generic-arbitrary ^>=1.0,+ monad-schedule,+ test-framework ^>=0.8,+ test-framework-hunit ^>=0.3,+ test-framework-quickcheck2 ^>=0.3,+ time >=1.9, default-language: Haskell2010- ghc-options: -threaded flag dev
src/Control/Monad/Schedule/FreeAsync.hs view
@@ -90,7 +90,8 @@ asyncMVar :: MVar a -> FreeAsyncT m a asyncMVar = FreeAsyncT . singleton -data MVarCont m a = forall b.+data MVarCont m a+ = forall b. MVarCont { mvar :: MVar b , cont :: b -> ProgramT MVar m a@@ -112,7 +113,7 @@ -- Have some of them finished? case partitionNonEmpty $ viewToEither <$> views of -- All have finished- Left (as, []) -> return (as, [])+ Left (as, []) -> pure (as, []) -- Some have finished, some are waiting for MVars Left (as, cont : conts) -> do -- Peek at the MVars@@ -126,11 +127,11 @@ -- Have some of them returned now? case partitionNonEmpty $ viewToEither <$> views of -- Yes. Return those as well- Left (as', conts') -> return (as <> as', embedMVarCont <$> (conts ++ conts'))+ Left (as', conts') -> pure (as <> as', embedMVarCont <$> (conts <> conts')) -- No, they are blocked on other MVars now- Right conts' -> return (as, embedMVarCont <$> toList conts' <> conts)+ Right conts' -> pure (as, embedMVarCont <$> toList conts' <> conts) -- All MVars are still blocked- Right conts -> return (as, embedMVarCont <$> toList conts)+ Right conts -> pure (as, embedMVarCont <$> toList conts) -- All actions are waiting for MVars Right conts -> do -- Retry until some MVars get unblocked@@ -151,25 +152,25 @@ tryProgress :: (MonadIO m) => MVarCont m a -> m (Either (ProgramT MVar m a) (MVarCont m a)) tryProgress mvarcont@MVarCont {mvar, cont} = do result <- liftIO $ tryTakeMVar mvar- return $ maybe (Right mvarcont) (Left . cont) result+ pure $ maybe (Right mvarcont) (Left . cont) result tryProgresses :: (MonadIO m) => NonEmpty (MVarCont m a) -> m (Either (NonEmpty (ProgramT MVar m a), [MVarCont m a]) (NonEmpty (MVarCont m a))) tryProgresses conts = do result <- partitionNonEmpty <$> mapM tryProgress conts case result of- Left (progressed, []) -> return $ Left (progressed, [])+ Left (progressed, []) -> pure $ Left (progressed, []) Left (progressed, cont : conts) -> do inner <- tryProgresses $ cont :| conts case inner of- Left (progressed', finalConts) -> return $ Left (progressed <> progressed', finalConts)- Right finalConts -> return $ Left (progressed, toList finalConts)- Right conts -> return $ Right conts+ Left (progressed', finalConts) -> pure $ Left (progressed <> progressed', finalConts)+ Right finalConts -> pure $ Left (progressed, toList finalConts)+ Right conts -> pure $ Right conts retryProgresses :: (MonadIO m) => NonEmpty (MVarCont m a) -> m (NonEmpty (ProgramT MVar m a), [MVarCont m a]) retryProgresses conts = do result <- tryProgresses conts case result of- Left progress -> return progress+ Left progress -> pure progress Right _ -> do liftIO $ yield >> threadDelay 100 retryProgresses conts@@ -231,5 +232,5 @@ schedule = fmap getConcurrentlyT >>> schedule- >>> fmap (second (map ConcurrentlyT))+ >>> fmap (second (fmap ConcurrentlyT)) >>> ConcurrentlyT