polysemy-conc 0.8.0.1 → 0.9.0.0

raw patch · 10 files changed

+163/−97 lines, 10 filesdep +hedgehogdep +tasty-hedgehogdep ~basedep ~incipit-corePVP ok

version bump matches the API change (PVP)

Dependencies added: hedgehog, tasty-hedgehog

Dependency ranges changed: base, incipit-core

API changes (from Hackage documentation)

Files

• changelog.md +0/−42
• lib/Polysemy/Conc.hs +14/−1
• lib/Polysemy/Conc/Interpreter/Mask.hs +4/−4
• lib/Polysemy/Conc/Interpreter/Scoped.hs +1/−1
• lib/Polysemy/Conc/Sync.hs +90/−0
• polysemy-conc.cabal +21/−18
• readme.md +0/−8
• test/Main.hs +3/−1
• test/Polysemy/Conc/Test/EventsTest.hs +30/−21
• test/Polysemy/Conc/Test/MaskTest.hs +0/−1

@@ -1,42 +0,0 @@-# Unreleased--# 0.6.1.0--* Add `SyncRead`, a read-only variant of `Sync`.-* Change `withAsync` to use `finally` instead of `bracket`, since the latter causes `AsyncCancelled` to be masked,-  preventing the action from being cancelled unless it runs an interruptible action.--# 0.6.0.0--* Add `Resumable` support for `Scoped`.-* Add `Scoped` interpreters that allow the allocator to interpret additional effects used by the handler.--# 0.5.0.0--* Add `mask` effects.-* Add `Monitor`, an effect that repeatedly checks a condition and restarts a region when it is met.-* Add interpreter combinators for `Scoped`.-* Add a runner for the default `Conc` stack.--# 0.4.0.0--* Add `lock`, a combinator for protecting a region with a mutex.-* Add `scheduleAsync`, a combinator for running an action async that allows the handle to be used before the thread-  starts-* Change the default signal handler for `Interrupt` to `CatchInfo`, catching repeated signals.--# 0.3.0.0--* Change `Race.timeout` to take a `Sem` for the fallback instead of a pure value.-* Export all `Queue` constructors from `Polysemy.Conc.Queue`.-* Export all `Sync` constructors from `Polysemy.Conc.Sync`.-* Move all interpreters to `Polysemy.Conc.Interpreter`.--# 0.2.0.0-* Add `read*` constructors for `Sync`-* Add `subscribeWhile`, a combinator that consumes events until a condition is met-* Add looping combinators for `Queue`-* Add `retry`, a combinator that runs an action repeatedly until it returns `Right` or a timeout is hit-* Add `Scoped`, an effect for local resource scoping-* Add `withAsync`, a bracketing combinator that runs an async action while the main action runs-* Add `interpretAtomic`, a convenience interpreter for `AtomicState` that runs `runAtomicStateTVar`

@@ -92,6 +92,7 @@   mask,   uninterruptibleMask,   restore,+  Restoration,    -- * Interpreters   interpretMaskFinal,@@ -109,6 +110,12 @@   interpretScopedAs,   interpretScopedResumable,   interpretScopedResumableH,+  interpretScopedWith,+  interpretScopedWithH,+  interpretScopedWith_,+  interpretScopedResumableWith,+  interpretScopedResumableWithH,+  interpretScopedResumableWith_,    -- * Monitoring   Monitor,@@ -170,7 +177,7 @@ import Polysemy.Conc.Interpreter.Critical (interpretCritical, interpretCriticalNull) import Polysemy.Conc.Interpreter.Events (ChanConsumer, ChanEvents, EventChan, EventConsumer, interpretEventsChan) import Polysemy.Conc.Interpreter.Interrupt (interpretInterrupt, interpretInterruptNull, interpretInterruptOnce)-import Polysemy.Conc.Interpreter.Mask (interpretMaskFinal, interpretUninterruptibleMaskFinal)+import Polysemy.Conc.Interpreter.Mask (Restoration, interpretMaskFinal, interpretUninterruptibleMaskFinal) import Polysemy.Conc.Interpreter.Monitor (interpretMonitorPure, interpretMonitorRestart) import Polysemy.Conc.Interpreter.Queue.Pure (   interpretQueueListReadOnlyAtomic,@@ -187,6 +194,12 @@   interpretScopedH,   interpretScopedResumable,   interpretScopedResumableH,+  interpretScopedResumableWith,+  interpretScopedResumableWithH,+  interpretScopedResumableWith_,+  interpretScopedWith,+  interpretScopedWithH,+  interpretScopedWith_,   runScoped,   runScopedAs,   )

@@ -15,6 +15,7 @@   ) import Polysemy.Conc.Interpreter.Scoped (runScoped) +-- |Resource type for the scoped 'Mask' effect, wrapping the @restore@ callback passed in by 'Base.mask'. newtype Restoration =   Restoration { unRestoration :: ∀ a . IO a -> IO a } @@ -24,7 +25,7 @@   Sem r a mask f =   withWeavingToFinal @IO \ s lower _ ->-    Base.mask \ restore -> (lower (f (MaskResource (Restoration restore)) <$ s))+    Base.mask \ restore -> lower (f (MaskResource (Restoration restore)) <$ s)  uninterruptibleMask ::   Member (Final IO) r =>@@ -32,7 +33,7 @@   Sem r a uninterruptibleMask f =   withWeavingToFinal @IO \ s lower _ ->-    Base.uninterruptibleMask \ restore -> (lower (f (UninterruptibleMaskResource (Restoration restore)) <$ s))+    Base.uninterruptibleMask \ restore -> lower (f (UninterruptibleMaskResource (Restoration restore)) <$ s)  interpretRestoreMask ::   ∀ r .@@ -44,8 +45,7 @@     Restore ma -> do       let         restoreSem m =-          withStrategicToFinal do-            (restore <$> runS m)+          withStrategicToFinal (restore <$> runS m)       restoreSem (runTSimple ma)  -- |Interpret 'Mask' in 'IO'.

@@ -8,7 +8,7 @@ import Polysemy.Internal.Tactics (liftT, runTactics) import Polysemy.Internal.Union (Weaving (Weaving), decomp, hoist, injWeaving) import Polysemy.Resume (Stop, runStop, type (!!))-import Polysemy.Resume.Data.Resumable (Resumable (Resumable))+import Polysemy.Resume.Effect.Resumable (Resumable (Resumable))  import Polysemy.Conc.Effect.Scoped (Scoped (InScope, Run)) 

@@ -9,6 +9,7 @@ import qualified Polysemy.Time as Time import Polysemy.Time (Time, TimeUnit) +import Polysemy.Conc.Effect.Mask (Mask, mask, restore) import Polysemy.Conc.Effect.Scoped (scoped) import qualified Polysemy.Conc.Effect.Sync as Sync import Polysemy.Conc.Effect.Sync (@@ -78,6 +79,7 @@   Sem r a lock l ma =   finally (takeBlock @l *> ma) (putTry l)+{-# inline lock #-}  -- |Remove the content of the 'Sync' variable if it is present. clear ::@@ -86,3 +88,91 @@   Sem r () clear =   void (takeTry @a)+{-# inline clear #-}++-- |Modify a 'Sync' variable with async exceptions masked for the 'Sync' operations, but not the action.+-- Allows a value to be returned.+-- Equivalent to 'Control.Concurrent.MVar.modifyMVar'.+modify ::+  ∀ a b res r .+  Members [Sync a, Mask res, Resource] r =>+  (a -> Sem r (a, b)) ->+  Sem r b+modify m =+  mask @res do+    a <- takeBlock+    (a', b) <- onException (restore (raise (m a))) (putBlock a)+    b <$ putBlock a'+{-# inline modify #-}++-- |Modify a 'Sync' variable with async exceptions masked for the 'Sync' operations, but not the action.+-- Does not allow a value to be returned.+-- Equivalent to 'Control.Concurrent.MVar.modifyMVar_'.+modify_ ::+  ∀ a res r .+  Members [Sync a, Mask res, Resource] r =>+  (a -> Sem r a) ->+  Sem r ()+modify_ m =+  mask @res do+    a <- takeBlock+    a' <- onException (restore (raise (m a))) (putBlock a)+    putBlock a'+{-# inline modify_ #-}++-- |Modify a 'Sync' variable with async exceptions masked for the entire procedure.+-- Allows a value to be returned.+-- Equivalent to 'Control.Concurrent.MVar.modifyMVarMasked'.+modifyMasked ::+  ∀ a b res r .+  Members [Sync a, Mask res, Resource] r =>+  (a -> Sem r (a, b)) ->+  Sem r b+modifyMasked m =+  mask @res do+    a <- takeBlock+    (a', b) <- onException (raise (m a)) (putBlock a)+    b <$ putBlock a'+{-# inline modifyMasked #-}++-- |Modify a 'Sync' variable with async exceptions masked for the entire procedure.+-- Does not allow a value to be returned.+-- Equivalent to 'Control.Concurrent.MVar.modifyMVarMasked_'.+modifyMasked_ ::+  ∀ a res r .+  Members [Sync a, Mask res, Resource] r =>+  (a -> Sem r a) ->+  Sem r ()+modifyMasked_ m =+  mask @res do+    a <- takeBlock+    a' <- onException (raise (m a)) (putBlock a)+    putBlock a'+{-# inline modifyMasked_ #-}++-- |Run an action with the current value of the 'Sync' variable with async exceptions masked for the 'Sync' operations,+-- but not the action.+-- Equivalent to 'Control.Concurrent.MVar.withMVar'.+use ::+  ∀ a b res r .+  Members [Sync a, Mask res, Resource] r =>+  (a -> Sem r b) ->+  Sem r b+use m =+  mask @res do+    a <- takeBlock+    finally (restore (raise (m a))) (putBlock a)+{-# inline use #-}++-- |Run an action with the current value of the 'Sync' variable with async exceptions masked for the entire procedure.+-- Equivalent to 'Control.Concurrent.MVar.withMVarMasked'.+useMasked ::+  ∀ a b res r .+  Members [Sync a, Mask res, Resource] r =>+  (a -> Sem r b) ->+  Sem r b+useMasked m =+  mask @res do+    a <- takeBlock+    finally (raise (m a)) (putBlock a)+{-# inline useMasked #-}

@@ -5,21 +5,18 @@ -- see: https://github.com/sol/hpack  name:           polysemy-conc-version:        0.8.0.1-synopsis:       Polysemy Effects for Concurrency-description:    See <https://hackage.haskell.org/package/polysemy-conc/docs/Polysemy-Conc.html>+version:        0.9.0.0+synopsis:       Polysemy effects for concurrency+description:    See https://hackage.haskell.org/package/polysemy-conc/docs/Polysemy-Conc.html category:       Concurrency homepage:       https://github.com/tek/polysemy-conc#readme bug-reports:    https://github.com/tek/polysemy-conc/issues author:         Torsten Schmits-maintainer:     haskell@tryp.io-copyright:      2021 Torsten Schmits+maintainer:     hackage@tryp.io+copyright:      2022 Torsten Schmits license:        BSD-2-Clause-Patent license-file:   LICENSE build-type:     Simple-extra-source-files:-    readme.md-    changelog.md  source-repository head   type: git@@ -79,6 +76,7 @@       DeriveFoldable       DeriveFunctor       DeriveGeneric+      DeriveLift       DeriveTraversable       DerivingStrategies       DerivingVia@@ -111,6 +109,7 @@       RankNTypes       RecordWildCards       RecursiveDo+      RoleAnnotations       ScopedTypeVariables       StandaloneDeriving       TemplateHaskell@@ -123,12 +122,12 @@       UndecidableInstances       UnicodeSyntax       ViewPatterns-  ghc-options: -Wall -Wredundant-constraints -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Widentities+  ghc-options: -Wall -Wredundant-constraints -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Widentities -Wunused-packages   build-depends:       async-    , base ==4.*+    , base >=4.12 && <5     , containers-    , incipit-core >=0.2+    , incipit-core >=0.3     , polysemy >=1.6     , polysemy-resume >=0.3     , polysemy-time >=0.3@@ -139,8 +138,8 @@     , unix   mixins:       base hiding (Prelude)-  if impl(ghc >= 8.10)-    ghc-options: -Wunused-packages+    , incipit-core (IncipitCore as Prelude)+    , incipit-core hiding (IncipitCore)   default-language: Haskell2010  test-suite polysemy-conc-unit@@ -171,6 +170,7 @@       DeriveFoldable       DeriveFunctor       DeriveGeneric+      DeriveLift       DeriveTraversable       DerivingStrategies       DerivingVia@@ -203,6 +203,7 @@       RankNTypes       RecordWildCards       RecursiveDo+      RoleAnnotations       ScopedTypeVariables       StandaloneDeriving       TemplateHaskell@@ -215,11 +216,12 @@       UndecidableInstances       UnicodeSyntax       ViewPatterns-  ghc-options: -Wall -Wredundant-constraints -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Widentities -threaded -rtsopts -with-rtsopts=-N+  ghc-options: -Wall -Wredundant-constraints -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Widentities -Wunused-packages -threaded -rtsopts -with-rtsopts=-N   build-depends:       async-    , base ==4.*-    , incipit-core+    , base >=4.12 && <5+    , hedgehog+    , incipit-core >=0.3     , polysemy     , polysemy-conc     , polysemy-plugin@@ -228,11 +230,12 @@     , polysemy-time     , stm     , tasty+    , tasty-hedgehog     , time     , unagi-chan     , unix   mixins:       base hiding (Prelude)-  if impl(ghc >= 8.10)-    ghc-options: -Wunused-packages+    , incipit-core (IncipitCore as Prelude)+    , incipit-core hiding (IncipitCore)   default-language: Haskell2010

@@ -1,8 +0,0 @@-# About--This library provides [Polysemy] effects for using STM queues, MVars, signal handling and racing.--Please visit [Hackage] for documentation.--[Polysemy]: https://hackage.haskell.org/package/polysemy-[Hackage]: https://hackage.haskell.org/package/polysemy-conc/docs/Polysemy-Conc.html

@@ -1,5 +1,6 @@ module Main where +import Hedgehog (property, test, withTests) import Polysemy.Conc.Test.EventsTest (test_events) import Polysemy.Conc.Test.InterruptTest (test_interrupt) import Polysemy.Conc.Test.MaskTest (test_mask)@@ -16,6 +17,7 @@ import Polysemy.Conc.Test.SyncTest (test_sync) import Polysemy.Test (unitTest) import Test.Tasty (TestTree, defaultMain, testGroup)+import Test.Tasty.Hedgehog (testProperty)  tests :: TestTree tests =@@ -29,7 +31,7 @@       unitTest "TB block" test_queueBlockTB     ],     testGroup "events" [-      unitTest "events" test_events+      testProperty "events" (withTests 100 (property (test test_events)))     ],     testGroup "sync" [       unitTest "sync" test_sync

@@ -11,24 +11,33 @@  test_events :: UnitTest test_events =-  (runTestAuto . asyncToIOFinal) do-    interpretRace $ interpretSync @() $ interpretEventsChan @Int $ interpretEventsChan @Text do-      thread1 <- async do-        Events.subscribe @Int @(OutChan Int) do-          Events.consume @Int-      thread2 <- async do-        Events.subscribe @Int @(OutChan Int) do-          Events.consume @Int-      thread3 <- async do-        Events.subscribe @Text @(OutChan Text) do-          Sync.putBlock ()-          Events.consume @Text-      Sync.takeBlock @()-      Events.publish @Text @(OutChan Text) "test"-      Events.publish @Int @(OutChan Int) 1-      num1 <- await thread1-      num2 <- await thread2-      text1 <- await thread3-      assertJust @_ @IO 1 num1-      assertJust @_ @IO 1 num2-      assertJust @_ @IO "test" text1+  (runTestAuto . asyncToIOFinal) $+  interpretRace $+  interpretSync @(Proxy 1) $+  interpretSync @(Proxy 2) $+  interpretSync @(Proxy 3) $+  interpretEventsChan @Int $+  interpretEventsChan @Text do+    thread1 <- async do+      Events.subscribe @Int @(OutChan Int) do+        Sync.putBlock (Proxy @1)+        Events.consume @Int+    thread2 <- async do+      Events.subscribe @Int @(OutChan Int) do+        Sync.putBlock (Proxy @2)+        Events.consume @Int+    thread3 <- async do+      Events.subscribe @Text @(OutChan Text) do+        Sync.putBlock (Proxy @3)+        Events.consume @Text+    Sync.takeBlock @(Proxy 1)+    Sync.takeBlock @(Proxy 2)+    Sync.takeBlock @(Proxy 3)+    Events.publish @Text @(OutChan Text) "test"+    Events.publish @Int @(OutChan Int) 1+    num1 <- await thread1+    num2 <- await thread2+    text1 <- await thread3+    assertJust @_ @IO 1 num1+    assertJust @_ @IO 1 num2+    assertJust @_ @IO "test" text1

@@ -5,7 +5,6 @@ import qualified Control.Concurrent.Async as Base import Control.Concurrent.Async (asyncThreadId) import Control.Exception (throwTo)-import GHC.Stack (withFrozenCallStack) import Polysemy.Test (Hedgehog, UnitTest, assertEq, evalLeft, runTestAuto) import qualified Polysemy.Time as Time import Polysemy.Time (MilliSeconds (MilliSeconds), interpretTimeGhc)