polysemy-conc 0.9.0.0 → 0.10.0.0

raw patch · 34 files changed

+1861/−435 lines, 34 filesdep ~polysemy-resumePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: polysemy-resume

API changes (from Hackage documentation)

Files

• changelog.md +68/−0
• lib/Polysemy/Conc.hs +121/−21
• lib/Polysemy/Conc/Async.hs +41/−5
• lib/Polysemy/Conc/Effect/Events.hs +8/−13
• lib/Polysemy/Conc/Effect/Gate.hs +28/−0
• lib/Polysemy/Conc/Effect/Lock.hs +47/−0
• lib/Polysemy/Conc/Effect/Mask.hs +14/−18
• lib/Polysemy/Conc/Effect/Monitor.hs +13/−18
• lib/Polysemy/Conc/Effect/Race.hs +1/−1
• lib/Polysemy/Conc/Effect/Scoped.hs +140/−19
• lib/Polysemy/Conc/Effect/Semaphore.hs +24/−0
• lib/Polysemy/Conc/Effect/Sync.hs +5/−8
• lib/Polysemy/Conc/Events.hs +170/−9
• lib/Polysemy/Conc/Gate.hs +10/−0
• lib/Polysemy/Conc/Interpreter/Events.hs +11/−23
• lib/Polysemy/Conc/Interpreter/Gate.hs +34/−0
• lib/Polysemy/Conc/Interpreter/Lock.hs +115/−0
• lib/Polysemy/Conc/Interpreter/Mask.hs +24/−20
• lib/Polysemy/Conc/Interpreter/Monitor.hs +10/−16
• lib/Polysemy/Conc/Interpreter/Scoped.hs +640/−150
• lib/Polysemy/Conc/Interpreter/Semaphore.hs +55/−0
• lib/Polysemy/Conc/Interpreter/Stack.hs +7/−3
• lib/Polysemy/Conc/Interpreter/Sync.hs +6/−6
• lib/Polysemy/Conc/Queue.hs +12/−2
• lib/Polysemy/Conc/Race.hs +16/−4
• lib/Polysemy/Conc/Semaphore.hs +11/−0
• lib/Polysemy/Conc/Sync.hs +24/−37
• polysemy-conc.cabal +13/−2
• readme.md +8/−0
• test/Main.hs +7/−7
• test/Polysemy/Conc/Test/EventsTest.hs +5/−6
• test/Polysemy/Conc/Test/LockTest.hs +51/−20
• test/Polysemy/Conc/Test/ScopedTest.hs +101/−26
• test/Polysemy/Conc/Test/SyncTest.hs +21/−1

@@ -0,0 +1,68 @@+# 0.10.0.0++## Breaking++* Add a parameter to `Scoped` that allows arbitrary data to be passed to the scoped interpreter via `scoped`.+* Remove the `resource` parameter from `Scoped`.++## Other++* Add `Queue.tryReadMaybe`, a variant of `readMaybe` that does not wait.+* Add variants of the combined `Scoped` interpreters in which the `Resumable` is inside the scope.+* Add `Semaphore`, abstracting `QSem` or `TSem`.+* Add `timeoutStop`, a variant of `timeout` that calls `Polysemy.Resume.stop`.+* Add `Lock`, a mutex effect.+* Add `withAsyncGated`, a variant of `withAsync` that requires the async action to signal the sync action to start.+* Add `Gate`, a synchronization point effect.+* Add variants of `subscribeWhile` and `subscribeLoop` that use `Gate` for synchronization and run in a new thread.+* Add pure interpreters for `Mask`.+* Add more variants of `subscribeLoop` that return matching elements.+* Add `Gates` to `ConcStack`.+* Add `rescope`, a reinterpreter for `Scoped` that may extend the scope parameters.++# 0.9.0.0++* Add the missing `MVar` combinators for `Sync` that bracket an action with `mask`.+* Export `Restoration`.+* Add `interpretProcessOutputLeft/Right`.++# 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`

@@ -31,11 +31,36 @@   interpretSync,   interpretSyncAs,   withSync,-  lock,   interpretScopedSync,   interpretScopedSyncAs,   syncRead, +  -- * Lock+  Lock,+  lock,+  lockOr,+  lockOrSkip,+  lockOrSkip_,++  -- ** Interpreters+  interpretLockReentrant,+  interpretLockPermissive,++  -- * Semaphores+  Semaphore,++  -- ** Interpreters+  interpretSemaphoreQ,+  interpretSemaphoreT,++  -- * Gate+  Gate,+  Gates,++  -- ** Interpreters+  interpretGates,+  interpretGate,+   -- * Racing   -- $race   Race,@@ -47,6 +72,7 @@   timeoutAs_,   timeoutU,   timeoutMaybe,+  timeoutStop,   retrying,   retryingWithError, @@ -68,13 +94,23 @@   publish,   consume,   subscribe,+  subscribeGated,+  subscribeAsync,   subscribeWhile,+  subscribeWhileGated,+  subscribeWhileAsync,   subscribeLoop,-  EventResource,-  EventChan,-  ChanEvents,+  subscribeLoopGated,+  subscribeLoopAsync,+  subscribeFind,+  subscribeFirstJust,+  subscribeElem,+  consumeWhile,+  consumeLoop,+  consumeFind,+  consumeFirstJust,+  consumeElem,   EventConsumer,-  ChanConsumer,    -- ** Interpreters   interpretEventsChan,@@ -97,25 +133,44 @@   -- * Interpreters   interpretMaskFinal,   interpretUninterruptibleMaskFinal,+  interpretMaskPure,+  interpretUninterruptibleMaskPure,    -- * Scoped Effects   Scoped,+  Scoped_,   scoped,+  scoped_,+  rescope,    -- ** Interpreters-  runScoped,-  runScopedAs,   interpretScoped,   interpretScopedH,+  interpretScopedH',   interpretScopedAs,-  interpretScopedResumable,-  interpretScopedResumableH,   interpretScopedWith,   interpretScopedWithH,   interpretScopedWith_,+  runScoped,+  runScopedAs,+  interpretScopedResumable,+  interpretScopedResumableH,+  interpretScopedResumable_,   interpretScopedResumableWith,   interpretScopedResumableWithH,   interpretScopedResumableWith_,+  interpretResumableScoped,+  interpretResumableScopedH,+  interpretResumableScoped_,+  interpretResumableScopedWith,+  interpretResumableScopedWithH,+  interpretResumableScopedWith_,+  interpretScopedR,+  interpretScopedRH,+  interpretScopedR_,+  interpretScopedRWith,+  interpretScopedRWithH,+  interpretScopedRWith_,    -- * Monitoring   Monitor,@@ -124,7 +179,6 @@   restart,   Restart,   RestartingMonitor,-  MonitorResource (MonitorResource),   ScopedMonitor,    -- ** Interpreters@@ -143,6 +197,8 @@   withAsync_,   scheduleAsync,   scheduleAsyncIO,+  withAsyncGated,+  withAsyncGated_, ) where  import Polysemy.Conc.Async (@@ -150,17 +206,27 @@   scheduleAsyncIO,   withAsync,   withAsyncBlock,+  withAsyncGated,+  withAsyncGated_,   withAsync_,   ) import Polysemy.Conc.AtomicState (interpretAtomic) import Polysemy.Conc.Data.QueueResult (QueueResult) import Polysemy.Conc.Effect.Critical (Critical)-import Polysemy.Conc.Effect.Events (Consume, EventResource, Events, consume, publish, subscribe)+import Polysemy.Conc.Effect.Events (Consume, Events, consume, publish, subscribe)+import Polysemy.Conc.Effect.Gate (Gate, Gates) import Polysemy.Conc.Effect.Interrupt (Interrupt)-import Polysemy.Conc.Effect.Mask (Mask, UninterruptibleMask, mask, restore, uninterruptibleMask)+import Polysemy.Conc.Effect.Lock (Lock, lock, lockOr, lockOrSkip, lockOrSkip_)+import Polysemy.Conc.Effect.Mask (+  Mask,+  Restoration,+  UninterruptibleMask,+  mask,+  restore,+  uninterruptibleMask,+  ) import Polysemy.Conc.Effect.Monitor (   Monitor,-  MonitorResource (MonitorResource),   Restart,   RestartingMonitor,   ScopedMonitor,@@ -170,14 +236,34 @@   ) import Polysemy.Conc.Effect.Queue (Queue) import Polysemy.Conc.Effect.Race (Race, race, timeout)-import Polysemy.Conc.Effect.Scoped (Scoped, scoped)+import Polysemy.Conc.Effect.Scoped (Scoped, Scoped_, scoped, scoped_, rescope)+import Polysemy.Conc.Effect.Semaphore (Semaphore) import Polysemy.Conc.Effect.Sync (ScopedSync, Sync) import Polysemy.Conc.Effect.SyncRead (SyncRead)-import Polysemy.Conc.Events (subscribeLoop, subscribeWhile)+import Polysemy.Conc.Events (+  consumeElem,+  consumeFind,+  consumeFirstJust,+  consumeLoop,+  consumeWhile,+  subscribeAsync,+  subscribeElem,+  subscribeFind,+  subscribeFirstJust,+  subscribeGated,+  subscribeLoop,+  subscribeLoopAsync,+  subscribeLoopGated,+  subscribeWhile,+  subscribeWhileAsync,+  subscribeWhileGated,+  ) import Polysemy.Conc.Interpreter.Critical (interpretCritical, interpretCriticalNull)-import Polysemy.Conc.Interpreter.Events (ChanConsumer, ChanEvents, EventChan, EventConsumer, interpretEventsChan)+import Polysemy.Conc.Interpreter.Events (EventConsumer, interpretEventsChan)+import Polysemy.Conc.Interpreter.Gate (interpretGate, interpretGates) import Polysemy.Conc.Interpreter.Interrupt (interpretInterrupt, interpretInterruptNull, interpretInterruptOnce)-import Polysemy.Conc.Interpreter.Mask (Restoration, interpretMaskFinal, interpretUninterruptibleMaskFinal)+import Polysemy.Conc.Interpreter.Lock (interpretLockPermissive, interpretLockReentrant)+import Polysemy.Conc.Interpreter.Mask (interpretMaskFinal, interpretMaskPure, interpretUninterruptibleMaskFinal, interpretUninterruptibleMaskPure) import Polysemy.Conc.Interpreter.Monitor (interpretMonitorPure, interpretMonitorRestart) import Polysemy.Conc.Interpreter.Queue.Pure (   interpretQueueListReadOnlyAtomic,@@ -189,29 +275,43 @@ import Polysemy.Conc.Interpreter.Queue.TBM (interpretQueueTBM) import Polysemy.Conc.Interpreter.Race (interpretRace) import Polysemy.Conc.Interpreter.Scoped (+  interpretResumableScoped,+  interpretResumableScopedH,+  interpretResumableScopedWith,+  interpretResumableScopedWithH,+  interpretResumableScopedWith_,+  interpretResumableScoped_,   interpretScoped,   interpretScopedAs,   interpretScopedH,+  interpretScopedR,+  interpretScopedRH,+  interpretScopedRWith,+  interpretScopedRWithH,+  interpretScopedRWith_,+  interpretScopedR_,   interpretScopedResumable,   interpretScopedResumableH,   interpretScopedResumableWith,   interpretScopedResumableWithH,   interpretScopedResumableWith_,+  interpretScopedResumable_,   interpretScopedWith,   interpretScopedWithH,   interpretScopedWith_,   runScoped,-  runScopedAs,+  runScopedAs, interpretScopedH',   )+import Polysemy.Conc.Interpreter.Semaphore (interpretSemaphoreQ, interpretSemaphoreT) import Polysemy.Conc.Interpreter.Stack (ConcStack, runConc) import Polysemy.Conc.Interpreter.Sync (interpretScopedSync, interpretScopedSyncAs, interpretSync, interpretSyncAs) import Polysemy.Conc.Interpreter.SyncRead (syncRead) import Polysemy.Conc.Monitor (ClockSkewConfig (ClockSkewConfig), clockSkewConfig, monitorClockSkew) import Polysemy.Conc.Queue (loop, loopOr) import Polysemy.Conc.Queue.Result (resultToMaybe)-import Polysemy.Conc.Race (race_, timeoutAs, timeoutAs_, timeoutMaybe, timeoutU, timeout_)+import Polysemy.Conc.Race (race_, timeoutAs, timeoutAs_, timeoutMaybe, timeoutStop, timeoutU, timeout_) import Polysemy.Conc.Retry (retrying, retryingWithError)-import Polysemy.Conc.Sync (lock, withSync)+import Polysemy.Conc.Sync (withSync)  -- $intro -- This library provides an assortment of tools for concurrency-related tasks:@@ -255,7 +355,7 @@ -- Usage is straightforward: -- -- @--- prog :: Member (Mask resource) r+-- prog :: Member Mask r -- prog = --  mask do --    doMaskedThing

@@ -4,7 +4,9 @@ import qualified Control.Concurrent.Async as Base import Polysemy.Time (MilliSeconds (MilliSeconds), TimeUnit) +import Polysemy.Conc.Effect.Gate (Gate, gate, withGate) import Polysemy.Conc.Effect.Race (Race)+import Polysemy.Conc.Effect.Scoped (Scoped_) import qualified Polysemy.Conc.Effect.Sync as Sync import Polysemy.Conc.Effect.Sync (ScopedSync, Sync) import Polysemy.Conc.Interpreter.Sync (interpretSync)@@ -25,7 +27,7 @@   finally (use handle) (cancel handle)  -- |Run the first action asynchronously while the second action executes, then cancel the first action.--- Passes the handle into the action to allow it to await its result.+-- Passes the handle into the sync action to allow it to await the async action's result. -- -- When cancelling, this variant will wait for the specified interval for the thread to be gone. withAsyncWait ::@@ -40,7 +42,7 @@   finally (use handle) (Race.timeoutU interval (cancel handle))  -- |Run the first action asynchronously while the second action executes, then cancel the first action.--- Passes the handle into the action to allow it to await its result.+-- Passes the handle into the sync action to allow it to await the async action's result. -- -- When cancelling, this variant will wait for 500ms for the thread to be gone. withAsync ::@@ -80,13 +82,13 @@ --   start -- now makeRequest is executed -- @ scheduleAsync ::-  ∀ res b r a .-  Members [ScopedSync res (), Async, Race] r =>+  ∀ b r a .+  Members [ScopedSync (), Async, Race] r =>   Sem r b ->   (Base.Async (Maybe b) -> Sem (Sync () : r) () -> Sem (Sync () : r) a) ->   Sem r a scheduleAsync mb f =-  withSync @() @res do+  withSync @() do     h <- async do       Sync.block @()       raise mb@@ -105,3 +107,37 @@       Sync.block @()       raise mb     f h (Sync.putBlock ())++-- |Run the first action asynchronously while the second action executes, then cancel the first action.+--+-- The second action will only start when the first action calls 'Polysemy.Conc.Gate.signal'.+--+-- Passes the handle into the sync action to allow it to await the async action's result.+--+-- This can be used to ensure that the async action has acquired its resources before the main action starts.+withAsyncGated ::+  ∀ b r a .+  Members [Scoped_ Gate, Resource, Race, Async] r =>+  Sem (Gate : r) b ->+  (Base.Async (Maybe b) -> Sem r a) ->+  Sem r a+withAsyncGated mb use =+  withGate $ withAsync mb \ h -> do+    gate+    raise (use h)++-- |Run the first action asynchronously while the second action executes, then cancel the first action.+--+-- The second action will only start when the first action calls 'Polysemy.Conc.Gate.signal'.+--+-- This can be used to ensure that the async action has acquired its resources before the main action starts.+withAsyncGated_ ::+  ∀ b r a .+  Members [Scoped_ Gate, Resource, Race, Async] r =>+  Sem (Gate : r) b ->+  Sem r a ->+  Sem r a+withAsyncGated_ mb use =+  withGate $ withAsync_ mb do+    gate+    raise use

@@ -3,23 +3,18 @@ -- |Description: Events/Consume Effects, Internal module Polysemy.Conc.Effect.Events where -import Polysemy.Conc.Effect.Scoped (Scoped, scoped)---- |Marker for the 'Scoped' resource for 'Events'.-newtype EventResource resource =-  EventResource { unEventToken :: resource }-  deriving stock (Eq, Show, Generic)+import Polysemy.Conc.Effect.Scoped (Scoped_, scoped_)  -- |An event publisher that can be consumed from multiple threads.-data Events (resource :: Type) (e :: Type) :: Effect where-  Publish :: e -> Events resource e m ()+data Events (e :: Type) :: Effect where+  Publish :: e -> Events e m ()  makeSem_ ''Events  -- |Publish one event. publish ::-  ∀ e resource r .-  Member (Events resource e) r =>+  ∀ e r .+  Member (Events e) r =>   e ->   Sem r () @@ -38,8 +33,8 @@ -- |Create a new scope for 'Events', causing the nested program to get its own copy of the event stream. -- To be used with 'Polysemy.Conc.interpretEventsChan'. subscribe ::-  ∀ e resource r .-  Member (Scoped (EventResource resource) (Consume e)) r =>+  ∀ e r .+  Member (Scoped_ (Consume e)) r =>   InterpreterFor (Consume e) r subscribe =-  scoped @(EventResource resource)+  scoped_

@@ -0,0 +1,28 @@+{-# options_haddock prune #-}++-- |Description: Gate effect, Internal+module Polysemy.Conc.Effect.Gate where++import Polysemy.Conc.Effect.Scoped (Scoped_, scoped_)++-- |A single-use synchronization point that blocks all consumers who called 'gate' until 'signal' is called.+--+-- The constructors are exported from [Polysemy.Conc.Gate]("Polysemy.Conc.Gate").+data Gate :: Effect where+  Signal :: Gate m ()+  Gate :: Gate m ()++makeSem ''Gate++-- |Convenience alias for scoped 'Gate'.+type Gates =+  Scoped_ Gate++-- |Run an action with a locally scoped 'Gate' effect.+--+-- This avoids a dependency on @'Embed' 'IO'@ in application logic while still allowing the effect to be scoped.+withGate ::+  Member (Scoped_ Gate) r =>+  InterpreterFor Gate r+withGate =+  scoped_

@@ -0,0 +1,47 @@+-- |Lock effect, Internal+module Polysemy.Conc.Effect.Lock where++-- |An exclusive lock or mutex, protecting a region from concurrent access.+data Lock :: Effect where+  -- |Run an action if the lock is available, block otherwise.+  Lock :: m a -> Lock m a+  -- |Run the second action if the lock is available, or the first action otherwise.+  LockOr :: m a -> m a -> Lock m a++makeSem_ ''Lock++-- |Run an action if the lock is available, block otherwise.+lock ::+  ∀ r a .+  Member Lock r =>+  Sem r a ->+  Sem r a++-- |Run an action if the lock is available, block otherwise.+lockOr ::+  ∀ r a .+  Member Lock r =>+  Sem r a ->+  Sem r a ->+  Sem r a++-- |Run an action if the lock is available, skip and return 'Nothing' otherwise.+lockOrSkip ::+  ∀ r a .+  Member Lock r =>+  Sem r a ->+  Sem r (Maybe a)+lockOrSkip ma =+  lockOr (pure Nothing) (Just <$> ma)+{-# inline lockOrSkip #-}++-- |Run an action if the lock is available, skip otherwise.+-- Return @()@.+lockOrSkip_ ::+  ∀ r a .+  Member Lock r =>+  Sem r a ->+  Sem r ()+lockOrSkip_ ma =+  lockOr unit (void ma)+{-# inline lockOrSkip_ #-}

@@ -3,7 +3,7 @@ -- |Description: Mask Effect, Internal module Polysemy.Conc.Effect.Mask where -import Polysemy.Conc.Effect.Scoped (Scoped, scoped)+import Polysemy.Conc.Effect.Scoped (Scoped_, scoped_)  -- |Part of an effect abstracting 'Control.Exception.mask'. data RestoreMask :: Effect where@@ -19,34 +19,30 @@   Sem r a ->   Sem r a -newtype MaskResource resource =-  MaskResource { unMaskResource :: resource }--newtype UninterruptibleMaskResource resource =-  UninterruptibleMaskResource { unUninterruptibleMaskResource :: resource }+-- |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 }  -- |The scoped masking effect.-type Mask resource =-  Scoped (MaskResource resource) RestoreMask+type Mask =+  Scoped_ RestoreMask  -- |The scoped uninterruptible masking effect.-type UninterruptibleMask resource =-  Scoped (UninterruptibleMaskResource resource) RestoreMask+type UninterruptibleMask =+  Scoped_ RestoreMask  -- |Mark a region as masked.--- Uses the 'Scoped' pattern.+-- Uses the 'Scoped_' pattern. mask ::-  ∀ resource r .-  Member (Mask resource) r =>+  Member Mask r =>   InterpreterFor RestoreMask r mask =-  scoped @(MaskResource resource)+  scoped_  -- |Mark a region as uninterruptibly masked.--- Uses the 'Scoped' pattern.+-- Uses the 'Scoped_' pattern. uninterruptibleMask ::-  ∀ resource r .-  Member (UninterruptibleMask resource) r =>+  Member UninterruptibleMask r =>   InterpreterFor RestoreMask r uninterruptibleMask =-  scoped @(UninterruptibleMaskResource resource)+  scoped_

@@ -5,7 +5,7 @@  import Polysemy.Time (NanoSeconds) -import Polysemy.Conc.Effect.Scoped (Scoped, scoped)+import Polysemy.Conc.Effect.Scoped (Scoped_, scoped_)  -- |Marker type for the restarting action for 'Monitor'. data Restart =@@ -15,7 +15,7 @@ -- |Mark a region as being subject to intervention by a monitoring program. -- This can mean that a thread is repeatedly checking a condition and cancelling this region when it is unmet. -- A use case could be checking whether a remote service is available, or whether the system was suspended and resumed.--- This should be used in a 'Scoped' context, like 'withMonitor'.+-- This should be used in a 'Scoped_' context, like 'withMonitor'. data Monitor (action :: Type) :: Effect where   Monitor :: m a -> Monitor action m a @@ -28,19 +28,15 @@   Sem r a ->   Sem r a --- |Marker type for a 'Scoped' 'Monitor'.-newtype MonitorResource a =-  MonitorResource { unMonitorResource :: a }---- |Convenience alias for a 'Scoped' 'Monitor'.-type ScopedMonitor (resource :: Type) (action :: Type) =-  Scoped (MonitorResource resource) (Monitor action)+-- |Convenience alias for a 'Scoped_' 'Monitor'.+type ScopedMonitor (action :: Type) =+  Scoped_ (Monitor action)  -- |'Monitor' specialized to the 'Restart' action.-type RestartingMonitor (resource :: Type) =-  ScopedMonitor resource Restart+type RestartingMonitor =+  ScopedMonitor Restart --- |Resources for a 'Scoped' 'Monitor'.+-- |Resources for a 'Scoped_' 'Monitor'. data MonitorCheck r =   MonitorCheck {     interval :: NanoSeconds,@@ -49,16 +45,15 @@  -- |Start a region that can contain monitor-intervention regions. withMonitor ::-  ∀ resource action r .-  Member (ScopedMonitor resource action) r =>+  ∀ action r .+  Member (ScopedMonitor action) r =>   InterpreterFor (Monitor action) r withMonitor =-  scoped @(MonitorResource resource)+  scoped_  -- |Variant of 'withMonitor' that uses the 'Restart' strategy. restart ::-  ∀ resource r .-  Member (ScopedMonitor resource Restart) r =>+  Member (ScopedMonitor Restart) r =>   InterpreterFor (Monitor Restart) r restart =-  withMonitor @resource+  withMonitor

@@ -10,7 +10,7 @@ data Race :: Effect where   -- |Run both programs concurrently, returning the result of the faster one.   Race :: m a -> m b -> Race m (Either a b)-  -- |Run the fallback action if the given program doesn't finish within the specified interval.+  -- |Run the first action if the second action doesn't finish within the specified interval.   Timeout :: TimeUnit u => m a -> u -> m b -> Race m (Either a b)  makeSem_ ''Race

@@ -3,28 +3,149 @@ -- |Description: Scoped Effect, Internal module Polysemy.Conc.Effect.Scoped where --- |@Scoped@ transforms a program so that @effect@ is associated with a @resource@ within that program.--- This requires the interpreter for @effect@ to be parameterized by @resource@ and constructed for every program using--- @Scoped@ separately.+-- | @Scoped@ transforms a program so that an interpreter for @effect@ may+-- perform arbitrary actions, like resource management, before and after the+-- computation wrapped by a call to 'scoped' is executed. ----- An application for this is 'Polysemy.Conc.Events', in which each program using the effect 'Polysemy.Conc.Consume' is--- interpreted with its own copy of the event channel; or a database transaction, in which a transaction handle is--- created for the wrapped program and passed to the interpreter for the database effect.+-- /Note/: This effect has been merged to Polysemy and will be released there soon. ----- Resource creation is performed by the function passed to 'Polysemy.Conc.Interpreter.runScoped'.+-- An application for this is @Polysemy.Conc.Events@ from+-- <https://hackage.haskell.org/package/polysemy-conc>, in which each program+-- using the effect @Polysemy.Conc.Consume@ is interpreted with its own copy of+-- the event channel; or a database transaction, in which a transaction handle+-- is created for the wrapped program and passed to the interpreter for the+-- database effect. ----- The constructors are not intended to be used directly; the smart constructor 'scoped' is used like a local--- interpreter for @effect@.-data Scoped (resource :: Type) (effect :: Effect) :: Effect where-  Run :: ∀ resource effect m a . resource -> effect m a -> Scoped resource effect m a-  InScope :: ∀ resource effect m a . (resource -> m a) -> Scoped resource effect m a+-- For a longer exposition, see <https://www.tweag.io/blog/2022-01-05-polysemy-scoped/>.+-- Note that the interface has changed since the blog post was published: The+-- @resource@ parameter no longer exists.+--+-- Resource allocation is performed by a function passed to+-- 'Polysemy.Scoped.interpretScoped'.+--+-- The constructors are not intended to be used directly; the smart constructor+-- 'scoped' is used like a local interpreter for @effect@. 'scoped' takes an+-- argument of type @param@, which will be passed through to the interpreter, to+-- be used by the resource allocation function.+--+-- As an example, imagine an effect for writing lines to a file:+--+-- > data Write :: Effect where+-- >   Write :: Text -> Write m ()+-- > makeSem ''Write+--+-- If we now have the following requirements:+--+-- 1. The file should be opened and closed right before and after the part of+--    the program in which we write lines+-- 2. The file name should be specifiable at the point in the program where+--    writing begins+-- 3. We don't want to commit to IO, lines should be stored in memory when+--    running tests+--+-- Then we can take advantage of 'Scoped' to write this program:+--+-- > prog :: Member (Scoped FilePath Write) r => Sem r ()+-- > prog = do+-- >   scoped "file1.txt" do+-- >     write "line 1"+-- >     write "line 2"+-- >   scoped "file2.txt" do+-- >     write "line 1"+-- >     write "line 2"+--+-- Here 'scoped' creates a prompt for an interpreter to start allocating a+-- resource for @"file1.txt"@ and handling @Write@ actions using that resource.+-- When the 'scoped' block ends, the resource should be freed.+--+-- The interpreter may look like this:+--+-- > interpretWriteFile :: Members '[Resource, Embed IO] => InterpreterFor (Scoped FilePath Write) r+-- > interpretWriteFile =+-- >   interpretScoped allocator handler+-- >   where+-- >     allocator name use = bracket (openFile name WriteMode) hClose use+-- >     handler fileHandle (Write line) = embed (Text.hPutStrLn fileHandle line)+--+-- Essentially, the @bracket@ is executed at the point where @scoped@ was+-- called, wrapping the following block. When the second @scoped@ is executed,+-- another call to @bracket@ is performed.+--+-- The effect of this is that the operation that uses @Embed IO@ was moved from+-- the call site to the interpreter, while the interpreter may be executed at+-- the outermost layer of the app.+--+-- This makes it possible to use a pure interpreter for testing:+--+-- > interpretWriteOutput :: Member (Output (FilePath, Text)) r => InterpreterFor (Scoped FilePath Write) r+-- > interpretWriteOutput =+-- >   interpretScoped (\ name use -> use name) \ name -> \case+-- >     Write line -> output (name, line)+--+-- Here we simply pass the name to the interpreter in the resource allocation+-- function.+--+-- Now imagine that we drop requirement 2 from the initial list – we still want+-- the file to be opened and closed as late/early as possible, but the file name+-- is globally fixed. For this case, the @param@ type is unused, and the API+-- provides some convenience aliases to make your code more concise:+--+-- > prog :: Member (Scoped_ Write) r => Sem r ()+-- > prog = do+-- >   scoped_ do+-- >     write "line 1"+-- >     write "line 2"+-- >   scoped_ do+-- >     write "line 1"+-- >     write "line 2"+--+-- The type 'Scoped_' and the constructor 'scoped_' simply fix @param@ to @()@.+data Scoped (param :: Type) (effect :: Effect) :: Effect where+  Run :: ∀ param effect m a . effect m a -> Scoped param effect m a+  InScope :: ∀ param effect m a . param -> m a -> Scoped param effect m a --- |Constructor for 'Scoped', taking a nested program and transforming all instances of @effect@ to--- @Scoped resource effect@.+-- |A convenience alias for a scope without parameters.+type Scoped_ effect =+  Scoped () effect++-- | Constructor for 'Scoped', taking a nested program and transforming all+-- instances of @effect@ to @'Scoped' param effect@.+--+-- Please consult the documentation of 'Scoped' for details and examples. scoped ::-  ∀ resource effect r .-  Member (Scoped resource effect) r =>+  ∀ param effect r .+  Member (Scoped param effect) r =>+  param ->   InterpreterFor effect r-scoped main =-  send $ InScope @resource @effect \ resource ->-    transform @effect (Run resource) main+scoped param main =+  send $ InScope @param @effect param do+    transform @effect (Run @param) main+{-# inline scoped #-}++-- | Constructor for 'Scoped_', taking a nested program and transforming all+-- instances of @effect@ to @'Scoped_' effect@.+--+-- Please consult the documentation of 'Scoped' for details and examples.+scoped_ ::+  ∀ effect r .+  Member (Scoped_ effect) r =>+  InterpreterFor effect r+scoped_ = scoped ()+{-# inline scoped_ #-}++-- | Transform the parameters of a 'Scoped' program.+--+-- This allows incremental additions to the data passed to the interpreter, for+-- example to create an API that permits different ways of running an effect+-- with some fundamental parameters being supplied at scope creation and some+-- optional or specific parameters being selected by the user downstream.+rescope ::+  ∀ param0 param1 effect r .+  Member (Scoped param1 effect) r =>+  (param0 -> param1) ->+  InterpreterFor (Scoped param0 effect) r+rescope fp =+  transform \case+    Run e          -> Run @param1 e+    InScope p main -> InScope (fp p) main+{-# inline rescope #-}

@@ -0,0 +1,24 @@+-- |Semaphore effect, Internal.+module Polysemy.Conc.Effect.Semaphore where++-- |This effect abstracts over the concept of a quantity semaphore, a concurrency primitive that contains a number of+-- slots that can be acquired and released.+data Semaphore :: Effect where+  -- |Wait until a slot is available, then acquire it.+  Wait :: Semaphore m ()+  -- |Release a slot.+  Signal :: Semaphore m ()++makeSem_ ''Semaphore++-- |Wait until a slot is available, then acquire it.+wait ::+  ∀ r .+  Member Semaphore r =>+  Sem r ()++-- |Release a slot.+signal ::+  ∀ r .+  Member Semaphore r =>+  Sem r ()

@@ -1,10 +1,10 @@ {-# options_haddock prune #-} --- |Description: Sync effect+-- |Description: Sync effect, Internal. module Polysemy.Conc.Effect.Sync where  import Polysemy.Time (TimeUnit)-import Polysemy.Conc.Effect.Scoped (Scoped)+import Polysemy.Conc.Effect.Scoped (Scoped_)  -- |Abstracts an 'Control.Concurrent.MVar'. --@@ -36,16 +36,13 @@   PutBlock :: d -> Sync d m ()   -- |Write the variable, waiting until it is writable or the timeout has expired.   PutWait :: TimeUnit u => u -> d -> Sync d m Bool-  -- |Write the variable, returning 'False' immmediately if no value was available.+  -- |Write the variable, returning 'False' immmediately if a value was available.   PutTry :: d -> Sync d m Bool   -- |Indicate whether the variable is empty.   Empty :: Sync d m Bool  makeSem ''Sync -newtype SyncResources a =-  SyncResources { unSyncResources :: a }- -- |Convenience alias.-type ScopedSync res a =-  Scoped (SyncResources res) (Sync a)+type ScopedSync a =+  Scoped_ (Sync a)

@@ -1,27 +1,188 @@ -- |Description: Events Combinators module Polysemy.Conc.Events where +import Polysemy.Conc.Async (withAsync_) import qualified Polysemy.Conc.Effect.Events as Events+import Polysemy.Conc.Effect.Events (Consume)+import Polysemy.Conc.Effect.Gate (Gate, Gates, gate, signal, withGate)+import Polysemy.Conc.Effect.Race (Race)+import Polysemy.Conc.Effect.Scoped (Scoped_) import Polysemy.Conc.Interpreter.Events (EventConsumer) +-- |Create a new scope for 'Polysemy.Conc.Events', causing the nested program to get its own copy of the event stream.+--+-- Calls 'signal' before running the argument to ensure that 'Events.subscribe' has finished creating a channel, for use+-- with asynchronous execution.+subscribeGated ::+  ∀ e r .+  Members [EventConsumer e, Gate] r =>+  InterpreterFor (Consume e) r+subscribeGated action =+  Events.subscribe @e do+    signal+    action++-- |Create a new scope for 'Polysemy.Conc.Events', causing the nested program to get its own copy of the event stream.+--+-- Executes in a new thread, ensuring that the main thread blocks until 'Events.subscribe' has finished creating a+-- channel.+subscribeAsync ::+  ∀ e r a .+  Members [EventConsumer e, Scoped_ Gate, Resource, Race, Async] r =>+  Sem (Consume e : r) () ->+  Sem r a ->+  Sem r a+subscribeAsync consumer ma =+  withGate $ withAsync_ (subscribeGated @_ (raiseUnder @Gate consumer)) do+    gate+    raise @Gate ma++-- |Pull repeatedly from 'Polysemy.Conc.Consume', passing the event to the supplied callback.+-- Stop when the action returns @False@.+consumeWhile ::+  Member (Consume e) r =>+  (e -> Sem r Bool) ->+  Sem r ()+consumeWhile action =+  spin+  where+    spin =+      whenM (action =<< Events.consume) spin+ -- |Pull repeatedly from the 'Polysemy.Conc.Events' channel, passing the event to the supplied callback. -- Stop when the action returns @False@. subscribeWhile ::-  ∀ e token r .-  Member (EventConsumer token e) r =>+  ∀ e r .+  Member (EventConsumer e) r =>   (e -> Sem r Bool) ->   Sem r () subscribeWhile action =-  Events.subscribe @e @token spin-  where-    spin =-      whenM (raise . action =<< Events.consume) spin+  Events.subscribe @e (consumeWhile (raise . action))  -- |Pull repeatedly from the 'Polysemy.Conc.Events' channel, passing the event to the supplied callback.+-- Stop when the action returns @False@.+--+-- Signals the caller that the channel was successfully subscribed to using the 'Gate' effect.+subscribeWhileGated ::+  ∀ e r .+  Members [EventConsumer e, Gate] r =>+  (e -> Sem r Bool) ->+  Sem r ()+subscribeWhileGated action =+  subscribeGated @e do+    consumeWhile (raise . action)++-- |Start a new thread that pulls repeatedly from the 'Polysemy.Conc.Events' channel, passing the event to the supplied+-- callback and stops when the action returns @False@.+subscribeWhileAsync ::+  ∀ e r a .+  Members [EventConsumer e, Gates, Resource, Race, Async] r =>+  (e -> Sem (Consume e : r) Bool) ->+  Sem r a ->+  Sem r a+subscribeWhileAsync action =+  subscribeAsync @e (consumeWhile action)++-- |Pull repeatedly from 'Polysemy.Conc.Consume', passing the event to the supplied callback.+consumeLoop ::+  Member (Consume e) r =>+  (e -> Sem r ()) ->+  Sem r ()+consumeLoop action =+  forever (action =<< Events.consume)++-- |Pull repeatedly from the 'Polysemy.Conc.Events' channel, passing the event to the supplied callback. subscribeLoop ::-  ∀ e token r .-  Member (EventConsumer token e) r =>+  ∀ e r .+  Member (EventConsumer e) r =>   (e -> Sem r ()) ->   Sem r () subscribeLoop action =-  Events.subscribe @e @token (forever (raise . action =<< Events.consume))+  Events.subscribe @e (consumeLoop (raise . action))++-- |Pull repeatedly from the 'Polysemy.Conc.Events' channel, passing the event to the supplied callback.+--+-- Signals the caller that the channel was successfully subscribed to using the 'Gate' effect.+subscribeLoopGated ::+  ∀ e r .+  Members [EventConsumer e, Gate] r =>+  (e -> Sem r ()) ->+  Sem r ()+subscribeLoopGated action =+  subscribeGated @e do+    consumeLoop (raise . action)++-- |Start a new thread that pulls repeatedly from the 'Polysemy.Conc.Events' channel, passing the event to the supplied+-- callback.+subscribeLoopAsync ::+  ∀ e r a .+  Members [EventConsumer e, Gates, Resource, Race, Async] r =>+  (e -> Sem (Consume e : r) ()) ->+  Sem r a ->+  Sem r a+subscribeLoopAsync action =+  subscribeAsync @e (consumeLoop action)++-- |Block until a value matching the predicate has been returned by 'Polysemy.Conc.Consume'.+consumeFind ::+  ∀ e r .+  Member (Consume e) r =>+  (e -> Sem r Bool) ->+  Sem r e+consumeFind f =+  spin+  where+    spin = do+      e <- Events.consume+      ifM (f e) (pure e) spin++-- |Block until a value matching the predicate has been published to the 'Polysemy.Conc.Events' channel.+subscribeFind ::+  ∀ e r .+  Member (EventConsumer e) r =>+  (e -> Sem (Consume e : r) Bool) ->+  Sem r e+subscribeFind f =+  Events.subscribe @e (consumeFind f)++-- |Return the first value returned by 'Polysemy.Conc.Consume' for which the function produces 'Just'.+consumeFirstJust ::+  ∀ e a r .+  Member (Consume e) r =>+  (e -> Sem r (Maybe a)) ->+  Sem r a+consumeFirstJust f =+  spin+  where+    spin = do+      e <- Events.consume+      maybe spin pure =<< f e++-- |Return the first value published to the 'Polysemy.Conc.Events' channel for which the function produces 'Just'.+subscribeFirstJust ::+  ∀ e a r .+  Member (EventConsumer e) r =>+  (e -> Sem (Consume e : r) (Maybe a)) ->+  Sem r a+subscribeFirstJust f =+  Events.subscribe @e (consumeFirstJust f)++-- |Block until the specified value has been returned by 'Polysemy.Conc.Consume'.+consumeElem ::+  ∀ e r .+  Eq e =>+  Member (Consume e) r =>+  e ->+  Sem r ()+consumeElem target =+  void (consumeFind (pure . (target ==)))++-- |Block until the specified value has been published to the 'Polysemy.Conc.Events' channel.+subscribeElem ::+  ∀ e r .+  Eq e =>+  Member (EventConsumer e) r =>+  e ->+  Sem r ()+subscribeElem target =+  Events.subscribe @e (consumeElem target)

@@ -0,0 +1,10 @@+{-# options_haddock prune #-}++-- |Description: API for the 'Gate' effect+module Polysemy.Conc.Gate (+  module Polysemy.Conc.Effect.Gate,+  module Polysemy.Conc.Interpreter.Gate,+) where++import Polysemy.Conc.Effect.Gate+import Polysemy.Conc.Interpreter.Gate

@@ -7,35 +7,23 @@  import Polysemy.Conc.Async (withAsync_) import qualified Polysemy.Conc.Effect.Events as Events-import Polysemy.Conc.Effect.Events (Consume, EventResource (EventResource), Events)+import Polysemy.Conc.Effect.Events (Consume, Events) import Polysemy.Conc.Effect.Race (Race)-import Polysemy.Conc.Effect.Scoped (Scoped)+import Polysemy.Conc.Effect.Scoped (Scoped_) import Polysemy.Conc.Interpreter.Scoped (runScopedAs) --- |Convenience alias for the default 'Events' that uses an 'OutChan'.-type ChanEvents e =-  Events (OutChan e) e---- |Convenience alias for the default 'EventResource' that uses an 'OutChan'.-type EventChan e =-  EventResource (OutChan e)- -- |Convenience alias for the consumer effect.-type EventConsumer token e =-  Scoped (EventResource token) (Consume e)---- |Convenience alias for the consumer effect using the default implementation.-type ChanConsumer e =-  Scoped (EventChan e) (Consume e)+type EventConsumer e =+  Scoped_ (Consume e)  -- |Interpret 'Consume' by reading from an 'OutChan'. -- Used internally by 'interpretEventsChan', not safe to use directly. interpretConsumeChan ::   ∀ e r .   Member (Embed IO) r =>-  EventChan e ->+  OutChan e ->   InterpreterFor (Consume e) r-interpretConsumeChan (EventResource chan) =+interpretConsumeChan chan =   interpret \case     Events.Consume ->       embed (readChan chan)@@ -47,15 +35,15 @@   ∀ e r .   Member (Embed IO) r =>   InChan e ->-  InterpreterFor (Events (OutChan e) e) r+  InterpreterFor (Events e) r interpretEventsInChan inChan =   interpret \case     Events.Publish e ->       void (embed (tryWriteChan inChan e))  -- |Interpret 'Events' and 'Consume' together by connecting them to the two ends of an unagi channel.--- 'Consume' is only interpreted in a 'Scoped' manner, ensuring that a new duplicate of the channel is created so that--- all consumers see all events (from the moment they are connected).+-- 'Consume' is only interpreted in a 'Polysemy.Conc.Scoped' manner, ensuring that a new duplicate of the channel is+-- created so that all consumers see all events (from the moment they are connected). -- -- This should be used in conjunction with 'Polysemy.Conc.subscribe': --@@ -71,8 +59,8 @@ interpretEventsChan ::   ∀ e r .   Members [Resource, Race, Async, Embed IO] r =>-  InterpretersFor [Events (OutChan e) e, ChanConsumer e] r+  InterpretersFor [Events e, EventConsumer e] r interpretEventsChan sem = do   (inChan, outChan) <- embed (newChan @e 64)   withAsync_ (forever (embed (readChan outChan))) do-    runScopedAs (EventResource <$> embed (dupChan inChan)) interpretConsumeChan (interpretEventsInChan inChan sem)+    runScopedAs (const (embed (dupChan inChan))) interpretConsumeChan (interpretEventsInChan inChan sem)

@@ -0,0 +1,34 @@+-- |Gate interpreters, Internal+module Polysemy.Conc.Interpreter.Gate where++import Polysemy.Conc.Effect.Gate (Gate (Gate, Signal))+import Polysemy.Conc.Effect.Scoped (Scoped_)+import Polysemy.Conc.Interpreter.Scoped (interpretScopedAs)++-- |Interpret 'Gate' with an 'MVar'.+interpretGate ::+  ∀ r .+  Member (Embed IO) r =>+  InterpreterFor Gate r+interpretGate sem = do+  mv <- embed newEmptyMVar+  int mv sem+  where+    int :: MVar () -> InterpreterFor Gate r+    int mv =+      interpret \case+        Signal ->+          void (embed (tryPutMVar mv ()))+        Gate ->+          embed (readMVar mv)++-- |Interpret @'Scoped_' 'Gate'@ with an @'MVar' ()@.+interpretGates ::+  Member (Embed IO) r =>+  InterpreterFor (Scoped_ Gate) r+interpretGates =+  interpretScopedAs @(MVar ()) (const (embed newEmptyMVar)) \ mv -> \case+    Signal ->+      void (embed (tryPutMVar mv ()))+    Gate ->+      embed (readMVar mv)

@@ -0,0 +1,115 @@+{-# options_haddock prune #-}++-- |Lock interpreters, Internal+module Polysemy.Conc.Interpreter.Lock where++import Control.Concurrent (ThreadId, myThreadId)++import Polysemy.Conc.Effect.Lock (Lock (Lock, LockOr))+import Polysemy.Conc.Effect.Mask (Mask, mask, restore)+import Polysemy.Conc.Effect.Race (Race)+import qualified Polysemy.Conc.Effect.Sync as Sync (putTry, takeBlock, takeTry)+import Polysemy.Conc.Effect.Sync (Sync)+import Polysemy.Conc.Interpreter.Sync (interpretSyncAs)++currentThread ::+  Member (Embed IO) r =>+  Sem r ThreadId+currentThread =+  embed myThreadId++-- |Interpret 'Lock' by executing all actions unconditionally.+interpretLockPermissive ::+  InterpreterFor Lock r+interpretLockPermissive =+  interpretH \case+    Lock ma ->+      runTSimple ma+    LockOr _ ma ->+      runTSimple ma+{-# inline interpretLockPermissive #-}++lockOnDifferentThread ::+  ∀ f m r a .+  Members [Sync (), Resource, Race, Mask, Embed IO] r =>+  ThreadId ->+  m a ->+  (Sem (Lock : r) (f a) -> Sem (Lock : r) (f a)) ->+  Sem (WithTactics Lock f m r) (f a)+lockOnDifferentThread lockThread maI f = do+  thread <- currentThread+  ma <- runT maI+  raise $ interpretLockReentrantEntered thread do+    if thread == lockThread+    then ma+    else f ma+{-# inline lockOnDifferentThread #-}++enter ::+  ∀ f m r a .+  Members [Sync (), Resource, Race, Mask, Embed IO] r =>+  m a ->+  (Sem (Lock : r) (f a) -> Sem (Lock : r) (f a)) ->+  Sem (WithTactics Lock f m r) (f a)+enter maI f = do+  thread <- currentThread+  ma <- runT maI+  raise $ interpretLockReentrantEntered thread do+    f ma+{-# inline enter #-}++lockWait ::+  ∀ r a .+  Members [Sync (), Resource, Mask] r =>+  Sem r a ->+  Sem r a+lockWait ma =+  mask do+    Sync.takeBlock @()+    finally (restore (raise ma)) (Sync.putTry ())+{-# inline lockWait #-}++lockAlt ::+  ∀ r a .+  Members [Sync (), Resource, Mask] r =>+  Sem r a ->+  Sem r a ->+  Sem r a+lockAlt alt ma =+  mask do+    Sync.takeTry >>= \case+      Just () ->+        finally (restore (raise ma)) (Sync.putTry ())+      Nothing ->+        restore (raise alt)+{-# inline lockAlt #-}++-- |Subinterpreter for 'interpretLockReentrant' that checks whether the current thread is equal to the lock-acquiring+-- thread to allow reentry into the lock.+interpretLockReentrantEntered ::+  Members [Sync (), Resource, Race, Mask, Embed IO] r =>+  ThreadId ->+  InterpreterFor Lock r+interpretLockReentrantEntered lockThread =+  interpretH \case+    Lock maI ->+      lockOnDifferentThread lockThread maI (lockWait)+    LockOr altI maI -> do+      alt <- runT altI+      lockOnDifferentThread lockThread maI (lockAlt alt)+{-# inline interpretLockReentrantEntered #-}++-- |Interpret 'Lock' as a reentrant lock, allowing nested calls to 'Polysemy.Conc.lock' unless called from a different+-- thread (as in, @async@ was called in a higher-order action passed to 'Polysemy.Conc.lock'.)+interpretLockReentrant ::+  Members [Resource, Race, Mask, Embed IO] r =>+  InterpreterFor Lock r+interpretLockReentrant =+  interpretSyncAs () .+  reinterpretH \case+    Lock maI ->+      enter maI (lockWait)+    LockOr altI maI -> do+      alt <- runT altI+      enter maI (lockAlt alt)+{-# inline interpretLockReentrant #-}

@@ -8,32 +8,27 @@  import Polysemy.Conc.Effect.Mask (   Mask,-  MaskResource (MaskResource),+  Restoration (Restoration),   RestoreMask (Restore),   UninterruptibleMask,-  UninterruptibleMaskResource (UninterruptibleMaskResource),   )-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 }+import Polysemy.Conc.Interpreter.Scoped (interpretScopedH, runScoped)  mask ::   Member (Final IO) r =>-  (MaskResource Restoration -> Sem r a) ->+  (Restoration -> Sem r a) ->   Sem r a mask f =   withWeavingToFinal @IO \ s lower _ ->-    Base.mask \ restore -> lower (f (MaskResource (Restoration restore)) <$ s)+    Base.mask \ restore -> lower (f (Restoration restore) <$ s)  uninterruptibleMask ::   Member (Final IO) r =>-  (UninterruptibleMaskResource Restoration -> Sem r a) ->+  (Restoration -> Sem r a) ->   Sem r a uninterruptibleMask f =   withWeavingToFinal @IO \ s lower _ ->-    Base.uninterruptibleMask \ restore -> lower (f (UninterruptibleMaskResource (Restoration restore)) <$ s)+    Base.uninterruptibleMask \ restore -> lower (f (Restoration restore) <$ s)  interpretRestoreMask ::   ∀ r .@@ -42,22 +37,31 @@   InterpreterFor RestoreMask r interpretRestoreMask (Restoration restore) =   interpretH \case-    Restore ma -> do-      let-        restoreSem m =-          withStrategicToFinal (restore <$> runS m)-      restoreSem (runTSimple ma)+    Restore ma ->+      withStrategicToFinal (restore <$> runS (runTSimple ma)) +-- |Interpret 'Mask' by sequencing the action without masking.+interpretMaskPure :: InterpreterFor Mask r+interpretMaskPure =+  interpretScopedH (const ($ ())) \ () -> \case+    Restore ma -> runTSimple ma+ -- |Interpret 'Mask' in 'IO'. interpretMaskFinal ::   Member (Final IO) r =>-  InterpreterFor (Mask Restoration) r+  InterpreterFor Mask r interpretMaskFinal =-  runScoped mask \ (MaskResource r) -> interpretRestoreMask r+  runScoped (const mask) \ r -> interpretRestoreMask r +-- |Interpret 'UninterruptibleMask' by sequencing the action without masking.+interpretUninterruptibleMaskPure :: InterpreterFor UninterruptibleMask r+interpretUninterruptibleMaskPure =+  interpretScopedH (const ($ ())) \ () -> \case+    Restore ma -> runTSimple ma+ -- |Interpret 'UninterruptibleMask' in 'IO'. interpretUninterruptibleMaskFinal ::   Member (Final IO) r =>-  InterpreterFor (UninterruptibleMask Restoration) r+  InterpreterFor UninterruptibleMask r interpretUninterruptibleMaskFinal =-  runScoped uninterruptibleMask \ (UninterruptibleMaskResource r) -> interpretRestoreMask r+  runScoped (const uninterruptibleMask) \ r -> interpretRestoreMask r

@@ -8,13 +8,7 @@ import Polysemy.Time (Time)  import Polysemy.Conc.Async (withAsync_)-import Polysemy.Conc.Effect.Monitor (-  Monitor (Monitor),-  MonitorCheck (MonitorCheck),-  MonitorResource (MonitorResource),-  RestartingMonitor,-  ScopedMonitor,-  )+import Polysemy.Conc.Effect.Monitor (Monitor (Monitor), MonitorCheck (MonitorCheck), RestartingMonitor, ScopedMonitor) import qualified Polysemy.Conc.Effect.Race as Race import Polysemy.Conc.Effect.Race (Race) import Polysemy.Conc.Interpreter.Scoped (runScoped, runScopedAs)@@ -29,9 +23,9 @@  interpretMonitorCancel ::   Members [Race, Async, Final IO] r =>-  MonitorResource CancelResource ->+  CancelResource ->   InterpreterFor (Monitor action) r-interpretMonitorCancel (MonitorResource CancelResource {..}) =+interpretMonitorCancel CancelResource {..} =   interpretH \case     Monitor ma ->       either (const (Base.throw MonitorCancel)) pure =<< Race.race (embedFinal @IO (readMVar signal)) (runTSimple ma)@@ -40,14 +34,14 @@   ∀ t d r a .   Members [Time t d, Resource, Async, Race, Final IO] r =>   MonitorCheck r ->-  (MonitorResource CancelResource -> Sem r a) ->+  (CancelResource -> Sem r a) ->   Sem r a monitorRestart (MonitorCheck interval check) use = do   sig <- embedFinal @IO newEmptyMVar   withAsync_ (Time.loop_ @t @d interval (check sig)) (spin sig)   where     spin sig = do-      let res = (MonitorResource (CancelResource sig))+      let res = (CancelResource sig)       void (embedFinal @IO (tryTakeMVar sig))       either (const (spin sig)) pure =<< errorToIOFinal @MonitorCancel (fromExceptionSem @MonitorCancel (raise (use res))) @@ -58,17 +52,17 @@   ∀ t d r .   Members [Time t d, Resource, Async, Race, Final IO] r =>   MonitorCheck r ->-  InterpreterFor (RestartingMonitor CancelResource) r+  InterpreterFor RestartingMonitor r interpretMonitorRestart check =-  runScoped (monitorRestart @t @d check) interpretMonitorCancel+  runScoped (const (monitorRestart @t @d check)) interpretMonitorCancel -interpretMonitorPure' :: MonitorResource () -> InterpreterFor (Monitor action) r+interpretMonitorPure' :: () -> InterpreterFor (Monitor action) r interpretMonitorPure' _ =   interpretH \case     Monitor ma ->       runTSimple ma  -- |Run 'Monitor' as a no-op.-interpretMonitorPure :: InterpreterFor (ScopedMonitor () action) r+interpretMonitorPure :: InterpreterFor (ScopedMonitor action) r interpretMonitorPure =-  runScopedAs (pure (MonitorResource ())) interpretMonitorPure'+  runScopedAs (const unit) interpretMonitorPure'

@@ -3,120 +3,321 @@ -- |Description: Scoped Interpreters, Internal module Polysemy.Conc.Interpreter.Scoped where -import Polysemy.Internal (Sem (Sem, runSem), liftSem)-import Polysemy.Internal.Index (InsertAtIndex)+import GHC.Err (errorWithoutStackTrace)+import Polysemy.Internal (Sem (Sem), hoistSem, liftSem, runSem)+import Polysemy.Internal.Sing (KnownList (singList)) import Polysemy.Internal.Tactics (liftT, runTactics)-import Polysemy.Internal.Union (Weaving (Weaving), decomp, hoist, injWeaving)+import Polysemy.Internal.Union (+  Union (Union),+  Weaving (Weaving),+  decomp,+  extendMembershipLeft,+  hoist,+  injWeaving,+  injectMembership,+  )+import Polysemy.Membership (ElemOf) import Polysemy.Resume (Stop, runStop, type (!!)) import Polysemy.Resume.Effect.Resumable (Resumable (Resumable))  import Polysemy.Conc.Effect.Scoped (Scoped (InScope, Run)) -interpretH' ::+interpretWeaving ::   ∀ e r .   (∀ x . Weaving e (Sem (e : r)) x -> Sem r x) ->   InterpreterFor e r-interpretH' h (Sem m) =+interpretWeaving h (Sem m) =   Sem \ k -> m $ decomp >>> \case     Right wav -> runSem (h wav) k-    Left g -> k $ hoist (interpretH' h) g+    Left g -> k (hoist (interpretWeaving h) g) +restack :: (∀ e . ElemOf e r -> ElemOf e r')+        -> Sem r a+        -> Sem r' a+restack n =+  hoistSem $ \ (Union pr wav) -> hoist (restack n) (Union (n pr) wav)+{-# inline restack #-} --- |Interpreter for 'Scoped', taking a @resource@ allocation function and a parameterized interpreter for the plain--- @effect@.------ @withResource@ is a callback function, allowing the user to acquire the resource for each program from other effects.+-- | Construct an interpreter for a higher-order effect wrapped in a 'Scoped',+-- given a resource allocation function and a parameterized handler for the+-- plain effect. ----- @scopedInterpreter@ is a regular interpreter that is called with the @resource@ argument produced by @scope@.--- /Note/: This function will be called for each action in the program, so if the interpreter allocates any resources,--- they will be scoped to a single action. Move them to @withResource@ instead.-runScoped ::-  ∀ resource effect r .-  (∀ x . (resource -> Sem r x) -> Sem r x) ->-  (resource -> InterpreterFor effect r) ->-  InterpreterFor (Scoped resource effect) r-runScoped withResource scopedInterpreter =-  run-  where-    run :: InterpreterFor (Scoped resource effect) r-    run =-      interpretH' \ (Weaving effect s wv ex ins) -> case effect of-        Run resource act ->-          scopedInterpreter resource (liftSem $ injWeaving $ Weaving act s (raise . run . wv) ex ins)-        InScope main ->-          ex <$> withResource \ resource -> run (wv (main resource <$ s))---- |Variant of 'runScoped' in which the resource allocator is a plain action.-runScopedAs ::-  ∀ resource effect r .-  Sem r resource ->-  (resource -> InterpreterFor effect r) ->-  InterpreterFor (Scoped resource effect) r-runScopedAs resource =-  runScoped \ f -> f =<< resource---- |Variant of 'runScoped' that takes a higher-order handler instead of an interpreter.+-- This combinator is analogous to 'interpretH' in that it allows the handler to+-- use the 'Tactical' environment and transforms the effect into other effects+-- on the stack. interpretScopedH ::-  ∀ resource effect r .-  (∀ x . (resource -> Sem r x) -> Sem r x) ->+  ∀ resource param effect r .+  -- | A callback function that allows the user to acquire a resource for each+  -- computation wrapped by 'Polysemy.Conc.scoped' using other effects, with an additional+  -- argument that contains the call site parameter passed to 'Polysemy.Conc.scoped'.+  (∀ x . param -> (resource -> Sem r x) -> Sem r x) ->+  -- | A handler like the one expected by 'interpretH' with an additional+  -- parameter that contains the @resource@ allocated by the first argument.   (∀ r0 x . resource -> effect (Sem r0) x -> Tactical effect (Sem r0) r x) ->-  InterpreterFor (Scoped resource effect) r+  InterpreterFor (Scoped param effect) r interpretScopedH withResource scopedHandler =-  run+  go (errorWithoutStackTrace "top level run")   where-    run :: InterpreterFor (Scoped resource effect) r-    run =-      interpretH' \ (Weaving effect s wv ex ins) -> case effect of-        Run resource act ->-          ex <$> runTactics s (raise . run . wv) ins (run . wv) (scopedHandler resource act)-        InScope main ->-          ex <$> withResource \ resource -> run (wv (main resource <$ s))+    go :: resource -> InterpreterFor (Scoped param effect) r+    go resource =+      interpretWeaving \ (Weaving effect s wv ex ins) -> case effect of+        Run act ->+          ex <$> runTactics s (raise . go resource . wv) ins (go resource . wv)+            (scopedHandler resource act)+        InScope param main ->+          withResource param \ resource' -> ex <$> go resource' (wv (main <$ s))+{-# inline interpretScopedH #-} --- |Variant of 'runScoped' that takes a handler instead of an interpreter.+-- | Variant of 'interpretScopedH' that allows the resource acquisition function+-- to use 'Tactical'.+interpretScopedH' ::+  ∀ resource param effect r .+  (∀ e r0 x . param -> (resource -> Tactical e (Sem r0) r x) ->+    Tactical e (Sem r0) r x) ->+  (∀ r0 x .+    resource -> effect (Sem r0) x ->+    Tactical (Scoped param effect) (Sem r0) r x) ->+  InterpreterFor (Scoped param effect) r+interpretScopedH' withResource scopedHandler =+  go (errorWithoutStackTrace "top level run")+  where+    go :: resource -> InterpreterFor (Scoped param effect) r+    go resource =+      interpretH \case+        Run act ->+          scopedHandler resource act+        InScope param main ->+          withResource param \ resource' ->+            raise . go resource' =<< runT main+{-# inline interpretScopedH' #-}++-- | First-order variant of 'interpretScopedH'. interpretScoped ::-  ∀ resource effect r .-  (∀ x . (resource -> Sem r x) -> Sem r x) ->-  (∀ r0 x . resource -> effect (Sem r0) x -> Sem r x) ->-  InterpreterFor (Scoped resource effect) r+  ∀ resource param effect r .+  (∀ x . param -> (resource -> Sem r x) -> Sem r x) ->+  (∀ m x . resource -> effect m x -> Sem r x) ->+  InterpreterFor (Scoped param effect) r interpretScoped withResource scopedHandler =   interpretScopedH withResource \ r e -> liftT (scopedHandler r e)+{-# inline interpretScoped #-} --- |Variant of 'interpretScoped' in which the resource allocator is a plain action.+-- | Variant of 'interpretScoped' in which the resource allocator is a plain+-- action. interpretScopedAs ::-  ∀ resource effect r .-  Sem r resource ->-  (∀ r0 x . resource -> effect (Sem r0) x -> Sem r x) ->-  InterpreterFor (Scoped resource effect) r+  ∀ resource param effect r .+  (param -> Sem r resource) ->+  (∀ m x . resource -> effect m x -> Sem r x) ->+  InterpreterFor (Scoped param effect) r interpretScopedAs resource =-  interpretScoped \ f -> f =<< resource+  interpretScoped \ p use -> use =<< resource p+{-# inline interpretScopedAs #-} +-- | Higher-order interpreter for 'Scoped' that allows the handler to use+-- additional effects that are interpreted by the resource allocator.+--+-- /Note/: It is necessary to specify the list of local interpreters with a type+-- application; GHC won't be able to figure them out from the type of+-- @withResource@.+--+-- As an example for a higher order effect, consider a mutexed concurrent state+-- effect, where an effectful function may lock write access to the state while+-- making it still possible to read it:+--+-- > data MState s :: Effect where+-- >   MState :: (s -> m (s, a)) -> MState s m a+-- >   MRead :: MState s m s+-- >+-- > makeSem ''MState+--+-- We can now use an 'Polysemy.AtomicState.AtomicState' to store the current+-- value and lock write access with an @MVar@. Since the state callback is+-- effectful, we need a higher order interpreter:+--+-- > withResource ::+-- >   Member (Embed IO) r =>+-- >   s ->+-- >   (MVar () -> Sem (AtomicState s : r) a) ->+-- >   Sem r a+-- > withResource initial use = do+-- >   tv <- embed (newTVarIO initial)+-- >   lock <- embed (newMVar ())+-- >   runAtomicStateTVar tv $ use lock+-- >+-- > interpretMState ::+-- >   ∀ s r .+-- >   Members [Resource, Embed IO] r =>+-- >   InterpreterFor (Scoped s (MState s)) r+-- > interpretMState =+-- >   interpretScopedWithH @'[AtomicState s] withResource \ lock -> \case+-- >     MState f ->+-- >       bracket_ (embed (takeMVar lock)) (embed (tryPutMVar lock ())) do+-- >         s0 <- atomicGet+-- >         res <- runTSimple (f s0)+-- >         Inspector ins <- getInspectorT+-- >         for_ (ins res) \ (s, _) -> atomicPut s+-- >         pure (snd <$> res)+-- >     MRead ->+-- >       liftT atomicGet+interpretScopedWithH ::+  ∀ extra resource param effect r r1 .+  r1 ~ (extra ++ r) =>+  KnownList extra =>+  (∀ x . param -> (resource -> Sem r1 x) -> Sem r x) ->+  (∀ r0 x . resource -> effect (Sem r0) x -> Tactical effect (Sem r0) r1 x) ->+  InterpreterFor (Scoped param effect) r+interpretScopedWithH withResource scopedHandler =+  interpretWeaving \case+    Weaving (InScope param main) s wv ex _ ->+      ex <$> withResource param \ resource -> inScope resource $+        restack+          (injectMembership+           (singList @'[Scoped param effect])+           (singList @extra)) $ wv (main <$ s)+    _ ->+      errorWithoutStackTrace "top level Run"+  where+    inScope :: resource -> InterpreterFor (Scoped param effect) r1+    inScope resource =+      interpretWeaving \case+        Weaving (InScope param main) s wv ex _ ->+          restack (extendMembershipLeft (singList @extra))+            (ex <$> withResource param \resource' ->+                inScope resource' (wv (main <$ s)))+        Weaving (Run act) s wv ex ins ->+          ex <$> runTactics s (raise . inScope resource . wv) ins (inScope resource . wv)+            (scopedHandler resource act)+{-# inline interpretScopedWithH #-}++-- | First-order variant of 'interpretScopedWithH'.+--+-- /Note/: It is necessary to specify the list of local interpreters with a type+-- application; GHC won't be able to figure them out from the type of+-- @withResource@:+--+-- > data SomeAction :: Effect where+-- >   SomeAction :: SomeAction m ()+-- >+-- > foo :: InterpreterFor (Scoped () SomeAction) r+-- > foo =+-- >   interpretScopedWith @[Reader Int, State Bool] localEffects \ () -> \case+-- >     SomeAction -> put . (> 0) =<< ask @Int+-- >   where+-- >     localEffects () use = evalState False (runReader 5 (use ()))+interpretScopedWith ::+  ∀ extra param resource effect r r1 .+  r1 ~ (extra ++ r) =>+  KnownList extra =>+  (∀ x . param -> (resource -> Sem r1 x) -> Sem r x) ->+  (∀ m x . resource -> effect m x -> Sem r1 x) ->+  InterpreterFor (Scoped param effect) r+interpretScopedWith withResource scopedHandler =+  interpretScopedWithH @extra withResource \ r e -> liftT (scopedHandler r e)+{-# inline interpretScopedWith #-}++-- | Variant of 'interpretScopedWith' in which no resource is used and the+-- resource allocator is a plain interpreter.+-- This is useful for scopes that only need local effects, but no resources in+-- the handler.+--+-- See the /Note/ on 'interpretScopedWithH'.+interpretScopedWith_ ::+  ∀ extra param effect r r1 .+  r1 ~ (extra ++ r) =>+  KnownList extra =>+  (∀ x . param -> Sem r1 x -> Sem r x) ->+  (∀ m x . effect m x -> Sem r1 x) ->+  InterpreterFor (Scoped param effect) r+interpretScopedWith_ withResource scopedHandler =+  interpretScopedWithH @extra (\ p f -> withResource p (f ())) \ () e -> liftT (scopedHandler e)+{-# inline interpretScopedWith_ #-}++-- | Variant of 'interpretScoped' that uses another interpreter instead of a+-- handler.+--+-- This is mostly useful if you want to reuse an interpreter that you cannot+-- easily rewrite (like from another library). If you have full control over the+-- implementation, 'interpretScoped' should be preferred.+--+-- /Note/: The wrapped interpreter will be executed fully, including the+-- initializing code surrounding its handler, for each action in the program, so+-- if the interpreter allocates any resources, they will be scoped to a single+-- action. Move them to @withResource@ instead.+--+-- For example, consider the following interpreter for+-- 'Polysemy.AtomicState.AtomicState':+--+-- > atomicTVar :: Member (Embed IO) r => a -> InterpreterFor (AtomicState a) r+-- > atomicTVar initial sem = do+-- >   tv <- embed (newTVarIO initial)+-- >   runAtomicStateTVar tv sem+--+-- If this interpreter were used for a scoped version of @AtomicState@ like+-- this:+--+-- > runScoped (\ initial use -> use initial) \ initial -> atomicTVar initial+--+-- Then the @TVar@ would be created every time an @AtomicState@ action is run,+-- not just when entering the scope.+--+-- The proper way to implement this would be to rewrite the resource allocation:+--+-- > runScoped (\ initial use -> use =<< embed (newTVarIO initial)) runAtomicStateTVar+runScoped ::+  ∀ resource param effect r .+  (∀ x . param -> (resource -> Sem r x) -> Sem r x) ->+  (resource -> InterpreterFor effect r) ->+  InterpreterFor (Scoped param effect) r+runScoped withResource scopedInterpreter =+  go (errorWithoutStackTrace "top level run")+  where+    go :: resource -> InterpreterFor (Scoped param effect) r+    go resource =+      interpretWeaving \ (Weaving effect s wv ex ins) -> case effect of+        Run act ->+          scopedInterpreter resource+            $ liftSem $ injWeaving $ Weaving act s (raise . go resource . wv) ex ins+        InScope param main ->+          withResource param \ resource' -> ex <$> go resource' (wv (main <$ s))+{-# inline runScoped #-}++-- | Variant of 'runScoped' in which the resource allocator returns the resource+-- rather tnen calling a continuation.+runScopedAs ::+  ∀ resource param effect r .+  (param -> Sem r resource) ->+  (resource -> InterpreterFor effect r) ->+  InterpreterFor (Scoped param effect) r+runScopedAs resource = runScoped \ p use -> use =<< resource p+{-# inline runScopedAs #-}+ -- |Combined higher-order interpreter for 'Scoped' and 'Resumable'.--- This allows 'Stop' to be sent from within the resource allocator so that the consumer receives it.+-- This allows 'Stop' to be sent from within the resource allocator so that the consumer receives it, terminating the+-- entire scope. interpretScopedResumableH ::-  ∀ resource effect err r .-  (∀ x . (resource -> Sem (Stop err : r) x) -> Sem (Stop err : r) x) ->+  ∀ param resource effect err r .+  (∀ x . param -> (resource -> Sem (Stop err : r) x) -> Sem (Stop err : r) x) ->   (∀ r0 x . resource -> effect (Sem r0) x -> Tactical effect (Sem r0) (Stop err : r) x) ->-  InterpreterFor (Scoped resource effect !! err) r+  InterpreterFor (Scoped param effect !! err) r interpretScopedResumableH withResource scopedHandler =-  run+  run (errorWithoutStackTrace "top level run")   where-    run :: InterpreterFor (Scoped resource effect !! err) r-    run =-      interpretH' \ (Weaving (Resumable inner) s' dist' ex' ins') ->+    run :: resource -> InterpreterFor (Scoped param effect !! err) r+    run resource =+      interpretWeaving \ (Weaving (Resumable inner) s' dist' ex' ins') ->         case inner of           Weaving effect s dist ex ins -> do             let               handleScoped = \case-                Run resource act ->+                Run act ->                   scopedHandler resource act-                InScope main ->-                  raise (withResource \ resource -> Compose <$> raise (run (dist' (dist (main resource <$ s) <$ s'))))+                InScope param main ->+                  raise (withResource param \ resource' -> Compose <$> raise (run resource' (dist' (dist (main <$ s) <$ s'))))               tac =                 runTactics                 (Compose (s <$ s'))-                (raise . raise . run . fmap Compose . dist' . fmap dist . getCompose)+                (raise . raise . run resource . fmap Compose . dist' . fmap dist . getCompose)                 (ins <=< ins' . getCompose)-                (raise . run . fmap Compose . dist' . fmap dist . getCompose)+                (raise . run resource . fmap Compose . dist' . fmap dist . getCompose)                 (handleScoped effect)               exFinal = ex' . \case                 Right (Compose a) -> Right . ex <$> a@@ -124,128 +325,417 @@             exFinal <$> runStop tac  -- |Combined interpreter for 'Scoped' and 'Resumable'.--- This allows 'Stop' to be sent from within the resource allocator so that the consumer receives it.+-- This allows 'Stop' to be sent from within the resource allocator so that the consumer receives it, terminating the+-- entire scope. interpretScopedResumable ::-  ∀ resource effect err r .-  (∀ x . (resource -> Sem (Stop err : r) x) -> Sem (Stop err : r) x) ->+  ∀ param resource effect err r .+  (∀ x . param -> (resource -> Sem (Stop err : r) x) -> Sem (Stop err : r) x) ->   (∀ r0 x . resource -> effect (Sem r0) x -> Sem (Stop err : r) x) ->-  InterpreterFor (Scoped resource effect !! err) r+  InterpreterFor (Scoped param effect !! err) r interpretScopedResumable withResource scopedHandler =   interpretScopedResumableH withResource \ r e -> liftT (scopedHandler r e) -interpretScopedWithH ::-  ∀ extra resource effect r r1 .-  r1 ~ (extra ++ r) =>-  InsertAtIndex 1 '[Scoped resource effect] r1 r (Scoped resource effect : r1) extra =>-  (∀ x . (resource -> Sem r1 x) -> Sem r x) ->-  (∀ m x . resource -> effect m x -> Tactical effect m r1 x) ->-  InterpreterFor (Scoped resource effect) r-interpretScopedWithH withResource scopedHandler =-  interpretH' \case-    Weaving (InScope main) s wv ex _ ->-      ex <$> withResource \ resource -> inScope (insertAt @1 @extra (wv (main resource <$ s)))-    _ ->-      error "top level Run"-  where-    inScope :: InterpreterFor (Scoped resource effect) r1-    inScope =-      interpretH' \case-        Weaving (Run resource act) s wv ex ins ->-          ex <$> runTactics s (raise . inScope . wv) ins (inScope . wv) (scopedHandler resource act)-        _ ->-          error "nested InScope"--interpretScopedWith ::-  ∀ extra resource effect r r1 .-  r1 ~ (extra ++ r) =>-  InsertAtIndex 1 '[Scoped resource effect] r1 r (Scoped resource effect : r1) extra =>-  (∀ x . (resource -> Sem r1 x) -> Sem r x) ->-  (∀ m x . resource -> effect m x -> Sem r1 x) ->-  InterpreterFor (Scoped resource effect) r-interpretScopedWith withResource scopedHandler =-  interpretScopedWithH @extra withResource \ r e -> liftT (scopedHandler r e)--interpretScopedWith_ ::-  ∀ extra effect r r1 .-  r1 ~ (extra ++ r) =>-  InsertAtIndex 1 '[Scoped () effect] r1 r (Scoped () effect : r1) extra =>-  (∀ x . Sem r1 x -> Sem r x) ->-  (∀ m x . effect m x -> Sem r1 x) ->-  InterpreterFor (Scoped () effect) r-interpretScopedWith_ withResource scopedHandler =-  interpretScopedWithH @extra (\ f -> withResource (f ())) \ () e -> liftT (scopedHandler e)+-- |Combined interpreter for 'Scoped' and 'Resumable'.+-- This allows 'Stop' to be sent from within the resource allocator so that the consumer receives it, terminating the+-- entire scope.+-- In this variant, the resource allocator is a plain action.+interpretScopedResumable_ ::+  ∀ param resource effect err r .+  (param -> Sem (Stop err : r) resource) ->+  (∀ r0 x . resource -> effect (Sem r0) x -> Sem (Stop err : r) x) ->+  InterpreterFor (Scoped param effect !! err) r+interpretScopedResumable_ resource =+  interpretScopedResumable \ p use -> use =<< resource p +-- |Combined higher-order interpreter for 'Scoped' and 'Resumable' that allows the handler to use additional effects+-- that are interpreted by the resource allocator.+-- This allows 'Stop' to be sent from within the resource allocator so that the consumer receives it, terminating the+-- entire scope. interpretScopedResumableWithH ::-  ∀ extra resource effect err r r1 .+  ∀ extra param resource effect err r r1 .+  r1 ~ (extra ++ (Stop err : r)) =>   r1 ~ ((extra ++ '[Stop err]) ++ r) =>-  InsertAtIndex 1 '[Scoped resource effect !! err] r1 r (Scoped resource effect !! err : r1) (extra ++ '[Stop err]) =>-  (∀ x . (resource -> Sem r1 x) -> Sem (Stop err : r) x) ->+  KnownList extra =>+  KnownList (extra ++ '[Stop err]) =>+  (∀ x . param -> (resource -> Sem r1 x) -> Sem (Stop err : r) x) ->   (∀ r0 x . resource -> effect (Sem r0) x -> Tactical effect (Sem r0) r1 x) ->-  InterpreterFor (Scoped resource effect !! err) r+  InterpreterFor (Scoped param effect !! err) r interpretScopedResumableWithH withResource scopedHandler =-  run+  run (errorWithoutStackTrace "top level run")   where-    run :: InterpreterFor (Scoped resource effect !! err) r-    run =-      interpretH' \ (Weaving (Resumable inner) s' dist' ex' ins') ->+    run :: resource -> InterpreterFor (Scoped param effect !! err) r+    run resource =+      interpretWeaving \ (Weaving (Resumable inner) s' dist' ex' ins') ->         case inner of           Weaving effect s dist ex ins -> do             let               handleScoped = \case-                Run _ _ ->+                Run _ ->                   error "top level Run"-                InScope main ->-                  raise (withResource \ resource -> Compose <$> inScope (insertAt @1 @(extra ++ '[Stop err]) (dist' (dist (main resource <$ s) <$ s'))))+                InScope param main ->+                  raise $ withResource param \ resource' ->+                    Compose <$> inScope resource' (restack (injectMembership (singList @'[Scoped param effect !! err]) (singList @(extra ++ '[Stop err]))) (dist' (dist (main <$ s) <$ s')))               tac =                 runTactics                 (Compose (s <$ s'))-                (raise . raise . run . fmap Compose . dist' . fmap dist . getCompose)+                (raise . raise . run resource . fmap Compose . dist' . fmap dist . getCompose)                 (ins <=< ins' . getCompose)-                (raise . run . fmap Compose . dist' . fmap dist . getCompose)+                (raise . run resource . fmap Compose . dist' . fmap dist . getCompose)                 (handleScoped effect)               exFinal = ex' . \case                 Right (Compose a) -> Right . ex <$> a                 Left err -> Left err <$ s'             exFinal <$> runStop tac-    inScope :: InterpreterFor (Scoped resource effect !! err) r1-    inScope =-      interpretH' \ (Weaving (Resumable inner) s' dist' ex' ins') ->+    inScope :: resource -> InterpreterFor (Scoped param effect !! err) r1+    inScope resource =+      interpretWeaving \ (Weaving (Resumable inner) s' dist' ex' ins') ->         case inner of           Weaving effect s dist ex ins -> do             let               handleScoped = \case-                Run resource act ->+                Run act ->                   scopedHandler resource act-                InScope _ ->-                  error "nested InScope"+                InScope param main ->+                  raise $ restack (extendMembershipLeft (singList @extra)) $ withResource param \ resource' ->+                    Compose <$> inScope resource' (dist' (dist (main <$ s) <$ s'))               tac =                 runTactics                 (Compose (s <$ s'))-                (raise . inScope . fmap Compose . dist' . fmap dist . getCompose)+                (raise . inScope resource . fmap Compose . dist' . fmap dist . getCompose)                 (ins <=< ins' . getCompose)-                (inScope . fmap Compose . dist' . fmap dist . getCompose)+                (inScope resource . fmap Compose . dist' . fmap dist . getCompose)                 (handleScoped effect)               exFinal = ex' . \case                 Right (Compose a) -> Right . ex <$> a                 Left err -> Left err <$ s'             exFinal <$> runStop (raise tac) +-- |Combined interpreter for 'Scoped' and 'Resumable' that allows the handler to use additional effects that are+-- interpreted by the resource allocator.+-- This allows 'Stop' to be sent from within the resource allocator so that the consumer receives it, terminating the+-- entire scope. interpretScopedResumableWith ::-  ∀ extra resource effect err r r1 .+  ∀ extra param resource effect err r r1 .+  r1 ~ (extra ++ (Stop err : r)) =>   r1 ~ ((extra ++ '[Stop err]) ++ r) =>-  InsertAtIndex 1 '[Scoped resource effect !! err] r1 r (Scoped resource effect !! err : r1) (extra ++ '[Stop err]) =>-  (∀ x . (resource -> Sem r1 x) -> Sem (Stop err : r) x) ->+  KnownList extra =>+  KnownList (extra ++ '[Stop err]) =>+  (∀ x . param -> (resource -> Sem r1 x) -> Sem (Stop err : r) x) ->   (∀ r0 x . resource -> effect (Sem r0) x -> Sem r1 x) ->-  InterpreterFor (Scoped resource effect !! err) r+  InterpreterFor (Scoped param effect !! err) r interpretScopedResumableWith withResource scopedHandler =   interpretScopedResumableWithH @extra withResource \ r e -> liftT (scopedHandler r e) +-- |Combined interpreter for 'Scoped' and 'Resumable' that allows the handler to use additional effects that are+-- interpreted by the resource allocator.+-- This allows 'Stop' to be sent from within the resource allocator so that the consumer receives it, terminating the+-- entire scope.+-- In this variant, no resource is used and the allocator is a plain interpreter. interpretScopedResumableWith_ ::-  ∀ extra effect err r r1 .+  ∀ extra param effect err r r1 .+  r1 ~ (extra ++ (Stop err : r)) =>   r1 ~ ((extra ++ '[Stop err]) ++ r) =>-  InsertAtIndex 1 '[Scoped () effect !! err] r1 r (Scoped () effect !! err : r1) (extra ++ '[Stop err]) =>-  (∀ x . Sem r1 x -> Sem (Stop err : r) x) ->+  KnownList extra =>+  KnownList (extra ++ '[Stop err]) =>+  (∀ x . param -> Sem r1 x -> Sem (Stop err : r) x) ->   (∀ r0 x . effect (Sem r0) x -> Sem r1 x) ->-  InterpreterFor (Scoped () effect !! err) r-interpretScopedResumableWith_ withResource scopedHandler =-  interpretScopedResumableWith @extra (\ f -> withResource (f ())) (const scopedHandler)+  InterpreterFor (Scoped param effect !! err) r+interpretScopedResumableWith_ extra scopedHandler =+  interpretScopedResumableWith @extra (\ p f -> extra p (f ())) (const scopedHandler)++-- |Combined higher-order interpreter for 'Resumable' and 'Scoped'.+-- In this variant, only the handler may send 'Stop', but this allows resumption to happen on each action inside of the+-- scope.+interpretResumableScopedH ::+  ∀ param resource effect err r .+  (∀ x . param -> (resource -> Sem r x) -> Sem r x) ->+  (∀ r0 x . resource -> effect (Sem r0) x -> Tactical effect (Sem r0) (Stop err : r) x) ->+  InterpreterFor (Scoped param (effect !! err)) r+interpretResumableScopedH withResource scopedHandler =+  run (errorWithoutStackTrace "top level run")+  where+    run :: resource -> InterpreterFor (Scoped param (effect !! err)) r+    run resource =+      interpretWeaving \ (Weaving inner s' dist' ex' ins') -> case inner of+        Run (Resumable (Weaving effect s dist ex ins)) ->+          exFinal <$> runStop (tac (scopedHandler resource effect))+          where+            tac =+              runTactics+              (Compose (s <$ s'))+              (raise . raise . run resource . fmap Compose . dist' . fmap dist . getCompose)+              (ins <=< ins' . getCompose)+              (raise . run resource . fmap Compose . dist' . fmap dist . getCompose)+            exFinal = ex' . \case+              Right (Compose a) -> Right . ex <$> a+              Left err -> Left err <$ s'+        InScope param main ->+          ex' <$> withResource param \ resource' -> run resource' (dist' (main <$ s'))++-- |Combined interpreter for 'Resumable' and 'Scoped'.+-- In this variant, only the handler may send 'Stop', but this allows resumption to happen on each action inside of the+-- scope.+interpretResumableScoped ::+  ∀ param resource effect err r .+  (∀ x . param -> (resource -> Sem r x) -> Sem r x) ->+  (∀ r0 x . resource -> effect (Sem r0) x -> Sem (Stop err : r) x) ->+  InterpreterFor (Scoped param (effect !! err)) r+interpretResumableScoped withResource scopedHandler =+  interpretResumableScopedH withResource \ r e -> liftT (scopedHandler r e)++-- |Combined interpreter for 'Resumable' and 'Scoped'.+-- In this variant:+-- - Only the handler may send 'Stop', but this allows resumption to happen on each action inside of the scope.+-- - The resource allocator is a plain action.+interpretResumableScoped_ ::+  ∀ param resource effect err r .+  (param -> Sem r resource) ->+  (∀ r0 x . resource -> effect (Sem r0) x -> Sem (Stop err : r) x) ->+  InterpreterFor (Scoped param (effect !! err)) r+interpretResumableScoped_ resource =+  interpretResumableScoped \ p use -> use =<< resource p++-- |Combined higher-order interpreter for 'Resumable' and 'Scoped' that allows the handler to use additional effects+-- that are interpreted by the resource allocator.+-- In this variant, only the handler may send 'Stop', but this allows resumption to happen on each action inside of the+-- scope.+interpretResumableScopedWithH ::+  ∀ extra param resource effect err r r1 .+  r1 ~ (extra ++ r) =>+  KnownList extra =>+  (∀ x . param -> (resource -> Sem r1 x) -> Sem r x) ->+  (∀ r0 x . resource -> effect (Sem r0) x -> Tactical effect (Sem r0) (Stop err : r1) x) ->+  InterpreterFor (Scoped param (effect !! err)) r+interpretResumableScopedWithH withResource scopedHandler =+  interpretWeaving \case+    Weaving (InScope param main) s dist ex _ ->+      ex <$> withResource param \ resource' -> inScope resource' (restack (injectMembership (singList @'[Scoped param (effect !! err)]) (singList @extra)) (dist (main <$ s)))+    _ ->+      errorWithoutStackTrace "top level run"+  where+    inScope :: resource -> InterpreterFor (Scoped param (effect !! err)) r1+    inScope resource =+      interpretWeaving \case+        Weaving (Run (Resumable (Weaving effect s dist ex ins))) s' dist' ex' ins' ->+          exFinal <$> runStop (tac (scopedHandler resource effect))+          where+            tac =+              runTactics+              (Compose (s <$ s'))+              (raise . raise . inScope resource . fmap Compose . dist' . fmap dist . getCompose)+              (ins <=< ins' . getCompose)+              (raise . inScope resource . fmap Compose . dist' . fmap dist . getCompose)+            exFinal = ex' . \case+              Right (Compose a) -> Right . ex <$> a+              Left err -> Left err <$ s'+        Weaving (InScope param main) s wv ex _ ->+          restack (extendMembershipLeft (singList @extra)) (ex <$> withResource param \ resource' -> inScope resource' (wv (main <$ s)))++-- |Combined interpreter for 'Resumable' and 'Scoped' that allows the handler to use additional effects that are+-- interpreted by the resource allocator.+-- In this variant, only the handler may send 'Stop', but this allows resumption to happen on each action inside of the+-- scope.+interpretResumableScopedWith ::+  ∀ extra param resource effect err r r1 .+  r1 ~ (extra ++ r) =>+  KnownList extra =>+  (∀ x . param -> (resource -> Sem r1 x) -> Sem r x) ->+  (∀ r0 x . resource -> effect (Sem r0) x -> Sem (Stop err : r1) x) ->+  InterpreterFor (Scoped param (effect !! err)) r+interpretResumableScopedWith withResource scopedHandler =+  interpretResumableScopedWithH @extra withResource \ r e -> liftT (scopedHandler r e)++-- |Combined interpreter for 'Resumable' and 'Scoped' that allows the handler to use additional effects that are+-- interpreted by the resource allocator.+-- In this variant:+-- - Only the handler may send 'Stop', but this allows resumption to happen on each action inside of the scope.+-- - No resource is used and the allocator is a plain interpreter.+interpretResumableScopedWith_ ::+  ∀ extra param effect err r r1 .+  r1 ~ (extra ++ r) =>+  KnownList extra =>+  (∀ x . param -> Sem r1 x -> Sem r x) ->+  (∀ r0 x . effect (Sem r0) x -> Sem (Stop err : r1) x) ->+  InterpreterFor (Scoped param (effect !! err)) r+interpretResumableScopedWith_ extra scopedHandler =+  interpretResumableScopedWith @extra @param @() @effect @err @r @r1 (\ p f -> extra p (f ())) (const scopedHandler)++-- |Combined higher-order interpreter for 'Resumable' and 'Scoped'.+-- In this variant, both the handler and the scope may send different errors via 'Stop', encoding the concept that the+-- resource allocation may fail to prevent the scope from being executed, and each individual scoped action may fail,+-- continuing the scope execution on resumption.+interpretScopedRH ::+  ∀ param resource effect eo ei r .+  (∀ x . param -> (resource -> Sem (Stop eo : r) x) -> Sem (Stop eo : r) x) ->+  (∀ r0 x . resource -> effect (Sem r0) x -> Tactical effect (Sem r0) (Stop ei : r) x) ->+  InterpreterFor (Scoped param (effect !! ei) !! eo) r+interpretScopedRH withResource scopedHandler =+  run (errorWithoutStackTrace "top level run")+  where+    run :: resource -> InterpreterFor (Scoped param (effect !! ei) !! eo) r+    run resource =+      interpretWeaving \ (Weaving (Resumable (Weaving inner s' dist' ex' ins')) s'' dist'' ex'' ins'') -> case inner of+        Run (Resumable (Weaving effect s dist ex ins)) ->+          exFinal <$> runStop @ei (tac (scopedHandler resource effect))+          where+            tac =+              runTactics+              (Compose (Compose (s <$ s') <$ s''))+              (raise . raise . run resource . fmap Compose . fmap (fmap Compose) . dist'' . fmap dist' . fmap (fmap dist . getCompose) . getCompose)+              (ins <=< ins' . getCompose <=< ins'' . getCompose)+              (raise . run resource . fmap Compose . fmap (fmap Compose) . dist'' . fmap dist' . fmap (fmap dist . getCompose) . getCompose)+            exFinal = \case+              Right (Compose fffa) ->+                ex'' $ fffa <&> Right . \ (Compose ffa) ->+                  ex' (Right . ex <$> ffa)+              Left err ->+                ex'' (Right (ex' (Left err <$ s')) <$ s'')+        InScope param main -> do+          let+            inScope =+                raise (withResource param \ resource' -> Compose <$> raise (run resource' (dist'' (dist' (main <$ s') <$ s''))))+            tac =+              runTactics+              (Compose (s' <$ s''))+              (raise . raise . run resource . fmap Compose . dist'' . fmap dist' . getCompose)+              (ins' <=< ins'' . getCompose)+              (raise . run resource . fmap Compose . dist'' . fmap dist' . getCompose)+              inScope+            exFinal = ex'' . \case+              Right (Compose a) -> Right . ex' <$> a+              Left err -> Left err <$ s''+          exFinal <$> runStop tac++-- |Combined interpreter for 'Scoped' and 'Resumable'.+-- In this variant, both the handler and the scope may send different errors via 'Stop', encoding the concept that the+-- resource allocation may fail to prevent the scope from being executed, and each individual scoped action may fail,+-- continuing the scope execution on resumption.+interpretScopedR ::+  ∀ param resource effect eo ei r .+  (∀ x . param -> (resource -> Sem (Stop eo : r) x) -> Sem (Stop eo : r) x) ->+  (∀ r0 x . resource -> effect (Sem r0) x -> Sem (Stop ei : r) x) ->+  InterpreterFor (Scoped param (effect !! ei) !! eo) r+interpretScopedR withResource scopedHandler =+  interpretScopedRH withResource \ r e -> liftT (scopedHandler r e)++-- |Combined interpreter for 'Scoped' and 'Resumable'.+-- In this variant:+-- - Both the handler and the scope may send different errors via 'Stop', encoding the concept that the+--   resource allocation may fail to prevent the scope from being executed, and each individual scoped action may fail,+--   continuing the scope execution on resumption.+-- - The resource allocator is a plain action.+interpretScopedR_ ::+  ∀ param resource effect eo ei r .+  (param -> Sem (Stop eo : r) resource) ->+  (∀ r0 x . resource -> effect (Sem r0) x -> Sem (Stop ei : r) x) ->+  InterpreterFor (Scoped param (effect !! ei) !! eo) r+interpretScopedR_ resource =+  interpretScopedR \ p use -> use =<< resource p++-- |Combined higher-order interpreter for 'Scoped' and 'Resumable' that allows the handler to use additional effects+-- that are interpreted by the resource allocator.+-- In this variant, both the handler and the scope may send different errors via 'Stop', encoding the concept that the+-- resource allocation may fail to prevent the scope from being executed, and each individual scoped action may fail,+-- continuing the scope execution on resumption.+interpretScopedRWithH ::+  ∀ extra param resource effect eo ei r r1 .+  r1 ~ (extra ++ Stop eo : r) =>+  r1 ~ ((extra ++ '[Stop eo]) ++ r) =>+  KnownList extra =>+  KnownList (extra ++ '[Stop eo]) =>+  (∀ x . param -> (resource -> Sem r1 x) -> Sem (Stop eo : r) x) ->+  (∀ r0 x . resource -> effect (Sem r0) x -> Tactical effect (Sem r0) (Stop ei : r1) x) ->+  InterpreterFor (Scoped param (effect !! ei) !! eo) r+interpretScopedRWithH withResource scopedHandler =+  run+  where+    run :: InterpreterFor (Scoped param (effect !! ei) !! eo) r+    run =+      interpretWeaving \ (Weaving (Resumable (Weaving inner s' dist' ex' ins')) s'' dist'' ex'' ins'') -> case inner of+        InScope param main -> do+            let+              ma =+                  raise $ withResource param \ resource ->+                    Compose <$> inScope resource (restack (injectMembership (singList @'[Scoped param (effect !! ei) !! eo]) (singList @(extra ++ '[Stop eo]))) (dist'' (dist' (main <$ s') <$ s'')))+              tac =+                runTactics+                (Compose (s' <$ s''))+                (raise . raise . run . fmap Compose . dist'' . fmap dist' . getCompose)+                (ins' <=< ins'' . getCompose)+                (raise . run . fmap Compose . dist'' . fmap dist' . getCompose)+                ma+              exFinal = ex'' . \case+                Right (Compose a) -> Right . ex' <$> a+                Left err -> Left err <$ s''+            exFinal <$> runStop tac+        _ ->+          error "top level Run"+    inScope :: resource -> InterpreterFor (Scoped param (effect !! ei) !! eo) r1+    inScope resource =+      interpretWeaving \ (Weaving (Resumable (Weaving inner s' dist' ex' ins')) s'' dist'' ex'' ins'') -> case inner of+        Run (Resumable (Weaving effect s dist ex ins)) ->+          exFinal <$> runStop @ei (tac (scopedHandler resource effect))+          where+            tac =+              runTactics+              (Compose (Compose (s <$ s') <$ s''))+              (raise . raise . inScope resource . fmap Compose . fmap (fmap Compose) . dist'' . fmap dist' . fmap (fmap dist . getCompose) . getCompose)+              (ins <=< ins' . getCompose <=< ins'' . getCompose)+              (raise . inScope resource . fmap Compose . fmap (fmap Compose) . dist'' . fmap dist' . fmap (fmap dist . getCompose) . getCompose)+            exFinal = \case+              Right (Compose fffa) ->+                ex'' $ fffa <&> Right . \ (Compose ffa) ->+                  ex' (Right . ex <$> ffa)+              Left err ->+                ex'' (Right (ex' (Left err <$ s')) <$ s'')+        InScope param main -> do+            let+              ma =+                raise $ restack (extendMembershipLeft (singList @(Stop eo : extra))) $ withResource param \ resource' ->+                  Compose <$> inScope resource' (dist'' (dist' (main <$ s') <$ s''))+              tac =+                runTactics+                (Compose (s' <$ s''))+                (raise . raise . inScope resource . fmap Compose . dist'' . fmap dist' . getCompose)+                (ins' <=< ins'' . getCompose)+                (raise . inScope resource . fmap Compose . dist'' . fmap dist' . getCompose)+                ma+              exFinal = ex'' . \case+                Right (Compose a) -> Right . ex' <$> a+                Left err -> Left err <$ s''+            exFinal <$> runStop tac++-- |Combined interpreter for 'Scoped' and 'Resumable' that allows the handler to use additional effects that are+-- interpreted by the resource allocator.+-- In this variant, both the handler and the scope may send different errors via 'Stop', encoding the concept that the+-- resource allocation may fail to prevent the scope from being executed, and each individual scoped action may fail,+-- continuing the scope execution on resumption.+interpretScopedRWith ::+  ∀ extra param resource effect eo ei r r1 .+  r1 ~ (extra ++ Stop eo : r) =>+  r1 ~ ((extra ++ '[Stop eo]) ++ r) =>+  KnownList extra =>+  KnownList (extra ++ '[Stop eo]) =>+  (∀ x . param -> (resource -> Sem r1 x) -> Sem (Stop eo : r) x) ->+  (∀ r0 x . resource -> effect (Sem r0) x -> Sem (Stop ei : r1) x) ->+  InterpreterFor (Scoped param (effect !! ei) !! eo) r+interpretScopedRWith withResource scopedHandler =+  interpretScopedRWithH @extra withResource \ r e -> liftT (scopedHandler r e)++-- |Combined interpreter for 'Scoped' and 'Resumable' that allows the handler to use additional effects that are+-- interpreted by the resource allocator.+-- - Both the handler and the scope may send different errors via 'Stop', encoding the concept that the+--   resource allocation may fail to prevent the scope from being executed, and each individual scoped action may fail,+--   continuing the scope execution on resumption.+-- - The resource allocator is a plain action.+interpretScopedRWith_ ::+  ∀ extra param effect eo ei r r1 .+  r1 ~ (extra ++ Stop eo : r) =>+  r1 ~ ((extra ++ '[Stop eo]) ++ r) =>+  KnownList extra =>+  KnownList (extra ++ '[Stop eo]) =>+  (∀ x . param -> Sem r1 x -> Sem (Stop eo : r) x) ->+  (∀ r0 x . effect (Sem r0) x -> Sem (Stop ei : r1) x) ->+  InterpreterFor (Scoped param (effect !! ei) !! eo) r+interpretScopedRWith_ extra scopedHandler =+  interpretScopedRWith @extra (\ p f -> extra p (f ())) (const scopedHandler)

@@ -0,0 +1,55 @@+-- |Semaphore interpreters, Internal.+module Polysemy.Conc.Interpreter.Semaphore where++import Control.Concurrent (QSem, newQSem, signalQSem, waitQSem)+import Control.Concurrent.STM (atomically)+import Control.Concurrent.STM.TSem (TSem, newTSem, signalTSem, waitTSem)++import qualified Polysemy.Conc.Effect.Semaphore as Semaphore+import Polysemy.Conc.Effect.Semaphore (Semaphore)++-- |Interpret 'Semaphore' using the supplied 'QSem'.+interpretSemaphoreQWith ::+  Member (Embed IO) r =>+  QSem ->+  InterpreterFor Semaphore r+interpretSemaphoreQWith qsem =+  interpret \case+    Semaphore.Wait ->+      embed (waitQSem qsem)+    Semaphore.Signal ->+      embed (signalQSem qsem)+{-# inline interpretSemaphoreQWith #-}++-- |Interpret 'Semaphore' as a 'QSem'.+interpretSemaphoreQ ::+  Member (Embed IO) r =>+  Int ->+  InterpreterFor Semaphore r+interpretSemaphoreQ n sem = do+  qsem <- embed (newQSem n)+  interpretSemaphoreQWith qsem sem+{-# inline interpretSemaphoreQ #-}++-- |Interpret 'Semaphore' using the supplied 'TSem'.+interpretSemaphoreTWith ::+  Member (Embed IO) r =>+  TSem ->+  InterpreterFor Semaphore r+interpretSemaphoreTWith qsem =+  interpret \case+    Semaphore.Wait ->+      embed (atomically (waitTSem qsem))+    Semaphore.Signal ->+      embed (atomically (signalTSem qsem))+{-# inline interpretSemaphoreTWith #-}++-- |Interpret 'Semaphore' as a 'TSem'.+interpretSemaphoreT ::+  Member (Embed IO) r =>+  Integer ->+  InterpreterFor Semaphore r+interpretSemaphoreT n sem = do+  qsem <- embed (atomically (newTSem n))+  interpretSemaphoreTWith qsem sem+{-# inline interpretSemaphoreT #-}

@@ -3,16 +3,19 @@ -- |Description: Convenience Interpreters for all Conc Effects, Internal module Polysemy.Conc.Interpreter.Stack where +import Polysemy.Conc.Effect.Gate (Gates) import Polysemy.Conc.Effect.Mask (Mask, UninterruptibleMask) import Polysemy.Conc.Effect.Race (Race)-import Polysemy.Conc.Interpreter.Mask (Restoration, interpretMaskFinal, interpretUninterruptibleMaskFinal)+import Polysemy.Conc.Interpreter.Gate (interpretGates)+import Polysemy.Conc.Interpreter.Mask (interpretMaskFinal, interpretUninterruptibleMaskFinal) import Polysemy.Conc.Interpreter.Race (interpretRace)  -- |A default basic stack with 'Final' for _polysemy-conc_. type ConcStack =   [-    UninterruptibleMask Restoration,-    Mask Restoration,+    UninterruptibleMask,+    Mask,+    Gates,     Race,     Async,     Resource,@@ -31,5 +34,6 @@   resourceToIOFinal .   asyncToIOFinal .   interpretRace .+  interpretGates .   interpretMaskFinal .   interpretUninterruptibleMaskFinal

@@ -2,9 +2,9 @@ module Polysemy.Conc.Interpreter.Sync where  import Polysemy.Conc.Effect.Race (Race)-import Polysemy.Conc.Effect.Scoped (Scoped)+import Polysemy.Conc.Effect.Scoped (Scoped_) import qualified Polysemy.Conc.Effect.Sync as Sync-import Polysemy.Conc.Effect.Sync (Sync, SyncResources (SyncResources), unSyncResources)+import Polysemy.Conc.Effect.Sync (Sync) import Polysemy.Conc.Interpreter.Scoped (runScopedAs) import qualified Polysemy.Conc.Race as Race @@ -60,15 +60,15 @@ interpretScopedSync ::   ∀ d r .   Members [Resource, Race, Embed IO] r =>-  InterpreterFor (Scoped (SyncResources (MVar d)) (Sync d)) r+  InterpreterFor (Scoped_ (Sync d)) r interpretScopedSync =-  runScopedAs (SyncResources <$> embed newEmptyMVar) \ r -> interpretSyncWith (unSyncResources r)+  runScopedAs (const (embed newEmptyMVar)) \ r -> interpretSyncWith r  -- |Interpret 'Sync' for locally scoped use with an 'MVar' containing the specified value. interpretScopedSyncAs ::   ∀ d r .   Members [Resource, Race, Embed IO] r =>   d ->-  InterpreterFor (Scoped (SyncResources (MVar d)) (Sync d)) r+  InterpreterFor (Scoped_ (Sync d)) r interpretScopedSyncAs d =-  runScopedAs (SyncResources <$> embed (newMVar d)) \ r -> interpretSyncWith (unSyncResources r)+  runScopedAs (const (embed (newMVar d))) \ r -> interpretSyncWith r

@@ -3,8 +3,10 @@ module Polysemy.Conc.Queue (   module Polysemy.Conc.Queue,   module Polysemy.Conc.Effect.Queue,+  module Polysemy.Conc.Data.QueueResult, ) where +import Polysemy.Conc.Data.QueueResult import qualified Polysemy.Conc.Data.QueueResult as QueueResult import qualified Polysemy.Conc.Effect.Queue as Queue import Polysemy.Conc.Effect.Queue (@@ -50,10 +52,18 @@ loop action =   loopOr (pure True) \ d -> True <$ action d --- |Read from a 'Queue' and convert the result to 'Maybe', returning 'Nothing' if there is no element available or the--- queue has been closed.+-- |Read from a 'Queue' and convert the result to 'Maybe', returning 'Nothing' if the queue has been closed, and+-- blocking until an element is available. readMaybe ::   Member (Queue d) r =>   Sem r (Maybe d) readMaybe =   resultToMaybe <$> read++-- |Read from a 'Queue' and convert the result to 'Maybe', returning 'Nothing' if there is no element available or the+-- queue has been closed.+tryReadMaybe ::+  Member (Queue d) r =>+  Sem r (Maybe d)+tryReadMaybe =+  resultToMaybe <$> tryRead

@@ -5,8 +5,9 @@  import qualified Polysemy.Conc.Effect.Race as Race import Polysemy.Conc.Effect.Race (Race)+import Polysemy.Resume (Stop, stop) --- |Specialization of 'Race.race' for the case where both thunks return the same type, obviating the need for 'Either'.+-- |Specialization of 'Race.race' for the case where both actions return the same type, obviating the need for 'Either'. race_ ::   Member Race r =>   Sem r a ->@@ -16,8 +17,8 @@   unify <$> Race.race ml mr {-# inline race_ #-} --- |Specialization of 'Race.timeout' for the case where the thunk return the same type as the fallback, obviating the--- need for 'Either'.+-- |Specialization of 'Race.timeout' for the case where the main action returns the same type as the fallback, obviating+-- the need for 'Either'. timeout_ ::   TimeUnit u =>   Member Race r =>@@ -41,7 +42,7 @@   Race.timeout (pure err) {-# inline timeoutAs #-} --- |Specialization of 'timeoutAs' for the case where the thunk return the same type as the fallback, obviating the+-- |Specialization of 'timeoutAs' for the case where the main action return the same type as the fallback, obviating the -- need for 'Either'. timeoutAs_ ::   TimeUnit u =>@@ -76,3 +77,14 @@   timeoutAs_ Nothing u (Just <$> ma) {-# inline timeoutMaybe #-} +-- |Variant of 'Race.timeout' that calls 'Stop' with the supplied error when the action times out.+timeoutStop ::+  TimeUnit u =>+  Members [Race, Stop err] r =>+  err ->+  u ->+  Sem r a ->+  Sem r a+timeoutStop err =+  timeout_ (stop err)+{-# inline timeoutStop #-}

@@ -0,0 +1,11 @@+-- |A quantity semaphore effect.+module Polysemy.Conc.Semaphore (+  Semaphore,+  interpretSemaphoreQ,+  interpretSemaphoreT,+  signal,+  wait,+) where++import Polysemy.Conc.Effect.Semaphore (Semaphore, signal, wait)+import Polysemy.Conc.Interpreter.Semaphore (interpretSemaphoreQ, interpretSemaphoreT)

@@ -10,23 +10,9 @@ import Polysemy.Time (Time, TimeUnit)  import Polysemy.Conc.Effect.Mask (Mask, mask, restore)-import Polysemy.Conc.Effect.Scoped (scoped)+import Polysemy.Conc.Effect.Scoped (scoped_) import qualified Polysemy.Conc.Effect.Sync as Sync-import Polysemy.Conc.Effect.Sync (-  ScopedSync,-  Sync,-  SyncResources,-  block,-  empty,-  putBlock,-  putTry,-  putWait,-  takeBlock,-  takeTry,-  takeWait,-  try,-  wait,-  )+import Polysemy.Conc.Effect.Sync  -- |Run an action repeatedly until the 'Sync' variable is available. whileEmpty ::@@ -57,13 +43,14 @@       whenM (not <$> Sync.empty @a) (Time.sleep @t @d interval *> spin)  -- |Run an action with a locally scoped 'Sync' variable.+-- -- This avoids a dependency on @'Embed' 'IO'@ in application logic while still allowing the variable to be scoped. withSync ::-  ∀ d res r .-  Member (ScopedSync res d) r =>+  ∀ d r .+  Member (ScopedSync d) r =>   InterpreterFor (Sync d) r withSync =-  scoped @(SyncResources res)+  scoped_  -- |Run the action @ma@ with an exclusive lock (mutex). -- When multiple threads call the action concurrently, only one is allowed to execute it at a time.@@ -94,12 +81,12 @@ -- 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 b r .+  Members [Sync a, Mask, Resource] r =>   (a -> Sem r (a, b)) ->   Sem r b modify m =-  mask @res do+  mask do     a <- takeBlock     (a', b) <- onException (restore (raise (m a))) (putBlock a)     b <$ putBlock a'@@ -109,12 +96,12 @@ -- 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 r .+  Members [Sync a, Mask, Resource] r =>   (a -> Sem r a) ->   Sem r () modify_ m =-  mask @res do+  mask do     a <- takeBlock     a' <- onException (restore (raise (m a))) (putBlock a)     putBlock a'@@ -124,12 +111,12 @@ -- 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 b r .+  Members [Sync a, Mask, Resource] r =>   (a -> Sem r (a, b)) ->   Sem r b modifyMasked m =-  mask @res do+  mask do     a <- takeBlock     (a', b) <- onException (raise (m a)) (putBlock a)     b <$ putBlock a'@@ -139,12 +126,12 @@ -- 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 r .+  Members [Sync a, Mask, Resource] r =>   (a -> Sem r a) ->   Sem r () modifyMasked_ m =-  mask @res do+  mask do     a <- takeBlock     a' <- onException (raise (m a)) (putBlock a)     putBlock a'@@ -154,12 +141,12 @@ -- but not the action. -- Equivalent to 'Control.Concurrent.MVar.withMVar'. use ::-  ∀ a b res r .-  Members [Sync a, Mask res, Resource] r =>+  ∀ a b r .+  Members [Sync a, Mask, Resource] r =>   (a -> Sem r b) ->   Sem r b use m =-  mask @res do+  mask do     a <- takeBlock     finally (restore (raise (m a))) (putBlock a) {-# inline use #-}@@ -167,12 +154,12 @@ -- |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 b r .+  Members [Sync a, Mask, Resource] r =>   (a -> Sem r b) ->   Sem r b useMasked m =-  mask @res do+  mask do     a <- takeBlock     finally (raise (m a)) (putBlock a) {-# inline useMasked #-}

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           polysemy-conc-version:        0.9.0.0+version:        0.10.0.0 synopsis:       Polysemy effects for concurrency description:    See https://hackage.haskell.org/package/polysemy-conc/docs/Polysemy-Conc.html category:       Concurrency@@ -17,6 +17,9 @@ license:        BSD-2-Clause-Patent license-file:   LICENSE build-type:     Simple+extra-source-files:+    changelog.md+    readme.md  source-repository head   type: git@@ -30,18 +33,24 @@       Polysemy.Conc.Data.QueueResult       Polysemy.Conc.Effect.Critical       Polysemy.Conc.Effect.Events+      Polysemy.Conc.Effect.Gate       Polysemy.Conc.Effect.Interrupt+      Polysemy.Conc.Effect.Lock       Polysemy.Conc.Effect.Mask       Polysemy.Conc.Effect.Monitor       Polysemy.Conc.Effect.Queue       Polysemy.Conc.Effect.Race       Polysemy.Conc.Effect.Scoped+      Polysemy.Conc.Effect.Semaphore       Polysemy.Conc.Effect.Sync       Polysemy.Conc.Effect.SyncRead       Polysemy.Conc.Events+      Polysemy.Conc.Gate       Polysemy.Conc.Interpreter.Critical       Polysemy.Conc.Interpreter.Events+      Polysemy.Conc.Interpreter.Gate       Polysemy.Conc.Interpreter.Interrupt+      Polysemy.Conc.Interpreter.Lock       Polysemy.Conc.Interpreter.Mask       Polysemy.Conc.Interpreter.Monitor       Polysemy.Conc.Interpreter.Queue.Pure@@ -49,6 +58,7 @@       Polysemy.Conc.Interpreter.Queue.TBM       Polysemy.Conc.Interpreter.Race       Polysemy.Conc.Interpreter.Scoped+      Polysemy.Conc.Interpreter.Semaphore       Polysemy.Conc.Interpreter.Stack       Polysemy.Conc.Interpreter.Sync       Polysemy.Conc.Interpreter.SyncRead@@ -58,6 +68,7 @@       Polysemy.Conc.Queue.Timeout       Polysemy.Conc.Race       Polysemy.Conc.Retry+      Polysemy.Conc.Semaphore       Polysemy.Conc.Sync       Polysemy.Conc.SyncRead   hs-source-dirs:@@ -129,7 +140,7 @@     , containers     , incipit-core >=0.3     , polysemy >=1.6-    , polysemy-resume >=0.3+    , polysemy-resume >=0.5     , polysemy-time >=0.3     , stm     , stm-chans >=2

@@ -0,0 +1,8 @@+# 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

@@ -3,6 +3,7 @@ import Hedgehog (property, test, withTests) import Polysemy.Conc.Test.EventsTest (test_events) import Polysemy.Conc.Test.InterruptTest (test_interrupt)+import Polysemy.Conc.Test.LockTest (test_lock) import Polysemy.Conc.Test.MaskTest (test_mask) import Polysemy.Conc.Test.MonitorTest (test_monitorBasic, test_monitorClockSkew) import Polysemy.Conc.Test.QueueTest (@@ -13,8 +14,8 @@   test_queueTBM,   test_queueTimeoutTBM,   )-import Polysemy.Conc.Test.ScopedTest (test_scopedResumableWith, test_scopedWith)-import Polysemy.Conc.Test.SyncTest (test_sync)+import Polysemy.Conc.Test.ScopedTest (test_scoped)+import Polysemy.Conc.Test.SyncTest (test_sync, test_syncLock) import Polysemy.Test (unitTest) import Test.Tasty (TestTree, defaultMain, testGroup) import Test.Tasty.Hedgehog (testProperty)@@ -34,8 +35,10 @@       testProperty "events" (withTests 100 (property (test test_events)))     ],     testGroup "sync" [-      unitTest "sync" test_sync+      unitTest "sync" test_sync,+      unitTest "lock" test_syncLock     ],+    test_lock,     testGroup "interrupt" [       unitTest "interrupt" test_interrupt     ],@@ -46,10 +49,7 @@       unitTest "basic" test_monitorBasic,       unitTest "clock skew" test_monitorClockSkew     ],-    testGroup "scoped" [-      unitTest "scopedWith" test_scopedWith,-      unitTest "scopedResumableWith" test_scopedResumableWith-    ]+    test_scoped   ]  main :: IO ()

@@ -1,6 +1,5 @@ module Polysemy.Conc.Test.EventsTest where -import Control.Concurrent.Chan.Unagi.Bounded (OutChan) import Polysemy.Test (UnitTest, assertJust, runTestAuto)  import qualified Polysemy.Conc.Effect.Events as Events@@ -19,22 +18,22 @@   interpretEventsChan @Int $   interpretEventsChan @Text do     thread1 <- async do-      Events.subscribe @Int @(OutChan Int) do+      Events.subscribe @Int do         Sync.putBlock (Proxy @1)         Events.consume @Int     thread2 <- async do-      Events.subscribe @Int @(OutChan Int) do+      Events.subscribe @Int do         Sync.putBlock (Proxy @2)         Events.consume @Int     thread3 <- async do-      Events.subscribe @Text @(OutChan Text) do+      Events.subscribe @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+    Events.publish @Text "test"+    Events.publish @Int 1     num1 <- await thread1     num2 <- await thread2     text1 <- await thread3

@@ -1,26 +1,57 @@+{-# options_ghc -fplugin=Polysemy.Plugin #-}+ module Polysemy.Conc.Test.LockTest where -import Data.Time (Day, UTCTime)-import Polysemy.Test (UnitTest, assertEq, runTestAuto)-import qualified Polysemy.Time as Time-import Polysemy.Time (MicroSeconds (MicroSeconds), interpretTimeGhc)+import Polysemy.Test (UnitTest, assert, assertJust, runTestAuto, unitTest)+import Polysemy.Time (GhcTime, MilliSeconds (MilliSeconds), Seconds (Seconds), interpretTimeGhc)+import Test.Tasty (TestTree, testGroup) -import Polysemy.Conc.AtomicState (interpretAtomic)+import qualified Polysemy.Conc.Effect.Lock as Lock+import Polysemy.Conc.Effect.Lock (Lock)+import Polysemy.Conc.Effect.Mask (Mask)+import Polysemy.Conc.Effect.Race (Race)+import qualified Polysemy.Conc.Effect.Sync as Sync+import Polysemy.Conc.Interpreter.Lock (interpretLockReentrant)+import Polysemy.Conc.Interpreter.Mask (interpretMaskFinal) import Polysemy.Conc.Interpreter.Race (interpretRace)-import Polysemy.Conc.Interpreter.Sync (interpretSyncAs)-import Polysemy.Conc.Sync (lock)+import Polysemy.Conc.Interpreter.Sync (interpretSync)+import Polysemy.Conc.Race (timeout_) -test_lock :: UnitTest+interpretLockTest ::+  Members [Resource, Embed IO, Final IO] r =>+  InterpretersFor [Lock, Mask, Race, Async, GhcTime] r+interpretLockTest =+  interpretTimeGhc .+  asyncToIOFinal .+  interpretRace .+  interpretMaskFinal .+  interpretLockReentrant++test_lockBasic :: UnitTest+test_lockBasic =+  runTestAuto $ interpretLockTest $ interpretSync @(Proxy 1) $ interpretSync @(Proxy 2) do+    t1 <- async do+      Lock.lock do+        assert =<< Sync.putTry (Proxy @1)+        assertJust Proxy =<< Sync.wait @(Proxy 2) (Seconds 5)+    assertJust Proxy =<< Sync.wait @(Proxy 1) (Seconds 5)+    assert =<< Lock.lockOr (pure True) (pure False)+    assert =<< timeout_ (pure True) (MilliSeconds 50) (Lock.lock (pure False))+    assert =<< Sync.putTry (Proxy @2)+    assertJust () =<< await t1++test_lockReentry :: UnitTest+test_lockReentry =+  runTestAuto $ interpretLockTest do+    Lock.lock do+      assert =<< Lock.lockOr (pure False) (pure True)+      assertJust True =<< await =<< async do+        assert =<< timeout_ (pure True) (MilliSeconds 50) (Lock.lock (pure False))+        Lock.lockOr (pure True) (pure False)++test_lock :: TestTree test_lock =-  runTestAuto $-  interpretTimeGhc $-  asyncToIOFinal $-  interpretRace $-  interpretSyncAs () $-  interpretAtomic (0 :: Int) do-    void $ sequenceConcurrently @[] $ [(1 :: Int)..100] $> do-      lock () do-        cur <- atomicGet @Int-        Time.sleep @UTCTime @Day (MicroSeconds 100)-        atomicPut (cur + 1)-    assertEq @Int @IO 100 =<< atomicGet+  testGroup "lock" [+    unitTest "basic" test_lockBasic,+    unitTest "reentry" test_lockReentry+  ]

@@ -2,13 +2,19 @@  module Polysemy.Conc.Test.ScopedTest where -import Control.Concurrent.STM (TVar, atomically, newTVarIO, readTVarIO, writeTVar)+import Control.Concurrent.STM (TVar, atomically, modifyTVar', newTVarIO, readTVarIO, writeTVar) import Polysemy.Resume (Stop, stop, (!!))-import Polysemy.Test (UnitTest, runTestAuto, (===))+import Polysemy.Test (UnitTest, runTestAuto, unitTest, (===))+import Test.Tasty (TestTree, testGroup) -import Polysemy.Conc.Effect.Scoped (scoped)-import Polysemy.Conc.Interpreter.Scoped (interpretScopedResumableWithH, interpretScopedWithH)+import Polysemy.Conc.Effect.Scoped (rescope, scoped)+import Polysemy.Conc.Interpreter.Scoped (interpretScoped, interpretScopedH', interpretScopedResumableWithH, interpretScopedWithH) +newtype Par =+  Par { unPar :: Int }+  deriving stock (Eq, Show)+  deriving newtype (Num, Real, Enum, Integral, Ord)+ data E :: Effect where   E1 :: E m Int   E2 :: E m Int@@ -44,19 +50,22 @@  scope ::   Member (Embed IO) r =>+  Par ->   (TVar Int -> Sem (F : r) a) ->   Sem r a-scope use = do-  tv <- embed (newTVarIO 20)+scope (Par n) use = do+  tv <- embed (newTVarIO n)   interpretF tv (use tv)  test_scopedWith :: UnitTest test_scopedWith =-  runTestAuto $ interpretScopedWithH @'[F] scope handleE do-    i1 <- scoped e1-    i2 <- scoped e1-    i1 === 35-    i2 === 35+  runTestAuto $ interpretScopedWithH @'[F] @_ @_ @E scope handleE do+    (i1, i2) <- scoped @_ @E 20 do+      i1 <- e1+      i2 <- scoped @_ @E 23 e1+      pure (i1, i2)+    35 === i1+    38 === i2  handleRE ::   Member (Embed IO) r =>@@ -72,28 +81,94 @@   E2 ->     pureT =<< f -interpretFR ::-  Members [Stop Int, Embed IO] r =>-  TVar Int ->-  InterpreterFor F r-interpretFR tv =-  interpret \ F -> do-    embed (atomically (writeTVar tv 7))-    pure 5- scopeR ::   Member (Embed IO) r =>+  Par ->   (TVar Int -> Sem (F : Stop Int : r) a) ->   Sem (Stop Int : r) a-scopeR use = do-  tv <- embed (newTVarIO 20)+scopeR (Par n) use = do+  tv <- embed (newTVarIO n)   _ <- interpretF tv (use tv)   stop . (50 +) =<< embed (readTVarIO tv)  test_scopedResumableWith :: UnitTest test_scopedResumableWith =   runTestAuto $ interpretScopedResumableWithH @'[F] scopeR handleRE do-    i1 <- scoped e1 !! pure-    i2 <- scoped e2 !! pure-    i1 === 25-    i2 === 57+    i1 <- scoped 20 e1 !! pure+    i2 <- scoped 23 e2 !! pure+    25 === i1+    57 === i2++scopeH ::+  Member (Embed IO) r =>+  Par ->+  (TVar Int -> Tactical e m r a) ->+  Tactical e m r a+scopeH (Par n) use = do+  tv <- embed (newTVarIO n)+  use tv++handleH ::+  Member (Embed IO) r =>+  TVar Int ->+  E (Sem r0) a ->+  Tactical e (Sem r0) r a+handleH tv = \case+  E1 -> do+    embed (atomically (modifyTVar' tv (+1)))+    pureT =<< embed (readTVarIO tv)+  E2 ->+    pureT 23++test_scopedH :: UnitTest+test_scopedH =+  runTestAuto $ interpretScopedH' scopeH handleH do+    r <- scoped @_ @E 100 do+      i1 <- e1+      i2 <- scoped @_ @E 200 e1+      i3 <- e1+      pure (i1, i2, i3)+    (101, 201, 102) === r++data RPar =+  RPar {+    rpD :: Double,+    rpB :: Bool+  }+  deriving stock (Eq, Show)++data RRes =+  RRes {+    rrD :: Double,+    rrI :: Int+  }+  deriving stock (Eq, Show)++scopeR1 :: RPar -> (RRes -> Sem r a) -> Sem r a+scopeR1 (RPar d b) use =+  use (RRes (d * 2) (if b then 1 else 2))++handleR1 :: RRes -> E m x -> Sem r x+handleR1 (RRes d i) = \case+  E1 -> pure (i + floor (d * 3))+  E2 -> pure (i + floor (d * 4))++rescopeP :: Int -> RPar+rescopeP i =+  RPar (fromIntegral i) False++test_rescope :: UnitTest+test_rescope =+  runTestAuto $ interpretScoped scopeR1 handleR1 do+    r <- rescope rescopeP do+      scoped @_ @E 100 do+        e1+    602 === r+++test_scoped :: TestTree+test_scoped =+  testGroup "scoped" [+    unitTest "scopedWith" test_scopedWith,+    unitTest "scopedResumableWith" test_scopedResumableWith+  ]

@@ -1,12 +1,17 @@ module Polysemy.Conc.Test.SyncTest where +import Data.Time (Day, UTCTime) import Polysemy.Test (UnitTest, assertEq, runTestAuto)+import qualified Polysemy.Time as Time+import Polysemy.Time (MicroSeconds (MicroSeconds), interpretTimeGhc) +import Polysemy.Conc.AtomicState (interpretAtomic) import Polysemy.Conc.Effect.Race (Race) import qualified Polysemy.Conc.Effect.Sync as Sync import Polysemy.Conc.Effect.Sync (Sync) import Polysemy.Conc.Interpreter.Race (interpretRace)-import Polysemy.Conc.Interpreter.Sync (interpretSync)+import Polysemy.Conc.Interpreter.Sync (interpretSync, interpretSyncAs)+import Polysemy.Conc.Sync (lock)  data Thread1 = Thread1 data Thread2 = Thread2@@ -51,3 +56,18 @@   runTestAuto do     result <- run $ sequenceConcurrently @[] [thread1, thread2]     assertEq @_ @IO [Just 3, Just 2] result++test_syncLock :: UnitTest+test_syncLock =+  runTestAuto $+  interpretTimeGhc $+  asyncToIOFinal $+  interpretRace $+  interpretSyncAs () $+  interpretAtomic (0 :: Int) do+    void $ sequenceConcurrently @[] $ [(1 :: Int)..100] $> do+      lock () do+        cur <- atomicGet @Int+        Time.sleep @UTCTime @Day (MicroSeconds 100)+        atomicPut (cur + 1)+    assertEq @Int @IO 100 =<< atomicGet