packages feed

polysemy-conc 0.12.1.0 → 0.15.0.0

raw patch · 54 files changed

Files

LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2020 Torsten Schmits+Copyright (c) 2023 Torsten Schmits  Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
changelog.md view
@@ -1,3 +1,10 @@+# 0.14.0.0++## Breaking++* Move `Interrupt` to `polysemy-process` to avoid the dependency on `unix`.+* Remove deprecated `Scoped`.+ # 0.12.0.0  ## Breaking
lib/Polysemy/Conc.hs view
@@ -1,4 +1,4 @@--- |Description: Polysemy Effects for Concurrency+-- | Description: Polysemy Effects for Concurrency module Polysemy.Conc (   -- * Introduction   -- $intro@@ -79,15 +79,6 @@   -- ** Interpreters   interpretRace, -  -- * Signal Handling-  -- $signal-  Interrupt,--  -- ** Interpreters-  interpretInterrupt,-  interpretInterruptOnce,-  interpretInterruptNull,-   -- * Event Channels   Events,   Consume,@@ -124,6 +115,7 @@    -- * Masking   Mask,+  MaskMode (..),   UninterruptibleMask,   mask,   uninterruptibleMask,@@ -136,42 +128,6 @@   interpretMaskPure,   interpretUninterruptibleMaskPure, -  -- * Scoped Effects-  Scoped,-  Scoped_,-  scoped,-  scoped_,-  rescope,--  -- ** Interpreters-  interpretScoped,-  interpretScopedH,-  interpretScopedH',-  interpretScopedAs,-  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,   monitor,@@ -232,13 +188,11 @@ import Polysemy.Conc.Effect.Critical (Critical) 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.Lock (Lock, lock, lockOr, lockOrSkip, lockOrSkip_)-import Polysemy.Conc.Effect.Mask (Mask, Restoration, UninterruptibleMask, mask, restore, uninterruptibleMask)+import Polysemy.Conc.Effect.Mask (Mask, MaskMode (..), Restoration, UninterruptibleMask, mask, restore, uninterruptibleMask) import Polysemy.Conc.Effect.Monitor (Monitor, Restart, RestartingMonitor, ScopedMonitor, monitor, restart, withMonitor) import Polysemy.Conc.Effect.Queue (Queue) import Polysemy.Conc.Effect.Race (Race, race, timeout)-import Polysemy.Conc.Effect.Scoped (Scoped, Scoped_, rescope, scoped, scoped_) import Polysemy.Conc.Effect.Semaphore (Semaphore) import Polysemy.Conc.Effect.Sync (ScopedSync, Sync) import Polysemy.Conc.Effect.SyncRead (SyncRead)@@ -263,7 +217,6 @@ import Polysemy.Conc.Interpreter.Critical (interpretCritical, interpretCriticalNull) 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.Lock (interpretLockPermissive, interpretLockReentrant) import Polysemy.Conc.Interpreter.Mask (   interpretMaskFinal,@@ -281,35 +234,6 @@ import Polysemy.Conc.Interpreter.Queue.TB (interpretQueueTB) 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,-  interpretScopedH',-  interpretScopedR,-  interpretScopedRH,-  interpretScopedRWith,-  interpretScopedRWithH,-  interpretScopedRWith_,-  interpretScopedR_,-  interpretScopedResumable,-  interpretScopedResumableH,-  interpretScopedResumableWith,-  interpretScopedResumableWithH,-  interpretScopedResumableWith_,-  interpretScopedResumable_,-  interpretScopedWith,-  interpretScopedWithH,-  interpretScopedWith_,-  runScoped,-  runScopedAs,-  ) import Polysemy.Conc.Interpreter.Semaphore (interpretSemaphoreQ, interpretSemaphoreT) import Polysemy.Conc.Interpreter.Stack (ConcStack, runConc) import Polysemy.Conc.Interpreter.Sync (interpretScopedSync, interpretScopedSyncAs, interpretSync, interpretSyncAs)@@ -350,15 +274,11 @@ -- -- When the first thunk finishes, the other will be killed. --- $signal--- #signal#- -- $mask -- #mask#--- The two effects 'Mask' and 'UninterruptibleMask' use the 'Polysemy.Scoped' pattern, which allow an effect--- with resources to be constrained to a region of code.--- The actual effect is 'Polysemy.Conc.Effect.Mask.RestoreMask', with `mask` and 'uninterruptibleMask' only specializing--- 'Polysemy.Conc.Effect.scoped' to the appropriate resource type.+-- The 'Mask' effect uses the 'Polysemy.Scoped' pattern with 'MaskMode' as the scope parameter.+-- 'mask' and 'uninterruptibleMask' are convenience functions that pass 'Interruptible' or 'Uninterruptible' to+-- 'Polysemy.scoped'. -- -- Usage is straightforward: --@@ -371,5 +291,3 @@ --      doUnmaskedThing --    doMaskedThing -- @------ The @resource@ parameter stays polymorphic; it is used to connect the resource in the interpreter to the callsite.
lib/Polysemy/Conc/Async.hs view
@@ -1,4 +1,4 @@--- |Description: Async Combinators+-- | Description: Async Combinators module Polysemy.Conc.Async where  import qualified Control.Concurrent.Async as Base@@ -12,7 +12,7 @@ import qualified Polysemy.Conc.Race as Race import Polysemy.Conc.Sync (withSync) --- |Run the first action asynchronously while the second action executes, then cancel the first action.+-- | 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. -- -- When cancelling, this variant will wait indefinitely for the thread to be gone.@@ -25,7 +25,7 @@   handle <- async mb   finally (use handle) (cancel handle) --- |Run the first action asynchronously while the second action executes, then cancel the first action.+-- | Run the first action asynchronously while the second action executes, then cancel the first action. -- 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.@@ -40,7 +40,7 @@   handle <- async mb   finally (use handle) (Race.timeoutU interval (cancel handle)) --- |Run the first action asynchronously while the second action executes, then cancel the first action.+-- | Run the first action asynchronously while the second action executes, then cancel the first action. -- 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.@@ -52,7 +52,7 @@ withAsync =   withAsyncWait (MilliSeconds 500) --- |Run the first action asynchronously while the second action executes, then cancel the first action.+-- | Run the first action asynchronously while the second action executes, then cancel the first action. -- Discards the handle, expecting the async action to either terminate or be cancelled. -- -- When cancelling, this variant will wait for 500ms for the thread to be gone.@@ -64,7 +64,7 @@ withAsync_ mb =   withAsync mb . const --- |Run an action with 'async', but don't start it right away, so the thread handle can be processed before the action+-- | Run an action with 'async', but don't start it right away, so the thread handle can be processed before the action -- executes. -- -- Takes a callback function that is invoked after spawning the thread.@@ -93,7 +93,7 @@       raise mb     f h (Sync.putBlock ()) --- |Variant of 'scheduleAsync' that directly interprets the 'Control.Concurrent.MVar' used for signalling.+-- | Variant of 'scheduleAsync' that directly interprets the 'Control.Concurrent.MVar' used for signalling. scheduleAsyncIO ::   ∀ b r a .   Members [Resource, Async, Race, Embed IO] r =>@@ -107,7 +107,7 @@       raise mb     f h (Sync.putBlock ()) --- |Run the first action asynchronously while the second action executes, then cancel the first action.+-- | 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'. --@@ -125,7 +125,7 @@     gate     raise (use h) --- |Run the first action asynchronously while the second action executes, then cancel the first action.+-- | 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'. --
lib/Polysemy/Conc/AtomicState.hs view
@@ -1,9 +1,9 @@--- |Description: AtomicState Interpreters+-- | Description: AtomicState Interpreters module Polysemy.Conc.AtomicState where  import Control.Concurrent.STM (newTVarIO) --- |Convenience wrapper around 'runAtomicStateTVar' that creates a new 'Control.Concurrent.STM.TVar'.+-- | Convenience wrapper around 'runAtomicStateTVar' that creates a new 'Control.Concurrent.STM.TVar'. interpretAtomic ::   ∀ a r .   Member (Embed IO) r =>
lib/Polysemy/Conc/Data/QueueResult.hs view
@@ -1,7 +1,7 @@--- |Description: Queue result ADT+-- | Description: Queue result ADT module Polysemy.Conc.Data.QueueResult where --- |Encodes failure reasons for queues.+-- | Encodes failure reasons for queues. -- -- For documentation on the constructors, see the module "Polysemy.Conc.Data.QueueResult". --@@ -9,13 +9,13 @@ -- import qualified Polysemy.Conc.Data.QueueResult as QueueResult -- @ data QueueResult d =-  -- |The operation was successful.+  -- | The operation was successful.   Success d   |-  -- |The queue is either full and cannot be added to, or empty and cannot be read from.+  -- | The queue is either full and cannot be added to, or empty and cannot be read from.   NotAvailable   |-  -- |The queue was closed by the user.+  -- | The queue was closed by the user.   Closed   deriving stock (Eq, Show, Ord, Functor, Generic)
lib/Polysemy/Conc/Effect/Critical.hs view
@@ -1,21 +1,21 @@ {-# options_haddock prune #-} --- |Description: Critical effect+-- | Description: Critical effect module Polysemy.Conc.Effect.Critical where  import Prelude hiding (catch) --- |An effect that catches exceptions.+-- | An effect that catches exceptions. -- -- Provides the exact functionality of `Polysemy.Error.fromExceptionSem`, but pushes the dependency on @Final IO@ to the -- interpreter, and makes it optional. data Critical :: Effect where-  -- |Catch all exceptions of type @e@ in this computation.+  -- | Catch all exceptions of type @e@ in this computation.   Catch :: Exception e => m a -> Critical m (Either e a)  makeSem ''Critical --- |Catch exceptions of type @e@ and return a fallback value.+-- | Catch exceptions of type @e@ and return a fallback value. catchAs ::   ∀ e a r .   Exception e =>@@ -26,7 +26,7 @@ catchAs a =   fmap (fromRight a) . catch @_ @e --- |Convenience overload for 'SomeException'.+-- | Convenience overload for 'SomeException'. run ::   Member Critical r =>   Sem r a ->@@ -34,7 +34,7 @@ run =   catch --- |Convenience overload for 'SomeException'.+-- | Convenience overload for 'SomeException'. runAs ::   Member Critical r =>   a ->
lib/Polysemy/Conc/Effect/Events.hs view
@@ -1,34 +1,34 @@ {-# options_haddock prune #-} --- |Description: Events/Consume Effects, Internal+-- | Description: Events/Consume Effects, Internal module Polysemy.Conc.Effect.Events where --- |An event publisher that can be consumed from multiple threads.+-- | An event publisher that can be consumed from multiple threads. data Events (e :: Type) :: Effect where   Publish :: e -> Events e m ()  makeSem_ ''Events --- |Publish one event.+-- | Publish one event. publish ::   ∀ e r .   Member (Events e) r =>   e ->   Sem r () --- |Consume events emitted by 'Events'.+-- | Consume events emitted by 'Events'. data Consume (e :: Type) :: Effect where   Consume :: Consume e m e  makeSem_ ''Consume --- |Consume one event emitted by 'Events'.+-- | Consume one event emitted by 'Events'. consume ::   ∀ e r .   Member (Consume e) r =>   Sem r e --- |Create a new scope for 'Events', causing the nested program to get its own copy of the event stream.+-- | 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 r .
lib/Polysemy/Conc/Effect/Gate.hs view
@@ -1,9 +1,9 @@ {-# options_haddock prune #-} --- |Description: Gate effect, Internal+-- | Description: Gate effect, Internal module Polysemy.Conc.Effect.Gate where --- |A single-use synchronization point that blocks all consumers who called 'gate' until 'signal' is called.+-- | 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@@ -12,11 +12,11 @@  makeSem ''Gate --- |Convenience alias for scoped 'Gate'.+-- | Convenience alias for scoped 'Gate'. type Gates =   Scoped_ Gate --- |Run an action with a locally scoped 'Gate' effect.+-- | 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 ::
− lib/Polysemy/Conc/Effect/Interrupt.hs 
@@ -1,44 +0,0 @@-{-# options_haddock prune #-}--- |Description: Interrupt effect-module Polysemy.Conc.Effect.Interrupt where---- |The interrupt handler effect allows three kinds of interaction for interrupt signals:------ - Execute a callback when a signal is received--- - Block a thread until a signal is received--- - Kill a thread when a signal is received------ For documentation on the constructors, see the module "Polysemy.Conc.Effect.Interrupt".------ @--- import qualified Polysemy.Conc.Effect.Interrupt as Interrupt------ prog = do---   Interrupt.register "task 1" (putStrLn "interrupted")---   Interrupt.killOnQuit $ forever do---    doSomeWork--- @-data Interrupt :: Effect where-  -- |Add a computation to be executed on interrupt, using the first argument as a key.-  Register :: Text -> IO () -> Interrupt m ()-  -- |Remove the previously added handler with the given key.-  Unregister :: Text -> Interrupt m ()-  -- |Manually trigger the interrupt.-  Quit :: Interrupt m ()-  -- |Block until an interrupt is triggered.-  WaitQuit :: Interrupt m ()-  -- |Indicate whether an interrupt was triggered.-  Interrupted :: Interrupt m Bool-  -- |Execute a computation, waiting for it to finish, killing its thread on interrupt.-  KillOnQuit :: Text -> m a -> Interrupt m (Maybe a)--makeSem ''Interrupt---- |Variant of 'killOnQuit' that returns @()@.-killOnQuit_ ::-  Member Interrupt r =>-  Text ->-  Sem r a ->-  Sem r ()-killOnQuit_ desc ma =-  void (killOnQuit desc ma)
lib/Polysemy/Conc/Effect/Lock.hs view
@@ -1,23 +1,23 @@--- |Lock effect, Internal+-- | Lock effect, Internal module Polysemy.Conc.Effect.Lock where --- |An exclusive lock or mutex, protecting a region from concurrent access.+-- | 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.+  -- | 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.+  -- | 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.+-- | 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.+-- | Run an action if the lock is available, block otherwise. lockOr ::   ∀ r a .   Member Lock r =>@@ -25,7 +25,7 @@   Sem r a ->   Sem r a --- |Run an action if the lock is available, skip and return 'Nothing' otherwise.+-- | Run an action if the lock is available, skip and return 'Nothing' otherwise. lockOrSkip ::   ∀ r a .   Member Lock r =>@@ -35,7 +35,7 @@   lockOr (pure Nothing) (Just <$> ma) {-# inline lockOrSkip #-} --- |Run an action if the lock is available, skip otherwise.+-- | Run an action if the lock is available, skip otherwise. -- Return @()@. lockOrSkip_ ::   ∀ r a .
lib/Polysemy/Conc/Effect/Mask.hs view
@@ -1,15 +1,15 @@ {-# options_haddock prune #-} --- |Description: Mask Effect, Internal+-- | Description: Mask Effect, Internal module Polysemy.Conc.Effect.Mask where --- |Part of an effect abstracting 'Control.Exception.mask'.+-- | Part of an effect abstracting 'Control.Exception.mask'. data RestoreMask :: Effect where   Restore :: m a -> RestoreMask m a  makeSem_ ''RestoreMask --- |Restore the previous masking state.+-- | Restore the previous masking state. -- Can only be called inside of an action passed to 'mask' or 'uninterruptibleMask'. restore ::   ∀ r a .@@ -17,30 +17,37 @@   Sem r a ->   Sem r a --- |Resource type for the scoped 'Mask' effect, wrapping the @restore@ callback passed in by 'Base.mask'.+-- | 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.+-- | Whether 'mask' or 'uninterruptibleMask' was requested.+data MaskMode =+  Interruptible+  |+  Uninterruptible+  deriving stock (Eq, Show)++-- | The scoped masking effect, parameterized by 'MaskMode'. type Mask =-  Scoped_ RestoreMask+  Scoped MaskMode RestoreMask --- |The scoped uninterruptible masking effect.-type UninterruptibleMask =-  Scoped_ RestoreMask+-- | Deprecated synonym for 'Mask'.+type UninterruptibleMask = Mask+{-# deprecated UninterruptibleMask "Use Mask instead, which now handles both variants via MaskMode" #-} --- |Mark a region as masked.--- Uses the 'Scoped_' pattern.+-- | Mark a region as masked.+-- Uses the 'Scoped' pattern with 'Interruptible'. mask ::   Member Mask r =>   InterpreterFor RestoreMask r mask =-  scoped_+  scoped Interruptible --- |Mark a region as uninterruptibly masked.--- Uses the 'Scoped_' pattern.+-- | Mark a region as uninterruptibly masked.+-- Uses the 'Scoped' pattern with 'Uninterruptible'. uninterruptibleMask ::-  Member UninterruptibleMask r =>+  Member Mask r =>   InterpreterFor RestoreMask r uninterruptibleMask =-  scoped_+  scoped Uninterruptible
lib/Polysemy/Conc/Effect/Monitor.hs view
@@ -1,16 +1,16 @@ {-# options_haddock prune #-} --- |Description: Monitor Effect, Internal+-- | Description: Monitor Effect, Internal module Polysemy.Conc.Effect.Monitor where  import Polysemy.Time (NanoSeconds) --- |Marker type for the restarting action for 'Monitor'.+-- | Marker type for the restarting action for 'Monitor'. data Restart =   Restart   deriving stock (Eq, Show) --- |Mark a region as being subject to intervention by a monitoring program.+-- | 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'.@@ -19,26 +19,26 @@  makeSem_ ''Monitor --- |Mark a region as being subject to intervention by a monitoring program.+-- | Mark a region as being subject to intervention by a monitoring program. monitor ::   ∀ action r a .   Member (Monitor action) r =>   Sem r a ->   Sem r a --- |Convenience alias for a 'Scoped_' 'Monitor'.+-- | Convenience alias for a 'Scoped_' 'Monitor'. type ScopedMonitor (action :: Type) =   Scoped_ (Monitor action) --- |'Monitor' specialized to the 'Restart' action.+-- | 'Monitor' specialized to the 'Restart' action. type RestartingMonitor =   ScopedMonitor Restart --- |Resources for a 'Scoped_' 'Monitor'.+-- | Resources for a 'Scoped_' 'Monitor'. data MonitorCheck r =   MonitorCheck {     interval :: NanoSeconds,-    check :: MVar () -> Sem r ()+    check :: Sem r Bool   }  -- | Transform the stack of the check in a 'MonitorCheck'.@@ -47,9 +47,9 @@   MonitorCheck r ->   MonitorCheck r' hoistMonitorCheck f MonitorCheck {..} =-  MonitorCheck {check = f . check, ..}+  MonitorCheck {check = f check, ..} --- |Start a region that can contain monitor-intervention regions.+-- | Start a region that can contain monitor-intervention regions. withMonitor ::   ∀ action r .   Member (ScopedMonitor action) r =>@@ -57,7 +57,7 @@ withMonitor =   scoped_ --- |Variant of 'withMonitor' that uses the 'Restart' strategy.+-- | Variant of 'withMonitor' that uses the 'Restart' strategy. restart ::   Member (ScopedMonitor Restart) r =>   InterpreterFor (Monitor Restart) r
lib/Polysemy/Conc/Effect/Queue.hs view
@@ -1,11 +1,11 @@ {-# options_haddock prune #-}--- |Description: Queue effect+-- | Description: Queue effect module Polysemy.Conc.Effect.Queue where  import Polysemy.Time (TimeUnit) import Polysemy.Conc.Data.QueueResult (QueueResult) --- |Abstracts queues like 'Control.Concurrent.STM.TBQueue'.+-- | Abstracts queues like 'Control.Concurrent.STM.TBQueue'. -- -- For documentation on the constructors, see the module "Polysemy.Conc.Data.Queue". --@@ -22,25 +22,25 @@ --     r -> pure r -- @ data Queue d :: Effect where-  -- |Read an element from the queue, blocking until one is available.+  -- | Read an element from the queue, blocking until one is available.   Read :: Queue d m (QueueResult d)-  -- |Read an element from the queue, immediately returning if none is available.+  -- | Read an element from the queue, immediately returning if none is available.   TryRead :: Queue d m (QueueResult d)-  -- |Read an element from the queue, blocking until one is available or the timeout expires.+  -- | Read an element from the queue, blocking until one is available or the timeout expires.   ReadTimeout :: TimeUnit t => t -> Queue d m (QueueResult d)-  -- |Read an element, leaving it in the queue, blocking until one is available.+  -- | Read an element, leaving it in the queue, blocking until one is available.   Peek :: Queue d m (QueueResult d)-  -- |Read an element, leaving it in the queue, immediately returning if none is available.+  -- | Read an element, leaving it in the queue, immediately returning if none is available.   TryPeek :: Queue d m (QueueResult d)-  -- |Write an element to the queue, blocking until a slot is available.+  -- | Write an element to the queue, blocking until a slot is available.   Write :: d -> Queue d m ()-  -- |Write an element to the queue, immediately returning if no slot is available.+  -- | Write an element to the queue, immediately returning if no slot is available.   TryWrite :: d -> Queue d m (QueueResult ())-  -- |Write an element to the queue, blocking until a slot is available or the timeout expires.+  -- | Write an element to the queue, blocking until a slot is available or the timeout expires.   WriteTimeout :: TimeUnit t => t -> d -> Queue d m (QueueResult ())-  -- |Indicate whether the queue is closed.+  -- | Indicate whether the queue is closed.   Closed :: Queue d m Bool-  -- |Close the queue.+  -- | Close the queue.   Close :: Queue d m ()  makeSem ''Queue
lib/Polysemy/Conc/Effect/Race.hs view
@@ -1,21 +1,21 @@ {-# options_haddock prune #-} --- |Description: Race effect+-- | Description: Race effect module Polysemy.Conc.Effect.Race where  import Polysemy.Time (TimeUnit) --- |Abstract the concept of running two programs concurrently, aborting the other when one terminates.+-- | Abstract the concept of running two programs concurrently, aborting the other when one terminates. -- 'Timeout' is a simpler variant, where one thread just sleeps for a given interval. data Race :: Effect where-  -- |Run both programs concurrently, returning the result of the faster one.+  -- | Run both programs concurrently, returning the result of the faster one.   Race :: m a -> m b -> Race m (Either a b)-  -- |Run the first action if the second action 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 --- |Run both programs concurrently, returning the result of the faster one.+-- | Run both programs concurrently, returning the result of the faster one. race ::   ∀ a b r .   Member Race r =>@@ -23,7 +23,7 @@   Sem r b ->   Sem r (Either a b) --- |Run the fallback action if the given program doesn't finish within the specified interval.+-- | Run the fallback action if the given program doesn't finish within the specified interval. timeout ::   ∀ a b u r .   TimeUnit u =>
− lib/Polysemy/Conc/Effect/Scoped.hs 
@@ -1,155 +0,0 @@-{-# options_haddock prune #-}---- |Description: Scoped Effect, Internal-module Polysemy.Conc.Effect.Scoped where--import Prelude hiding (Scoped, Scoped_, scoped)---- | @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.------ /Note/: This effect has been merged to Polysemy and will be released there soon.------ 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.------ 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--{-# deprecated Scoped "Scoped has been moved to Polysemy.Scoped" #-}---- |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 ::-  ∀ param effect r .-  Member (Scoped param effect) r =>-  param ->-  InterpreterFor effect r-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 #-}
lib/Polysemy/Conc/Effect/Semaphore.hs view
@@ -1,23 +1,23 @@--- |Semaphore effect, Internal.+-- | 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+-- | 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 until a slot is available, then acquire it.   Wait :: Semaphore m ()-  -- |Release a slot.+  -- | Release a slot.   Signal :: Semaphore m ()  makeSem_ ''Semaphore --- |Wait until a slot is available, then acquire it.+-- | Wait until a slot is available, then acquire it. wait ::   ∀ r .   Member Semaphore r =>   Sem r () --- |Release a slot.+-- | Release a slot. signal ::   ∀ r .   Member Semaphore r =>
lib/Polysemy/Conc/Effect/Sync.hs view
@@ -1,12 +1,12 @@ {-# options_haddock prune #-} --- |Description: Sync effect, Internal.+-- | Description: Sync effect, Internal. module Polysemy.Conc.Effect.Sync where  import Polysemy.Time (TimeUnit) import Prelude hiding (empty, try) --- |Abstracts an 'Control.Concurrent.MVar'.+-- | Abstracts an 'Control.Concurrent.MVar'. -- -- For documentation on the constructors, see the module "Polysemy.Conc.Effect.Sync". --@@ -20,29 +20,29 @@ --   Sync.takeBlock -- @ data Sync d :: Effect where-  -- |Read the variable, waiting until a value is available.+  -- | Read the variable, waiting until a value is available.   Block :: Sync d m d-  -- |Read the variable, waiting until a value is available or the timeout has expired.+  -- | Read the variable, waiting until a value is available or the timeout has expired.   Wait :: TimeUnit u => u -> Sync d m (Maybe d)-  -- |Read the variable, returning 'Nothing' immmediately if no value was available.+  -- | Read the variable, returning 'Nothing' immmediately if no value was available.   Try :: Sync d m (Maybe d)-  -- |Take the variable, waiting until a value is available.+  -- | Take the variable, waiting until a value is available.   TakeBlock :: Sync d m d-  -- |Take the variable, waiting until a value is available or the timeout has expired.+  -- | Take the variable, waiting until a value is available or the timeout has expired.   TakeWait :: TimeUnit u => u -> Sync d m (Maybe d)-  -- |Take the variable, returning 'Nothing' immmediately if no value was available.+  -- | Take the variable, returning 'Nothing' immmediately if no value was available.   TakeTry :: Sync d m (Maybe d)-  -- |Write the variable, waiting until it is writable.+  -- | Write the variable, waiting until it is writable.   PutBlock :: d -> Sync d m ()-  -- |Write the variable, waiting until it is writable or the timeout has expired.+  -- | 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 a 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.+  -- | Indicate whether the variable is empty.   Empty :: Sync d m Bool  makeSem ''Sync --- |Convenience alias.+-- | Convenience alias. type ScopedSync a =   Scoped_ (Sync a)
lib/Polysemy/Conc/Effect/SyncRead.hs view
@@ -1,20 +1,20 @@ {-# options_haddock prune #-} --- |The effect 'SyncRead' is equivalent to 'Polysemy.Conc.Sync' without the write actions.+-- | The effect 'SyncRead' is equivalent to 'Polysemy.Conc.Sync' without the write actions. module Polysemy.Conc.Effect.SyncRead where  import Polysemy.Time (TimeUnit) import Prelude hiding (empty, try) --- |An interface to a shared variable ('MVar') that can only be read.+-- | An interface to a shared variable ('MVar') that can only be read. data SyncRead (d :: Type) :: Effect where-  -- |Read the variable, waiting until a value is available.+  -- | Read the variable, waiting until a value is available.   Block :: SyncRead d m d-  -- |Read the variable, waiting until a value is available or the timeout has expired.+  -- | Read the variable, waiting until a value is available or the timeout has expired.   Wait :: TimeUnit u => u -> SyncRead d m (Maybe d)-  -- |Read the variable, returning 'Nothing' immmediately if no value was available.+  -- | Read the variable, returning 'Nothing' immmediately if no value was available.   Try :: SyncRead d m (Maybe d)-  -- |Indicate whether the variable is empty.+  -- | Indicate whether the variable is empty.   Empty :: SyncRead d m Bool  makeSem ''SyncRead
lib/Polysemy/Conc/Events.hs view
@@ -1,4 +1,4 @@--- |Description: Events Combinators+-- | Description: Events Combinators module Polysemy.Conc.Events where  import Polysemy.Conc.Async (withAsync_)@@ -8,7 +8,7 @@ import Polysemy.Conc.Effect.Race (Race) 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.+-- | 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.@@ -21,7 +21,7 @@     signal     action --- |Create a new scope for 'Polysemy.Conc.Events', causing the nested program to get its own copy of the event stream.+-- | 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.@@ -36,7 +36,7 @@     gate     raise @Gate ma --- |Pull repeatedly from 'Polysemy.Conc.Consume', passing the event to the supplied callback.+-- | Pull repeatedly from 'Polysemy.Conc.Consume', passing the event to the supplied callback. -- Stop when the action returns @False@. consumeWhile ::   Member (Consume e) r =>@@ -48,7 +48,7 @@     spin =       whenM (action =<< Events.consume) spin --- |Pull repeatedly from the 'Polysemy.Conc.Events' channel, passing the event to the supplied callback.+-- | Pull repeatedly from the 'Polysemy.Conc.Events' channel, passing the event to the supplied callback. -- Stop when the action returns @False@. subscribeWhile ::   ∀ e r .@@ -58,7 +58,7 @@ subscribeWhile action =   Events.subscribe @e (consumeWhile (raise . action)) --- |Pull repeatedly from the 'Polysemy.Conc.Events' channel, passing the event to the supplied callback.+-- | 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.@@ -71,7 +71,7 @@   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+-- | 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 .@@ -82,7 +82,7 @@ subscribeWhileAsync action =   subscribeAsync @e (consumeWhile action) --- |Pull repeatedly from 'Polysemy.Conc.Consume', passing the event to the supplied callback.+-- | Pull repeatedly from 'Polysemy.Conc.Consume', passing the event to the supplied callback. consumeLoop ::   Member (Consume e) r =>   (e -> Sem r ()) ->@@ -90,7 +90,7 @@ consumeLoop action =   forever (action =<< Events.consume) --- |Pull repeatedly from the 'Polysemy.Conc.Events' channel, passing the event to the supplied callback.+-- | Pull repeatedly from the 'Polysemy.Conc.Events' channel, passing the event to the supplied callback. subscribeLoop ::   ∀ e r .   Member (EventConsumer e) r =>@@ -99,7 +99,7 @@ subscribeLoop action =   Events.subscribe @e (consumeLoop (raise . action)) --- |Pull repeatedly from the 'Polysemy.Conc.Events' channel, passing the event to the supplied callback.+-- | 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 ::@@ -111,7 +111,7 @@   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+-- | Start a new thread that pulls repeatedly from the 'Polysemy.Conc.Events' channel, passing the event to the supplied -- callback. subscribeLoopAsync ::   ∀ e r a .@@ -122,7 +122,7 @@ subscribeLoopAsync action =   subscribeAsync @e (consumeLoop action) --- |Block until a value matching the predicate has been returned by 'Polysemy.Conc.Consume'.+-- | Block until a value matching the predicate has been returned by 'Polysemy.Conc.Consume'. consumeFind ::   ∀ e r .   Member (Consume e) r =>@@ -135,7 +135,7 @@       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.+-- | Block until a value matching the predicate has been published to the 'Polysemy.Conc.Events' channel. subscribeFind ::   ∀ e r .   Member (EventConsumer e) r =>@@ -144,7 +144,7 @@ subscribeFind f =   Events.subscribe @e (consumeFind f) --- |Return the first value returned by 'Polysemy.Conc.Consume' for which the function produces 'Just'.+-- | Return the first value returned by 'Polysemy.Conc.Consume' for which the function produces 'Just'. consumeFirstJust ::   ∀ e a r .   Member (Consume e) r =>@@ -157,7 +157,7 @@       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'.+-- | 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 =>@@ -166,7 +166,7 @@ subscribeFirstJust f =   Events.subscribe @e (consumeFirstJust f) --- |Block until the specified value has been returned by 'Polysemy.Conc.Consume'.+-- | Block until the specified value has been returned by 'Polysemy.Conc.Consume'. consumeElem ::   ∀ e r .   Eq e =>@@ -176,7 +176,7 @@ consumeElem target =   void (consumeFind (pure . (target ==))) --- |Block until the specified value has been published to the 'Polysemy.Conc.Events' channel.+-- | Block until the specified value has been published to the 'Polysemy.Conc.Events' channel. subscribeElem ::   ∀ e r .   Eq e =>
lib/Polysemy/Conc/Gate.hs view
@@ -1,6 +1,6 @@ {-# options_haddock prune #-} --- |Description: API for the 'Gate' effect+-- | Description: API for the 'Gate' effect module Polysemy.Conc.Gate (   module Polysemy.Conc.Effect.Gate,   module Polysemy.Conc.Interpreter.Gate,
lib/Polysemy/Conc/Interpreter/Critical.hs view
@@ -1,4 +1,4 @@--- |Description: Critical interpreters+-- | Description: Critical interpreters module Polysemy.Conc.Interpreter.Critical where  import qualified Control.Exception as Exception@@ -6,7 +6,7 @@  import Polysemy.Conc.Effect.Critical (Critical (..)) --- |Interpret 'Critical' in terms of 'Final' 'IO'.+-- | Interpret 'Critical' in terms of 'Final' 'IO'. interpretCritical ::   Member (Final IO) r =>   InterpreterFor Critical r@@ -21,7 +21,7 @@           Exception.catch (fmap Right <$> ma') \ se -> pure (Left se <$ s) {-# inline interpretCritical #-} --- |Interpret 'Critical' by doing nothing.+-- | Interpret 'Critical' by doing nothing. interpretCriticalNull ::   InterpreterFor Critical r interpretCriticalNull =
lib/Polysemy/Conc/Interpreter/Events.hs view
@@ -1,6 +1,6 @@ {-# options_haddock prune #-} --- |Description: Events/Consume Interpreters, Internal+-- | Description: Events/Consume Interpreters, Internal module Polysemy.Conc.Interpreter.Events where  import Control.Concurrent.Chan.Unagi.Bounded (InChan, OutChan, dupChan, newChan, readChan, tryWriteChan)@@ -10,11 +10,11 @@ import Polysemy.Conc.Effect.Events (Consume, Events) import Polysemy.Conc.Effect.Race (Race) --- |Convenience alias for the consumer effect.+-- | Convenience alias for the consumer effect. type EventConsumer e =   Scoped_ (Consume e) --- |Interpret 'Consume' by reading from an 'OutChan'.+-- | Interpret 'Consume' by reading from an 'OutChan'. -- Used internally by 'interpretEventsChan', not safe to use directly. interpretConsumeChan ::   ∀ e r .@@ -26,7 +26,7 @@     Events.Consume ->       embed (readChan chan) --- |Interpret 'Events' by writing to an 'InChan'.+-- | Interpret 'Events' by writing to an 'InChan'. -- Used internally by 'interpretEventsChan', not safe to use directly. -- When the channel queue is full, this silently discards events. interpretEventsInChan ::@@ -39,7 +39,7 @@     Events.Publish e ->       void (embed (tryWriteChan inChan e)) --- |Interpret 'Events' and 'Consume' together by connecting them to the two ends of an unagi channel.+-- | Interpret 'Events' and 'Consume' together by connecting them to the two ends of an unagi channel. -- '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). --
lib/Polysemy/Conc/Interpreter/Gate.hs view
@@ -1,9 +1,9 @@--- |Gate interpreters, Internal+-- | Gate interpreters, Internal module Polysemy.Conc.Interpreter.Gate where  import Polysemy.Conc.Effect.Gate (Gate (Gate, Signal)) --- |Interpret 'Gate' with an 'MVar'.+-- | Interpret 'Gate' with an 'MVar'. interpretGate ::   ∀ r .   Member (Embed IO) r =>@@ -20,7 +20,7 @@         Gate ->           embed (readMVar mv) --- |Interpret @'Scoped_' 'Gate'@ with an @'MVar' ()@.+-- | Interpret @'Scoped_' 'Gate'@ with an @'MVar' ()@. interpretGates ::   Member (Embed IO) r =>   InterpreterFor (Scoped_ Gate) r
− lib/Polysemy/Conc/Interpreter/Interrupt.hs 
@@ -1,243 +0,0 @@-{-# options_haddock prune #-}---- |Description: Interrupt interpreters-module Polysemy.Conc.Interpreter.Interrupt where--import qualified Control.Concurrent.Async as A-import Control.Concurrent.Async (AsyncCancelled)-import Control.Concurrent.STM (TVar, newTVarIO)-import qualified Data.Map.Strict as Map-import qualified Data.Set as Set-import qualified Data.Text.IO as Text-import Polysemy.Internal.Tactics (liftT)-import Polysemy.Time (Seconds (Seconds))-import System.IO (stderr)-import System.Posix.Signals (-  Handler (Catch, CatchInfo, CatchInfoOnce, CatchOnce),-  SignalInfo,-  installHandler,-  keyboardSignal,-  )--import qualified Polysemy.Conc.Effect.Critical as Critical-import Polysemy.Conc.Effect.Critical (Critical)-import Polysemy.Conc.Effect.Interrupt (Interrupt (..))-import Polysemy.Conc.Effect.Race (Race)-import qualified Polysemy.Conc.Effect.Sync as Sync-import Polysemy.Conc.Interpreter.Sync (interpretSync)-import Polysemy.Conc.Race (race_)--putErr ::-  Member (Embed IO) r =>-  Text ->-  Sem r ()-putErr =-  embed . Text.hPutStrLn stderr--data InterruptState =-  InterruptState {-    quit :: !(MVar ()),-    finished :: !(MVar ()),-    listeners :: !(Set Text),-    original :: !(SignalInfo -> IO ()),-    handlers :: !(Map Text (IO ()))-  }--modListeners :: (Set Text -> Set Text) -> InterruptState -> InterruptState-modListeners f s@InterruptState {listeners} =-  s {listeners = f listeners}--modHandlers :: (Map Text (IO ()) -> Map Text (IO ())) -> InterruptState -> InterruptState-modHandlers f s@InterruptState {handlers} =-  s {handlers = f handlers}--waitQuit ::-  Members [AtomicState InterruptState, Embed IO] r =>-  Sem r ()-waitQuit = do-  mv <- atomicGets quit-  embed (readMVar mv)--checkListeners ::-  Members [AtomicState InterruptState, Embed IO] r =>-  Sem r ()-checkListeners =-  whenM (atomicGets (Set.null . listeners)) do-    fin <- atomicGets finished-    void (embed (tryPutMVar fin ()))--onQuit ::-  Members [AtomicState InterruptState, Embed IO] r =>-  Text ->-  Sem r a ->-  Sem r a-onQuit name ma = do-  atomicModify' (modListeners (Set.insert name))-  waitQuit-  a <- ma-  atomicModify' (modListeners (Set.delete name))-  checkListeners-  pure a--processHandler ::-  Member (Embed IO) r =>-  Text ->-  IO () ->-  Sem r ()-processHandler name thunk = do-  putErr ("processing interrupt handler: " <> name)-  embed thunk--execInterrupt ::-  Members [AtomicState InterruptState, Embed IO] r =>-  Sem r (SignalInfo -> Sem r ())-execInterrupt = do-  InterruptState quitSignal finishSignal _ orig _ <- atomicGet-  whenM (embed (tryPutMVar quitSignal ())) do-    traverse_ (uncurry processHandler) . Map.toList =<< atomicGets handlers-    checkListeners-    embed (takeMVar finishSignal)-  embed . orig <$ putErr "interrupt handlers finished"--registerHandler ::-  Member (AtomicState InterruptState) r =>-  Text ->-  IO () ->-  Sem r ()-registerHandler name handler =-  atomicModify' (modHandlers (Map.insert name handler))--awaitOrKill ::-  Members [AtomicState InterruptState, Critical, Race, Async, Embed IO] r =>-  Text ->-  A.Async (Maybe a) ->-  Sem r (Maybe a)-awaitOrKill desc handle = do-  interpretSync @() do-    race_ (catchCritical (await handle)) kill-  where-    catchCritical =-      maybe waitKill (pure . Just) <=< Critical.catchAs @AsyncCancelled Nothing-    waitKill =-      Nothing <$ Sync.wait @() (Seconds 1)-    kill = do-      onQuit desc do-        putErr ("killing " <> desc)-        cancel handle-        putErr ("killed " <> desc)-        Sync.putBlock ()-        pure Nothing--interpretInterruptState ::-  Members [AtomicState InterruptState, Critical, Race, Async, Embed IO] r =>-  InterpreterFor Interrupt r-interpretInterruptState =-  interpretH \case-    Register name handler ->-      liftT (registerHandler name handler)-    Unregister name ->-      liftT $ atomicModify' \ s@InterruptState {handlers} -> s {handlers = Map.delete name handlers}-    WaitQuit ->-      liftT waitQuit-    Quit ->-      liftT do-        putErr "manual interrupt"-        void execInterrupt-    Interrupted ->-      liftT . fmap isJust . embed . tryReadMVar =<< atomicGets quit-    KillOnQuit desc ma -> do-      maT <- runT ma-      ins <- getInspectorT-      handle <- raise (interpretInterruptState (async maT))-      result <- liftT (awaitOrKill desc handle)-      pure (join . fmap (inspect ins) <$> result)-{-# inline interpretInterruptState #-}--broadcastInterrupt ::-  Members [AtomicState InterruptState, Embed IO] r =>-  SignalInfo ->-  Sem r ()-broadcastInterrupt sig = do-  putErr "caught interrupt signal"-  orig <- execInterrupt-  orig sig---- The original handler is either the default handler that kills all threads or a handler installed by an environment--- like ghcid.--- In the latter case, not calling it results in ghcid misbehaving.--- To distinguish the two cases, the constructor used by the default is 'Catch', while a custom handler should usually--- use 'CatchOnce', since you don't want to catch repeated occurences of SIGINT, as it will surely cause problems.-originalHandler :: Handler -> (SignalInfo -> IO ())-originalHandler (CatchOnce thunk) =-  (const thunk)-originalHandler (CatchInfoOnce thunk) =-  thunk-originalHandler (Catch thunk) =-  (const thunk)-originalHandler (CatchInfo thunk) =-  thunk-originalHandler _ =-  const unit-{-# inline originalHandler #-}--installSignalHandler ::-  TVar InterruptState ->-  ((SignalInfo -> IO ()) -> Handler) ->-  IO Handler-installSignalHandler state consHandler =-  installHandler keyboardSignal (consHandler handler) Nothing-  where-    handler sig =-      runFinal $ embedToFinal @IO $ runAtomicStateTVar state (broadcastInterrupt sig)---- |Interpret 'Interrupt' by installing a signal handler.------ Takes a constructor for 'Handler'.-interpretInterruptWith ::-  Members [Critical, Race, Async, Embed IO] r =>-  ((SignalInfo -> IO ()) -> Handler) ->-  InterpreterFor Interrupt r-interpretInterruptWith consHandler sem = do-  quitMVar <- embed newEmptyMVar-  finishMVar <- embed newEmptyMVar-  state <- embed (newTVarIO (InterruptState quitMVar finishMVar Set.empty (const unit) Map.empty))-  orig <- embed $ installSignalHandler state consHandler-  runAtomicStateTVar state do-    atomicModify' \ s -> s {original = originalHandler orig}-    interpretInterruptState $ raiseUnder sem---- |Interpret 'Interrupt' by installing a signal handler.------ Catches repeat invocations of SIGINT.-interpretInterrupt ::-  Members [Critical, Race, Async, Embed IO] r =>-  InterpreterFor Interrupt r-interpretInterrupt =-  interpretInterruptWith CatchInfo---- |Interpret 'Interrupt' by installing a signal handler.------ Catches only the first invocation of SIGINT.-interpretInterruptOnce ::-  Members [Critical, Race, Async, Embed IO] r =>-  InterpreterFor Interrupt r-interpretInterruptOnce =-  interpretInterruptWith CatchInfoOnce---- |Eliminate 'Interrupt' without interpreting.-interpretInterruptNull ::-  InterpreterFor Interrupt r-interpretInterruptNull =-  interpretH \case-    Register _ _ ->-      pureT ()-    Unregister _ ->-      pureT ()-    WaitQuit ->-      pureT ()-    Quit ->-      pureT ()-    Interrupted ->-      pureT False-    KillOnQuit _ _ ->-      pureT Nothing
lib/Polysemy/Conc/Interpreter/Lock.hs view
@@ -1,6 +1,6 @@ {-# options_haddock prune #-} --- |Lock interpreters, Internal+-- | Lock interpreters, Internal module Polysemy.Conc.Interpreter.Lock where  import Control.Concurrent (ThreadId, myThreadId)@@ -18,7 +18,7 @@ currentThread =   embed myThreadId --- |Interpret 'Lock' by executing all actions unconditionally.+-- | Interpret 'Lock' by executing all actions unconditionally. interpretLockPermissive ::   InterpreterFor Lock r interpretLockPermissive =@@ -84,7 +84,7 @@         restore (raise alt) {-# inline lockAlt #-} --- |Subinterpreter for 'interpretLockReentrant' that checks whether the current thread is equal to the lock-acquiring+-- | 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 =>@@ -99,7 +99,7 @@       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+-- | 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 =>
lib/Polysemy/Conc/Interpreter/Mask.hs view
@@ -1,6 +1,6 @@ {-# options_haddock prune #-} --- |Description: Mask Interpreters, Internal+-- | Description: Mask Interpreters, Internal module Polysemy.Conc.Interpreter.Mask where  import qualified Control.Exception as Base@@ -8,9 +8,9 @@  import Polysemy.Conc.Effect.Mask (   Mask,+  MaskMode (Interruptible, Uninterruptible),   Restoration (Restoration),   RestoreMask (Restore),-  UninterruptibleMask,   )  mask ::@@ -39,28 +39,42 @@     Restore ma ->       withStrategicToFinal (restore <$> runS (runTSimple ma)) --- |Interpret 'Mask' by sequencing the action without masking.+maskForMode ::+  Member (Final IO) r =>+  MaskMode ->+  (Restoration -> Sem r a) ->+  Sem r a+maskForMode = \case+  Interruptible -> mask+  Uninterruptible -> uninterruptibleMask++-- | Interpret 'Mask' by sequencing the action without masking. interpretMaskPure :: InterpreterFor Mask r interpretMaskPure =   interpretScopedH (const ($ ())) \ () -> \case     Restore ma -> runTSimple ma --- |Interpret 'Mask' in 'IO'.+-- | Interpret 'Mask' in 'IO', dispatching on 'MaskMode' to select 'Base.mask' or 'Base.uninterruptibleMask'. interpretMaskFinal ::   Member (Final IO) r =>   InterpreterFor Mask r interpretMaskFinal =-  runScoped (const mask) \ r -> interpretRestoreMask r+  runScoped maskForMode interpretRestoreMask --- |Interpret 'UninterruptibleMask' by sequencing the action without masking.-interpretUninterruptibleMaskPure :: InterpreterFor UninterruptibleMask r+-- | Interpret 'Mask' by sequencing the action without masking.+--+-- @since 0.14.1.0+{-# deprecated interpretUninterruptibleMaskPure "Use interpretMaskPure, which now handles both variants" #-}+interpretUninterruptibleMaskPure :: InterpreterFor Mask r interpretUninterruptibleMaskPure =-  interpretScopedH (const ($ ())) \ () -> \case-    Restore ma -> runTSimple ma+  interpretMaskPure --- |Interpret 'UninterruptibleMask' in 'IO'.+-- | Interpret 'Mask' in 'IO'.+--+-- @since 0.14.1.0+{-# deprecated interpretUninterruptibleMaskFinal "Use interpretMaskFinal, which now handles both variants" #-} interpretUninterruptibleMaskFinal ::   Member (Final IO) r =>-  InterpreterFor UninterruptibleMask r+  InterpreterFor Mask r interpretUninterruptibleMaskFinal =-  runScoped (const uninterruptibleMask) \ r -> interpretRestoreMask r+  interpretMaskFinal
lib/Polysemy/Conc/Interpreter/Monitor.hs view
@@ -1,6 +1,6 @@ {-# options_haddock prune #-} --- |Description: Monitor Interpreters, Internal+-- | Description: Monitor Interpreters, Internal module Polysemy.Conc.Interpreter.Monitor where  import qualified Control.Exception as Base@@ -18,8 +18,8 @@ import qualified Polysemy.Conc.Effect.Race as Race import Polysemy.Conc.Effect.Race (Race) -newtype CancelResource =-  CancelResource { signal :: MVar () }+data CancelResource =+  CancelResource { kill :: MVar () }  data MonitorCancel =   MonitorCancel@@ -33,15 +33,24 @@   (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 = (CancelResource sig)-      void (embedFinal @IO (tryTakeMVar sig))-      either (const (spin sig)) pure =<< errorToIOFinal @MonitorCancel (fromExceptionSem @MonitorCancel (raise (use res)))+  kill <- embedFinal @IO newEmptyMVar+  start <- embedFinal @IO newEmptyMVar+  let --- |Interpret @'Polysemy.Conc.Scoped' 'Monitor'@ with the 'Polysemy.Conc.Restart' strategy.+    runCheck = do+      embedFinal (readMVar start)+      whenM check $ embedFinal @IO do+        takeMVar start+        void (tryPutMVar kill ())++    spin = do+      let res = CancelResource {..}+      embedFinal (putMVar start ())+      leftA (const spin) =<< errorToIOFinal @MonitorCancel (fromExceptionSem @MonitorCancel (raise (use res)))++  withAsync_ (Time.loop_ @t @d interval runCheck) spin++-- | Interpret @'Polysemy.Conc.Scoped' 'Monitor'@ with the 'Polysemy.Conc.Restart' strategy. -- This takes a check action that may put an 'MVar' when the scoped region should be restarted. -- The check is executed in a loop, with an interval given in 'MonitorCheck'. interpretMonitorRestart ::@@ -51,8 +60,9 @@   InterpreterFor RestartingMonitor r interpretMonitorRestart check =   interpretScopedH (const (monitorRestart @t @d (hoistMonitorCheck raise check))) \ CancelResource {..} -> \case-    Monitor ma ->-      either (const (Base.throw MonitorCancel)) pure =<< Race.race (embedFinal @IO (readMVar signal)) (runTSimple ma)+    Monitor ma -> do+      void (embedFinal @IO (tryTakeMVar kill))+      leftA (const (Base.throw MonitorCancel)) =<< Race.race (embedFinal @IO (readMVar kill)) (runTSimple ma)  interpretMonitorPure' :: () -> InterpreterFor (Monitor action) r interpretMonitorPure' _ =@@ -60,7 +70,7 @@     Monitor ma ->       runTSimple ma --- |Run 'Monitor' as a no-op.+-- | Run 'Monitor' as a no-op. interpretMonitorPure :: InterpreterFor (ScopedMonitor action) r interpretMonitorPure =   runScopedAs (const unit) interpretMonitorPure'
lib/Polysemy/Conc/Interpreter/Queue/Pure.hs view
@@ -1,4 +1,4 @@--- |Description: Pure Queue Interpreters+-- | Description: Pure Queue Interpreters module Polysemy.Conc.Interpreter.Queue.Pure where  import Polysemy.Conc.AtomicState (interpretAtomic)@@ -7,7 +7,7 @@ import qualified Polysemy.Conc.Effect.Queue as Queue import Polysemy.Conc.Effect.Queue (Queue) --- |Reinterpret 'Queue' as 'AtomicState' with a list that cannot be written to.+-- | Reinterpret 'Queue' as 'AtomicState' with a list that cannot be written to. -- Useful for testing. interpretQueueListReadOnlyAtomicWith ::   ∀ d r .@@ -48,7 +48,7 @@         h : _ -> QueueResult.Success h {-# inline interpretQueueListReadOnlyAtomicWith #-} --- |Variant of 'interpretQueueListReadOnlyAtomicWith' that interprets the 'AtomicState'.+-- | Variant of 'interpretQueueListReadOnlyAtomicWith' that interprets the 'AtomicState'. interpretQueueListReadOnlyAtomic ::   ∀ d r .   Member (Embed IO) r =>@@ -58,7 +58,7 @@   interpretAtomic ds (interpretQueueListReadOnlyAtomicWith (raiseUnder sem)) {-# inline interpretQueueListReadOnlyAtomic #-} --- |Reinterpret 'Queue' as 'State' with a list that cannot be written to.+-- | Reinterpret 'Queue' as 'State' with a list that cannot be written to. -- Useful for testing. interpretQueueListReadOnlyStateWith ::   ∀ d r .@@ -99,7 +99,7 @@         h : _ -> QueueResult.Success h {-# inline interpretQueueListReadOnlyStateWith #-} --- |Variant of 'interpretQueueListReadOnlyAtomicWith' that interprets the 'State'.+-- | Variant of 'interpretQueueListReadOnlyAtomicWith' that interprets the 'State'. interpretQueueListReadOnlyState ::   ∀ d r .   [d] ->
lib/Polysemy/Conc/Interpreter/Queue/TB.hs view
@@ -1,4 +1,4 @@--- |Description: Queue Interpreters for 'TBQueue'+-- | Description: Queue Interpreters for 'TBQueue' module Polysemy.Conc.Interpreter.Queue.TB where  import Control.Concurrent.STM (@@ -20,7 +20,7 @@ import Polysemy.Conc.Queue.Result (naResult) import Polysemy.Conc.Queue.Timeout (withTimeout) --- |Interpret 'Queue' with a 'TBQueue'.+-- | Interpret 'Queue' with a 'TBQueue'. -- -- This variant expects an allocated queue as an argument. interpretQueueTBWith ::@@ -53,11 +53,11 @@       unit {-# inline interpretQueueTBWith #-} --- |Interpret 'Queue' with a 'TBQueue'.+-- | Interpret 'Queue' with a 'TBQueue'. interpretQueueTB ::   ∀ d r .   Members [Race, Embed IO] r =>-  -- |Buffer size+  -- | Buffer size   Natural ->   InterpreterFor (Queue d) r interpretQueueTB maxQueued sem = do
lib/Polysemy/Conc/Interpreter/Queue/TBM.hs view
@@ -1,6 +1,6 @@ {-# options_haddock prune #-} --- |Description: Queue Interpreters for 'TBMQueue'+-- | Description: Queue Interpreters for 'TBMQueue' module Polysemy.Conc.Interpreter.Queue.TBM where  import Control.Concurrent.STM (atomically)@@ -23,7 +23,7 @@ import Polysemy.Conc.Queue.Result (closedBoolResult, closedNaResult, closedResult) import Polysemy.Conc.Queue.Timeout (withTimeout) --- |Interpret 'Queue' with a 'TBMQueue'.+-- | Interpret 'Queue' with a 'TBMQueue'. -- -- This variant expects an allocated queue as an argument. interpretQueueTBMWith ::@@ -65,11 +65,11 @@ withTBMQueue maxQueued =   bracket (embed (newTBMQueueIO maxQueued)) (embed . atomically . closeTBMQueue) --- |Interpret 'Queue' with a 'TBMQueue'.+-- | Interpret 'Queue' with a 'TBMQueue'. interpretQueueTBM ::   ∀ d r .   Members [Resource, Race, Embed IO] r =>-  -- |Buffer size+  -- | Buffer size   Int ->   InterpreterFor (Queue d) r interpretQueueTBM maxQueued sem = do
lib/Polysemy/Conc/Interpreter/Race.hs view
@@ -1,5 +1,5 @@ {-# options_haddock prune #-}--- |Description: Race Interpreters+-- | Description: Race Interpreters module Polysemy.Conc.Interpreter.Race where  import qualified Control.Concurrent.Async as Async@@ -19,7 +19,7 @@   either (fmap Left) (fmap Right) {-# inline biseqEither #-} --- |Interpret 'Race' in terms of 'Async.race' and 'System.timeout'.+-- | Interpret 'Race' in terms of 'Async.race' and 'System.timeout'. -- Since this has to pass higher-order thunks as 'IO' arguments, it is interpreted in terms of 'Final IO'. interpretRace ::   Member (Final IO) r =>
− lib/Polysemy/Conc/Interpreter/Scoped.hs 
@@ -1,640 +0,0 @@-{-# options_haddock prune #-}---- |Description: Scoped Interpreters, Internal-module Polysemy.Conc.Interpreter.Scoped where--import GHC.Err (errorWithoutStackTrace)-import Polysemy.Internal (Sem (Sem), hoistSem, liftSem, runSem)-import Polysemy.Internal.Sing (KnownList (singList))-import Polysemy.Internal.Tactics (liftT)-import Polysemy.Internal.Union (-  Union (Union),-  Weaving (Weaving),-  decomp,-  extendMembershipLeft,-  hoist,-  injWeaving,-  injectMembership,-  weave,-  )-import Polysemy.Membership (ElemOf)-import Polysemy.Resume (Stop, interpretResumableH, runStop, type (!!))-import Polysemy.Resume.Effect.Resumable (Resumable (Resumable))-import Prelude hiding (Scoped, interpretScoped, interpretScopedH, interpretScopedWithH, runScoped)--import Polysemy.Conc.Effect.Scoped (Scoped (InScope, Run))--interpretWeaving ::-  ∀ e r .-  (∀ x . Weaving e (Sem (e : r)) x -> Sem r x) ->-  InterpreterFor e r-interpretWeaving h (Sem m) =-  Sem \ k -> m $ decomp >>> \case-    Right wav -> runSem (h wav) k-    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 #-}--exResumable ::-  Functor f =>-  f () ->-  (f (Either err a) -> x) ->-  (f' a' -> a) ->-  Sem r (Either err (f (f' a'))) ->-  Sem r x-exResumable s ex ex' =-  fmap $ ex . \case-    Right a -> Right . ex' <$> a-    Left err -> Left err <$ s-{-# inline exResumable #-}---- | 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.------ 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 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 param effect) r-interpretScopedH withResource scopedHandler =-  interpretWeaving $ \(Weaving effect s wv ex _) -> case effect of-    Run _ -> errorWithoutStackTrace "top level run"-    InScope param main -> withResource param \ resource ->-          ex-      <$> interpretH (scopedHandler resource) (go $ raiseUnder $ wv (main <$ s))-  where-    -- TODO investigate whether loopbreaker optimization is effective here-    go :: InterpreterFor (Scoped param effect) (effect : r)-    go =-      interpretWeaving \ (Weaving effect s wv ex ins) -> case effect of-        Run act -> liftSem $ injWeaving $ Weaving act s (go . wv) ex ins-        InScope param main -> raise $ withResource param \ resource ->-          ex <$> interpretH (scopedHandler resource) (go $ wv (main <$ s))-{-# inline interpretScopedH #-}---- | 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 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.-interpretScopedAs ::-  ∀ 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 \ 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 .-  KnownList extra =>-  r1 ~ (extra ++ r) =>-  (∀ 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 ->-        interpretH (scopedHandler resource) $ inScope $-          restack-            (injectMembership-             (singList @'[Scoped param effect])-             (singList @(effect : extra))) $ wv (main <$ s)-    _ ->-      errorWithoutStackTrace "top level Run"-  where-    inScope :: InterpreterFor (Scoped param effect) (effect : r1)-    inScope =-      interpretWeaving \case-        Weaving (InScope param main) s wv ex _ ->-          restack-            (extendMembershipLeft (singList @(effect : extra)))-            (ex <$> withResource param \resource ->-                interpretH (scopedHandler resource) $ inScope $ wv (main <$ s))-        Weaving (Run act) s wv ex ins ->-          liftSem $ injWeaving $ Weaving act s (inScope . wv) ex ins-{-# 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/: In previous versions of Polysemy, the wrapped interpreter was--- executed fully, including the initializing code surrounding its handler,--- for each action in the program. However, new and continuing discoveries--- regarding 'Scoped' has allowed the improvement of having the interpreter be--- used only once per use of 'scoped', and have it cover the same scope of--- actions that @withResource@ does.------ This renders @withResource@ practically redundant; for the moment, the API--- surrounding 'Scoped' remains the same, but work is in progress to revamp the--- entire API of 'Scoped'.-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 =-  interpretWeaving \(Weaving effect s wv ex _) -> case effect of-    Run _ -> errorWithoutStackTrace "top level run"-    InScope param main -> withResource param \ resource ->-      ex <$> scopedInterpreter resource (go (raiseUnder $ wv (main <$ s)))-  where-    go :: InterpreterFor (Scoped param effect) (effect : r)-    go =-      interpretWeaving \ (Weaving effect s wv ex ins) -> case effect of-        Run act -> liftSem $ injWeaving $ Weaving act s (go . wv) ex ins-        InScope param main ->-          raise $ withResource param \ resource ->-            ex <$> scopedInterpreter resource (go (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, terminating the--- entire scope.-interpretScopedResumableH ::-  ∀ 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 param effect !! err) r-interpretScopedResumableH withResource scopedHandler =-  interpretWeaving \case-    Weaving (Resumable (Weaving (InScope param main) s' wv' ex' _)) s wv ex _ -> do-      exResumable s ex ex' $ runStop $ withResource param \ resource ->-        interpretH (scopedHandler resource) (raiseUnder (go $ raiseUnder $ wv ((wv' (main <$ s')) <$ s)))-    _ ->-      errorWithoutStackTrace "top level run"-  where-    go :: InterpreterFor (Scoped param effect !! err) (effect : r)-    go =-      interpretWeaving \ (Weaving (Resumable (Weaving effect s' wv' ex' ins')) s wv ex ins) -> case effect of-        Run act ->-          ex . fmap Right <$> liftSem (weave s (go . wv) ins (injWeaving (Weaving act s' wv' ex' ins')))-        InScope param main -> do-          exResumable s ex ex' $ raise $ runStop $ withResource param \ resource ->-            interpretH (scopedHandler resource) (raiseUnder (go $ wv (wv' (main <$ s') <$ s)))---- |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.-interpretScopedResumable ::-  ∀ 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 param effect !! err) r-interpretScopedResumable withResource scopedHandler =-  interpretScopedResumableH withResource \ r e -> liftT (scopedHandler r 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 param resource effect err r r1 extraerr .-  extraerr ~ (extra ++ '[Stop err]) =>-  r1 ~ (extraerr ++ r) =>-  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 param effect !! err) r-interpretScopedResumableWithH withResource scopedHandler =-  interpretWeaving \case-    Weaving (Resumable (Weaving (InScope param main) s' wv' ex' _)) s wv ex _ -> do-      exResumable s ex ex' $ runStop $ withResource param \ resource ->-        interpretH (scopedHandler resource) $ inScope $-          restack-            (injectMembership-             (singList @'[Scoped param effect !! err])-             (singList @(effect : extraerr))) $ wv (wv' (main <$ s') <$ s)-    _ ->-      errorWithoutStackTrace "top level Run"-  where-    inScope :: InterpreterFor (Scoped param effect !! err) (effect : r1)-    inScope =-      interpretWeaving \ (Weaving (Resumable (Weaving effect s' wv' ex' ins')) s wv ex ins) -> case effect of-        InScope param main ->-          restack-            (extendMembershipLeft (singList @(effect : extraerr))) $-            exResumable s ex ex' $ runStop $ withResource param \ resource ->-              interpretH (scopedHandler resource) (inScope $ wv (wv' (main <$ s') <$ s))-        Run act ->-          ex . fmap Right <$> liftSem (weave s (inScope . wv) ins (injWeaving (Weaving act s' wv' ex' ins')))---- |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 param resource effect err r r1 .-  r1 ~ ((extra ++ '[Stop err]) ++ r) =>-  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 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 param effect err r r1 .-  r1 ~ ((extra ++ '[Stop err]) ++ r) =>-  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 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 !! err) (Sem r0) (Stop err : r) x) ->-  InterpreterFor (Scoped param (effect !! err)) r-interpretResumableScopedH withResource scopedHandler =-  interpretWeaving $ \(Weaving effect s wv ex _) -> case effect of-    Run _ -> errorWithoutStackTrace "top level run"-    InScope param main -> withResource param \ resource ->-      ex <$> interpretResumableH (scopedHandler resource) (inScope $ raiseUnder $ wv (main <$ s))-  where-    inScope :: InterpreterFor (Scoped param (effect !! err)) (effect !! err : r)-    inScope =-      interpretWeaving \ (Weaving effect s wv ex ins) -> case effect of-        Run act -> liftSem $ injWeaving $ Weaving act s (inScope . wv) ex ins-        InScope param main -> raise $ withResource param \ resource ->-          ex <$> interpretResumableH (scopedHandler resource) (inScope $ wv (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 !! err) (Sem r0) (Stop err : r1) x) ->-  InterpreterFor (Scoped param (effect !! err)) r-interpretResumableScopedWithH withResource scopedHandler =-  interpretWeaving \case-    Weaving (InScope param main) s wv ex _ ->-      ex <$> withResource param \ resource ->-        interpretResumableH (scopedHandler resource) $ inScope $-          restack-            (injectMembership-             (singList @'[Scoped param (effect !! err)])-             (singList @(effect !! err : extra))) $ wv (main <$ s)-    _ ->-      errorWithoutStackTrace "top level Run"-  where-    inScope :: InterpreterFor (Scoped param (effect !! err)) (effect !! err : r1)-    inScope =-      interpretWeaving \case-        Weaving (InScope param main) s wv ex _ ->-          restack-            (extendMembershipLeft (singList @(effect !! err : extra)))-            (ex <$> withResource param \resource ->-                interpretResumableH (scopedHandler resource) $ inScope $ wv (main <$ s))-        Weaving (Run act) s wv ex ins ->-          liftSem $ injWeaving $ Weaving act s (inScope . wv) ex ins---- |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 !! ei) (Sem r0) (Stop ei : Stop eo : r) x) ->-  InterpreterFor (Scoped param (effect !! ei) !! eo) r-interpretScopedRH withResource scopedHandler =-  interpretWeaving \case-    Weaving (Resumable (Weaving (InScope param main) s' wv' ex' _)) s wv ex _ -> do-      exResumable s ex ex' $ runStop $ withResource param \ resource ->-        interpretResumableH (scopedHandler resource) (raiseUnder (inScope $ raiseUnder $ wv (wv' (main <$ s') <$ s)))-    _ ->-      errorWithoutStackTrace "top level run"-  where-    inScope :: InterpreterFor (Scoped param (effect !! ei) !! eo) (effect !! ei : r)-    inScope =-      interpretWeaving \ (Weaving (Resumable (Weaving effect s' wv' ex' ins')) s wv ex ins) -> case effect of-        Run act ->-          ex . fmap Right <$> liftSem (weave s (inScope . wv) ins (injWeaving (Weaving act s' wv' ex' ins')))-        InScope param main -> do-          exResumable s ex ex' $ raise $ runStop $ withResource param \ resource ->-            interpretResumableH (scopedHandler resource) (raiseUnder (inScope $ wv (wv' (main <$ s') <$ s)))---- |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 : Stop eo : 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 : Stop eo : 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 extraerr .-  extraerr ~ (extra ++ '[Stop eo]) =>-  r1 ~ (extra ++ Stop eo : r) =>-  r1 ~ ((extra ++ '[Stop eo]) ++ r) =>-  KnownList (extra ++ '[Stop eo]) =>-  (∀ x . param -> (resource -> Sem (extra ++ Stop eo : r) x) -> Sem (Stop eo : r) x) ->-  (∀ r0 x . resource -> effect (Sem r0) x -> Tactical (effect !! ei) (Sem r0) (Stop ei : r1) x) ->-  InterpreterFor (Scoped param (effect !! ei) !! eo) r-interpretScopedRWithH withResource scopedHandler =-  interpretWeaving \case-    Weaving (Resumable (Weaving (InScope param main) s' wv' ex' _)) s wv ex _ -> do-      exResumable s ex ex' $ runStop $ withResource param \ resource ->-        interpretResumableH (scopedHandler resource) $ inScope $-          restack-            (injectMembership-             (singList @'[Scoped param (effect !! ei) !! eo])-             (singList @(effect !! ei : extraerr))) $ wv (wv' (main <$ s') <$ s)-    _ ->-      errorWithoutStackTrace "top level Run"-  where-    inScope :: InterpreterFor (Scoped param (effect !! ei) !! eo) (effect !! ei : r1)-    inScope =-      interpretWeaving \ (Weaving (Resumable (Weaving effect s' wv' ex' ins')) s wv ex ins) -> case effect of-        InScope param main ->-          exResumable s ex ex' $-          restack (extendMembershipLeft (singList @(effect !! ei : extraerr))) $-          runStop $-          withResource param \ resource ->-            interpretResumableH (scopedHandler resource) (inScope $ wv (wv' (main <$ s') <$ s))-        Run act ->-          ex . fmap Right <$> liftSem (weave s (inScope . wv) ins (injWeaving (Weaving act s' wv' ex' ins')))---- |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 ++ '[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 ++ '[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)
lib/Polysemy/Conc/Interpreter/Semaphore.hs view
@@ -1,4 +1,4 @@--- |Semaphore interpreters, Internal.+-- | Semaphore interpreters, Internal. module Polysemy.Conc.Interpreter.Semaphore where  import Control.Concurrent (QSem, newQSem, signalQSem, waitQSem)@@ -8,7 +8,7 @@ import qualified Polysemy.Conc.Effect.Semaphore as Semaphore import Polysemy.Conc.Effect.Semaphore (Semaphore) --- |Interpret 'Semaphore' using the supplied 'QSem'.+-- | Interpret 'Semaphore' using the supplied 'QSem'. interpretSemaphoreQWith ::   Member (Embed IO) r =>   QSem ->@@ -21,7 +21,7 @@       embed (signalQSem qsem) {-# inline interpretSemaphoreQWith #-} --- |Interpret 'Semaphore' as a 'QSem'.+-- | Interpret 'Semaphore' as a 'QSem'. interpretSemaphoreQ ::   Member (Embed IO) r =>   Int ->@@ -31,7 +31,7 @@   interpretSemaphoreQWith qsem sem {-# inline interpretSemaphoreQ #-} --- |Interpret 'Semaphore' using the supplied 'TSem'.+-- | Interpret 'Semaphore' using the supplied 'TSem'. interpretSemaphoreTWith ::   Member (Embed IO) r =>   TSem ->@@ -44,7 +44,7 @@       embed (atomically (signalTSem qsem)) {-# inline interpretSemaphoreTWith #-} --- |Interpret 'Semaphore' as a 'TSem'.+-- | Interpret 'Semaphore' as a 'TSem'. interpretSemaphoreT ::   Member (Embed IO) r =>   Integer ->
lib/Polysemy/Conc/Interpreter/Stack.hs view
@@ -1,19 +1,18 @@ {-# options_haddock prune #-} --- |Description: Convenience Interpreters for all Conc Effects, Internal+-- | 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.Mask (Mask) import Polysemy.Conc.Effect.Race (Race) import Polysemy.Conc.Interpreter.Gate (interpretGates)-import Polysemy.Conc.Interpreter.Mask (interpretMaskFinal, interpretUninterruptibleMaskFinal)+import Polysemy.Conc.Interpreter.Mask (interpretMaskFinal) import Polysemy.Conc.Interpreter.Race (interpretRace) --- |A default basic stack with 'Final' for _polysemy-conc_.+-- | A default basic stack with 'Final' for _polysemy-conc_. type ConcStack =   [-    UninterruptibleMask,     Mask,     Gates,     Race,@@ -23,7 +22,7 @@     Final IO   ] --- |Interprets 'UninterruptibleMask', 'Mask' and 'Race' in terms of @'Final' 'IO'@ and runs the entire rest of the+-- | Interprets 'Mask' and 'Race' in terms of @'Final' 'IO'@ and runs the entire rest of the -- stack. runConc ::   Sem ConcStack a ->@@ -35,5 +34,4 @@   asyncToIOFinal .   interpretRace .   interpretGates .-  interpretMaskFinal .-  interpretUninterruptibleMaskFinal+  interpretMaskFinal
lib/Polysemy/Conc/Interpreter/Sync.hs view
@@ -1,4 +1,4 @@--- |Description: Sync Interpreters+-- | Description: Sync Interpreters module Polysemy.Conc.Interpreter.Sync where  import Polysemy.Conc.Effect.Race (Race)@@ -6,7 +6,7 @@ import Polysemy.Conc.Effect.Sync (Sync) import qualified Polysemy.Conc.Race as Race --- |Interpret 'Sync' with the provided 'MVar'.+-- | Interpret 'Sync' with the provided 'MVar'. interpretSyncWith ::   ∀ d r .   Members [Race, Embed IO] r =>@@ -35,7 +35,7 @@     Sync.Empty ->       embed (isEmptyMVar var) --- |Interpret 'Sync' with an empty 'MVar'.+-- | Interpret 'Sync' with an empty 'MVar'. interpretSync ::   ∀ d r .   Members [Race, Embed IO] r =>@@ -44,7 +44,7 @@   var <- embed newEmptyMVar   interpretSyncWith var sem --- |Interpret 'Sync' with an 'MVar' containing the specified value.+-- | Interpret 'Sync' with an 'MVar' containing the specified value. interpretSyncAs ::   ∀ d r .   Members [Race, Embed IO] r =>@@ -54,7 +54,7 @@   var <- embed (newMVar d)   interpretSyncWith var sem --- |Interpret 'Sync' for locally scoped use with an empty 'MVar'.+-- | Interpret 'Sync' for locally scoped use with an empty 'MVar'. interpretScopedSync ::   ∀ d r .   Members [Resource, Race, Embed IO] r =>@@ -62,7 +62,7 @@ interpretScopedSync =   runScopedAs (const (embed newEmptyMVar)) \ r -> interpretSyncWith r --- |Interpret 'Sync' for locally scoped use with an 'MVar' containing the specified value.+-- | Interpret 'Sync' for locally scoped use with an 'MVar' containing the specified value. interpretScopedSyncAs ::   ∀ d r .   Members [Resource, Race, Embed IO] r =>
lib/Polysemy/Conc/Interpreter/SyncRead.hs view
@@ -1,4 +1,4 @@--- |Description: Interpreter for 'SyncRead' that reinterprets to 'Sync'.+-- | Description: Interpreter for 'SyncRead' that reinterprets to 'Sync'. module Polysemy.Conc.Interpreter.SyncRead where  import qualified Polysemy.Conc.Effect.Sync as Sync@@ -6,7 +6,7 @@ import qualified Polysemy.Conc.Effect.SyncRead as SyncRead import Polysemy.Conc.Effect.SyncRead (SyncRead) --- |Run 'SyncRead' in terms of 'Sync'.+-- | Run 'SyncRead' in terms of 'Sync'. syncRead ::   ∀ d r .   Member (Sync d) r =>
lib/Polysemy/Conc/Monitor.hs view
@@ -1,6 +1,6 @@ {-# options_haddock prune #-} --- |Description: Monitor Implementations, Internal+-- | Description: Monitor Implementations, Internal module Polysemy.Conc.Monitor where  import qualified Polysemy.Time as Time@@ -9,7 +9,7 @@  import Polysemy.Conc.Effect.Monitor (MonitorCheck (MonitorCheck)) --- |Config for 'monitorClockSkew'.+-- | Config for 'monitorClockSkew'. data ClockSkewConfig =   ClockSkewConfig {     interval :: NanoSeconds,@@ -17,7 +17,7 @@   }   deriving stock (Eq, Show) --- |Smart constructor for 'ClockSkewConfig' that takes arbitrary 'TimeUnit's.+-- | Smart constructor for 'ClockSkewConfig' that takes arbitrary 'TimeUnit's. clockSkewConfig ::   TimeUnit u1 =>   TimeUnit u2 =>@@ -31,7 +31,7 @@   def =     clockSkewConfig (Minutes 1) (Seconds 5) --- |Check for 'Polysemy.Conc.Effect.Monitor' that checks every @interval@ whether the difference between the current+-- | Check for 'Polysemy.Conc.Effect.Monitor' that checks every @interval@ whether the difference between the current -- time and the time at the last check is larger than @interval@ + @tolerance@. -- Can be used to detect that the operating system suspended and resumed. monitorClockSkew ::@@ -42,12 +42,8 @@   ClockSkewConfig ->   MonitorCheck r monitorClockSkew (ClockSkewConfig interval tolerance) =-  MonitorCheck interval \ signal -> do-    atomicGet >>= \case-      Just prev -> do-        now <- Time.now @t @d-        when (minus (convert (difference now prev)) tolerance > interval) (void (embed @IO (tryPutMVar signal ())))-        atomicPut (Just now)-      Nothing -> do-        now <- Time.now @t @d-        atomicPut (Just now)+  MonitorCheck interval do+    now <- Time.now @t @d+    atomicState \ s -> (Just now, maybe False (skewed now) s)+  where+    skewed now prev = minus (convert (difference now prev)) tolerance > interval
lib/Polysemy/Conc/Queue.hs view
@@ -1,5 +1,5 @@ {-# options_haddock prune #-}--- |Description: Queue Combinators+-- | Description: Queue Combinators module Polysemy.Conc.Queue (   module Polysemy.Conc.Queue,   module Polysemy.Conc.Effect.Queue,@@ -24,7 +24,7 @@   ) import Polysemy.Conc.Queue.Result (resultToMaybe) --- |Read from a 'Queue' repeatedly until it is closed.+-- | Read from a 'Queue' repeatedly until it is closed. -- -- When an element is received, call @action@ and recurse if it returns 'True'. -- When no element is available, evaluate @na@ and recurse if it returns 'True'.@@ -42,7 +42,7 @@         QueueResult.NotAvailable -> whenM na spin         QueueResult.Closed -> unit --- |Read from a 'Queue' repeatedly until it is closed.+-- | Read from a 'Queue' repeatedly until it is closed. -- -- When an element is received, call @action@ and recurse. loop ::@@ -52,7 +52,7 @@ loop action =   loopOr (pure True) \ d -> True <$ action d --- |Read from a 'Queue' and convert the result to 'Maybe', returning 'Nothing' if the queue has been closed, and+-- | 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 =>@@ -60,7 +60,7 @@ readMaybe =   resultToMaybe <$> read --- |Read from a 'Queue' and convert the result to 'Maybe', returning 'Nothing' if there is no element available or the+-- | 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 =>
lib/Polysemy/Conc/Queue/Result.hs view
@@ -38,7 +38,7 @@   Just True -> QueueResult.Success () {-# inline closedBoolResult #-} --- |Turn a 'QueueResult.Success' into 'Just'.+-- | Turn a 'QueueResult.Success' into 'Just'. resultToMaybe :: QueueResult d -> Maybe d resultToMaybe = \case   QueueResult.Success d -> Just d
lib/Polysemy/Conc/Queue/Timeout.hs view
@@ -1,4 +1,4 @@--- |Description: Timeout Helper+-- | Description: Timeout Helper module Polysemy.Conc.Queue.Timeout where  import Control.Concurrent.STM (STM, atomically)@@ -9,7 +9,7 @@ import Polysemy.Conc.Effect.Race (Race) import qualified Polysemy.Conc.Race as Race --- |Run an 'STM' action atomically with a time limit+-- | Run an 'STM' action atomically with a time limit withTimeout ::   TimeUnit t =>   Members [Race, Embed IO] r =>
lib/Polysemy/Conc/Race.hs view
@@ -1,4 +1,4 @@--- |Description: Race Combinators+-- | Description: Race Combinators module Polysemy.Conc.Race where  import Polysemy.Time (TimeUnit)@@ -7,7 +7,7 @@ import Polysemy.Conc.Effect.Race (Race) import Polysemy.Resume (Stop, stop) --- |Specialization of 'Race.race' for the case where both actions 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 ->@@ -17,7 +17,7 @@   unify <$> Race.race ml mr {-# inline race_ #-} --- |Specialization of 'Race.timeout' for the case where the main action returns the same type as the fallback, obviating+-- | 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 =>@@ -30,7 +30,7 @@   unify <$> Race.timeout err interval ma {-# inline timeout_ #-} --- |Version of `Race.timeout` that takes a pure fallback value.+-- | Version of `Race.timeout` that takes a pure fallback value. timeoutAs ::   TimeUnit u =>   Member Race r =>@@ -42,7 +42,7 @@   Race.timeout (pure err) {-# inline timeoutAs #-} --- |Specialization of 'timeoutAs' for the case where the main action 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 =>@@ -55,7 +55,7 @@   timeout_ (pure err) {-# inline timeoutAs_ #-} --- |Specialization of 'Race.timeout' for unit actions.+-- | Specialization of 'Race.timeout' for unit actions. timeoutU ::   TimeUnit u =>   Member Race r =>@@ -66,7 +66,7 @@   timeout_ unit {-# inline timeoutU #-} --- |Variant of 'Race.timeout' that returns 'Maybe'.+-- | Variant of 'Race.timeout' that returns 'Maybe'. timeoutMaybe ::   TimeUnit u =>   Member Race r =>@@ -77,7 +77,7 @@   timeoutAs_ Nothing u (Just <$> ma) {-# inline timeoutMaybe #-} --- |Variant of 'Race.timeout' that calls 'Stop' with the supplied error when the action times out.+-- | Variant of 'Race.timeout' that calls 'Stop' with the supplied error when the action times out. timeoutStop ::   TimeUnit u =>   Members [Race, Stop err] r =>
lib/Polysemy/Conc/Retry.hs view
@@ -1,4 +1,4 @@--- |Description: Action Retrying+-- | Description: Action Retrying module Polysemy.Conc.Retry where  import qualified Polysemy.Time as Time@@ -9,15 +9,15 @@ import Polysemy.Conc.Interpreter.Sync (interpretSync) import qualified Polysemy.Conc.Race as Race --- |Run an action repeatedly until it returns 'Right' or the timout has been exceeded.+-- | Run an action repeatedly until it returns 'Right' or the timout has been exceeded. retrying ::   ∀ e w u t d r a .   TimeUnit w =>   TimeUnit u =>   Members [Race, Time t d] r =>-  -- |The timeout after which the attempt is abandoned.+  -- | The timeout after which the attempt is abandoned.   w ->-  -- |The waiting interval between two tries.+  -- | The waiting interval between two tries.   u ->   Sem r (Either e a) ->   Sem r (Maybe a)@@ -32,7 +32,7 @@           Time.sleep @t @d interval           spin --- |Run an action repeatedly until it returns 'Right' or the timout has been exceeded.+-- | Run an action repeatedly until it returns 'Right' or the timout has been exceeded. -- -- If the action failed at least once, the last error will be returned in case of timeout. retryingWithError ::@@ -40,9 +40,9 @@   TimeUnit w =>   TimeUnit u =>   Members [Race, Time t d, Embed IO] r =>-  -- |The timeout after which the attempt is abandoned.+  -- | The timeout after which the attempt is abandoned.   w ->-  -- |The waiting interval between two tries.+  -- | The waiting interval between two tries.   u ->   Sem r (Either e a) ->   Sem r (Maybe (Either e a))
lib/Polysemy/Conc/Semaphore.hs view
@@ -1,4 +1,4 @@--- |A quantity semaphore effect.+-- | A quantity semaphore effect. module Polysemy.Conc.Semaphore (   Semaphore,   interpretSemaphoreQ,
lib/Polysemy/Conc/Sync.hs view
@@ -1,6 +1,6 @@ {-# options_haddock prune #-} --- |Description: Sync Combinators+-- | Description: Sync Combinators module Polysemy.Conc.Sync (   module Polysemy.Conc.Sync,   module Polysemy.Conc.Effect.Sync,@@ -13,7 +13,7 @@ import qualified Polysemy.Conc.Effect.Sync as Sync import Polysemy.Conc.Effect.Sync --- |Run an action repeatedly until the 'Sync' variable is available.+-- | Run an action repeatedly until the 'Sync' variable is available. whileEmpty ::   ∀ a r .   Member (Sync a) r =>@@ -26,7 +26,7 @@       action       whenM (not <$> Sync.empty @a) spin --- |Run an action repeatedly until the 'Sync' variable is available, waiting for the specified time between executions.+-- | Run an action repeatedly until the 'Sync' variable is available, waiting for the specified time between executions. whileEmptyInterval ::   ∀ a u t d r .   TimeUnit u =>@@ -41,7 +41,7 @@       action       whenM (not <$> Sync.empty @a) (Time.sleep @t @d interval *> spin) --- |Run an action with a locally scoped 'Sync' variable.+-- | 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 ::@@ -51,7 +51,7 @@ withSync =   scoped_ --- |Run the action @ma@ with an exclusive lock (mutex).+-- | 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. -- The value @l@ is used to disambiguate the 'Sync' from other uses of the combinator. -- You can pass in something like @Proxy @"db-write"@.@@ -67,7 +67,7 @@   finally (takeBlock @l *> ma) (putTry l) {-# inline lock #-} --- |Remove the content of the 'Sync' variable if it is present.+-- | Remove the content of the 'Sync' variable if it is present. clear ::   ∀ a r .   Member (Sync a) r =>@@ -76,7 +76,7 @@   void (takeTry @a) {-# inline clear #-} --- |Modify a 'Sync' variable with async exceptions masked for the 'Sync' operations, but not the action.+-- | Modify a 'Sync' variable with async exceptions masked for the 'Sync' operations, but not the action. -- Allows a value to be returned. -- Equivalent to 'Control.Concurrent.MVar.modifyMVar'. modify ::@@ -91,7 +91,7 @@     b <$ putBlock a' {-# inline modify #-} --- |Modify a 'Sync' variable with async exceptions masked for the 'Sync' operations, but not the action.+-- | Modify a 'Sync' variable with async exceptions masked for the 'Sync' operations, but not the action. -- Does not allow a value to be returned. -- Equivalent to 'Control.Concurrent.MVar.modifyMVar_'. modify_ ::@@ -106,7 +106,7 @@     putBlock a' {-# inline modify_ #-} --- |Modify a 'Sync' variable with async exceptions masked for the entire procedure.+-- | Modify a 'Sync' variable with async exceptions masked for the entire procedure. -- Allows a value to be returned. -- Equivalent to 'Control.Concurrent.MVar.modifyMVarMasked'. modifyMasked ::@@ -121,7 +121,7 @@     b <$ putBlock a' {-# inline modifyMasked #-} --- |Modify a 'Sync' variable with async exceptions masked for the entire procedure.+-- | Modify a 'Sync' variable with async exceptions masked for the entire procedure. -- Does not allow a value to be returned. -- Equivalent to 'Control.Concurrent.MVar.modifyMVarMasked_'. modifyMasked_ ::@@ -136,7 +136,7 @@     putBlock a' {-# inline modifyMasked_ #-} --- |Run an action with the current value of the 'Sync' variable with async exceptions masked for the 'Sync' operations,+-- | Run an action with the current value of the 'Sync' variable with async exceptions masked for the 'Sync' operations, -- but not the action. -- Equivalent to 'Control.Concurrent.MVar.withMVar'. use ::@@ -150,7 +150,7 @@     finally (restore (raise (m a))) (putBlock a) {-# inline use #-} --- |Run an action with the current value of the 'Sync' variable with async exceptions masked for the entire procedure.+-- | 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 r .
lib/Polysemy/Conc/SyncRead.hs view
@@ -1,6 +1,6 @@ {-# options_haddock prune #-} --- |Description: API and combinators for 'SyncRead'.+-- | Description: API and combinators for 'SyncRead'. module Polysemy.Conc.SyncRead (   module Polysemy.Conc.SyncRead,   module Polysemy.Conc.Effect.SyncRead,@@ -12,7 +12,7 @@ import qualified Polysemy.Conc.Effect.SyncRead as SyncRead import Polysemy.Conc.Effect.SyncRead (SyncRead, block, empty, try, wait) --- |Run an action repeatedly until the 'SyncRead' variable is available.+-- | Run an action repeatedly until the 'SyncRead' variable is available. whileEmpty ::   ∀ a r .   Member (SyncRead a) r =>@@ -25,7 +25,7 @@       action       whenM (not <$> SyncRead.empty @a) spin --- |Run an action repeatedly until the 'SyncRead' variable is available, waiting for the specified time between executions.+-- | Run an action repeatedly until the 'SyncRead' variable is available, waiting for the specified time between executions. whileEmptyInterval ::   ∀ a u t d r .   TimeUnit u =>
polysemy-conc.cabal view
@@ -1,29 +1,29 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.35.0.+-- This file has been generated from package.yaml by hpack version 0.38.2. -- -- see: https://github.com/sol/hpack  name:           polysemy-conc-version:        0.12.1.0+version:        0.15.0.0 synopsis:       Polysemy effects for concurrency description:    See https://hackage.haskell.org/package/polysemy-conc/docs/Polysemy-Conc.html category:       Concurrency-homepage:       https://git.tryp.io/tek/polysemy-conc+homepage:       https://github.com/tek/polysemy-conc#readme bug-reports:    https://github.com/tek/polysemy-conc/issues author:         Torsten Schmits maintainer:     hackage@tryp.io-copyright:      2022 Torsten Schmits+copyright:      2025 Torsten Schmits license:        BSD-2-Clause-Patent license-file:   LICENSE build-type:     Simple extra-source-files:-    changelog.md     readme.md+    changelog.md  source-repository head   type: git-  location: https://git.tryp.io/tek/polysemy-conc+  location: https://github.com/tek/polysemy-conc  library   exposed-modules:@@ -34,13 +34,11 @@       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@@ -49,7 +47,6 @@       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@@ -57,7 +54,6 @@       Polysemy.Conc.Interpreter.Queue.TB       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@@ -76,179 +72,123 @@   default-extensions:       AllowAmbiguousTypes       ApplicativeDo-      BangPatterns-      BinaryLiterals       BlockArguments-      ConstraintKinds       DataKinds       DefaultSignatures       DeriveAnyClass-      DeriveDataTypeable-      DeriveFoldable-      DeriveFunctor-      DeriveGeneric-      DeriveLift-      DeriveTraversable       DerivingStrategies       DerivingVia       DisambiguateRecordFields-      DoAndIfThenElse       DuplicateRecordFields-      EmptyCase-      EmptyDataDecls-      ExistentialQuantification-      FlexibleContexts-      FlexibleInstances       FunctionalDependencies       GADTs-      GeneralizedNewtypeDeriving-      InstanceSigs-      KindSignatures       LambdaCase       LiberalTypeSynonyms-      MultiParamTypeClasses+      MonadComprehensions       MultiWayIf-      NamedFieldPuns+      NoFieldSelectors       OverloadedLabels       OverloadedLists+      OverloadedRecordDot       OverloadedStrings       PackageImports       PartialTypeSignatures-      PatternGuards       PatternSynonyms-      PolyKinds       QuantifiedConstraints       QuasiQuotes-      RankNTypes       RecordWildCards       RecursiveDo       RoleAnnotations-      ScopedTypeVariables-      StandaloneDeriving       TemplateHaskell-      TupleSections-      TypeApplications       TypeFamilies       TypeFamilyDependencies-      TypeOperators-      TypeSynonymInstances       UndecidableInstances       UnicodeSyntax       ViewPatterns-  ghc-options: -Wall -Wredundant-constraints -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Widentities -Wunused-packages+  ghc-options: -Wall -Widentities -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Wredundant-constraints -Wunused-type-patterns -Wunused-packages   build-depends:-      async-    , base >=4.12 && <5-    , containers-    , incipit-core >=0.4.1-    , polysemy ==1.9.*-    , polysemy-resume ==0.7.*-    , polysemy-time ==0.6.*-    , stm-    , stm-chans >=3 && <3.1+      async >=2.2.4 && <2.3+    , base >=4.17.2.1 && <4.22+    , incipit-core >=0.4.1.0 && <0.8+    , polysemy >=1.9.0.0 && <1.10+    , polysemy-resume >=0.7.0.0 && <0.10+    , polysemy-time >=0.5.1.0 && <0.8+    , stm >=2.5.1.0 && <2.6+    , stm-chans >=2.0.0 && <3.1     , torsor ==0.1.*-    , unagi-chan ==0.4.*-    , unix+    , unagi-chan >=0.4.1.3 && <0.5   mixins:       base hiding (Prelude)     , incipit-core (IncipitCore as Prelude)     , incipit-core hiding (IncipitCore)-  default-language: Haskell2010+  default-language: GHC2021 -test-suite polysemy-conc-unit+test-suite polysemy-conc-test   type: exitcode-stdio-1.0   main-is: Main.hs   other-modules:       Polysemy.Conc.Test.EventsTest-      Polysemy.Conc.Test.InterruptTest       Polysemy.Conc.Test.LockTest       Polysemy.Conc.Test.MaskTest       Polysemy.Conc.Test.MonitorTest       Polysemy.Conc.Test.QueueTest+      Polysemy.Conc.Test.Run       Polysemy.Conc.Test.SyncTest   hs-source-dirs:       test   default-extensions:       AllowAmbiguousTypes       ApplicativeDo-      BangPatterns-      BinaryLiterals       BlockArguments-      ConstraintKinds       DataKinds       DefaultSignatures       DeriveAnyClass-      DeriveDataTypeable-      DeriveFoldable-      DeriveFunctor-      DeriveGeneric-      DeriveLift-      DeriveTraversable       DerivingStrategies       DerivingVia       DisambiguateRecordFields-      DoAndIfThenElse       DuplicateRecordFields-      EmptyCase-      EmptyDataDecls-      ExistentialQuantification-      FlexibleContexts-      FlexibleInstances       FunctionalDependencies       GADTs-      GeneralizedNewtypeDeriving-      InstanceSigs-      KindSignatures       LambdaCase       LiberalTypeSynonyms-      MultiParamTypeClasses+      MonadComprehensions       MultiWayIf-      NamedFieldPuns+      NoFieldSelectors       OverloadedLabels       OverloadedLists+      OverloadedRecordDot       OverloadedStrings       PackageImports       PartialTypeSignatures-      PatternGuards       PatternSynonyms-      PolyKinds       QuantifiedConstraints       QuasiQuotes-      RankNTypes       RecordWildCards       RecursiveDo       RoleAnnotations-      ScopedTypeVariables-      StandaloneDeriving       TemplateHaskell-      TupleSections-      TypeApplications       TypeFamilies       TypeFamilyDependencies-      TypeOperators-      TypeSynonymInstances       UndecidableInstances       UnicodeSyntax       ViewPatterns-  ghc-options: -Wall -Wredundant-constraints -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Widentities -Wunused-packages -threaded -rtsopts -with-rtsopts=-N+  ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Widentities -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Wredundant-constraints -Wunused-type-patterns -Wunused-packages   build-depends:-      async-    , base >=4.12 && <5-    , hedgehog-    , incipit-core >=0.4.1-    , polysemy-    , polysemy-conc-    , polysemy-plugin-    , polysemy-resume-    , polysemy-test-    , polysemy-time-    , stm-    , tasty-    , tasty-hedgehog-    , time-    , unix+      async >=2.2.4 && <2.3+    , base >=4.17.2.1 && <4.22+    , hedgehog >=1.4 && <1.8+    , incipit-core >=0.4.1.0 && <0.8+    , polysemy >=1.9.0.0 && <1.10+    , polysemy-conc <0.16+    , polysemy-plugin >=0.4.4.0 && <0.5+    , polysemy-test >=0.6.0.0 && <0.12+    , polysemy-time >=0.5.1.0 && <0.8+    , tasty >=1.5.2 && <1.6+    , tasty-hedgehog >=1.4.0.2 && <1.5+    , time >=1.12.2 && <1.15+    , torsor ==0.1.*   mixins:       base hiding (Prelude)     , incipit-core (IncipitCore as Prelude)     , incipit-core hiding (IncipitCore)-  default-language: Haskell2010+  default-language: GHC2021
readme.md view
@@ -1,6 +1,6 @@ # About -This library provides [Polysemy] effects for using STM queues, MVars, signal handling and racing.+This library provides [Polysemy] effects for using STM queues, MVars and racing.  Please visit [Hackage] for documentation.
test/Main.hs view
@@ -1,8 +1,6 @@ module Main where -import Hedgehog (property, test, withTests) import Polysemy.Conc.Test.EventsTest (test_events)-import Polysemy.Conc.Test.InterruptTest (test_interrupt) import Polysemy.Conc.Test.LockTest (test_lock) import Polysemy.Conc.Test.MaskTest (test_mask) import Polysemy.Conc.Test.MonitorTest (test_monitorBasic, test_monitorClockSkew)@@ -14,42 +12,43 @@   test_queueTBM,   test_queueTimeoutTBM,   )+import Polysemy.Conc.Test.Run (unitTestTimes) import Polysemy.Conc.Test.SyncTest (test_sync, test_syncLock)-import Polysemy.Test (unitTest)-import Test.Tasty (TestTree, defaultMain, testGroup)-import Test.Tasty.Hedgehog (testProperty)+import Test.Tasty (TestTree, Timeout (NoTimeout), adjustOption, defaultMain, mkTimeout, testGroup) +defaultTimeout :: Timeout -> Timeout+defaultTimeout = \case+  NoTimeout -> mkTimeout 60_000_000+  t -> t+ tests :: TestTree tests =+  adjustOption defaultTimeout $   testGroup "main" [     testGroup "queue" [-      unitTest "TBM success" test_queueTBM,-      unitTest "TBM timeout" test_queueTimeoutTBM,-      unitTest "TBM peek" test_queuePeekTBM,-      unitTest "TBM block" test_queueBlockTBM,-      unitTest "TB success" test_queueTB,-      unitTest "TB block" test_queueBlockTB+      unitTestTimes 100 "TBM success" test_queueTBM,+      unitTestTimes 100 "TBM timeout" test_queueTimeoutTBM,+      unitTestTimes 100 "TBM peek" test_queuePeekTBM,+      unitTestTimes 10 "TBM block" test_queueBlockTBM,+      unitTestTimes 100 "TB success" test_queueTB,+      unitTestTimes 10 "TB block" test_queueBlockTB     ],     testGroup "events" [-      testProperty "events" (withTests 100 (property (test test_events)))+      unitTestTimes 100 "events" test_events     ],     testGroup "sync" [-      unitTest "sync" test_sync,-      unitTest "lock" test_syncLock+      unitTestTimes 100 "sync" test_sync,+      unitTestTimes 10 "lock" test_syncLock     ],     test_lock,-    testGroup "interrupt" [-      unitTest "interrupt" test_interrupt-    ],     testGroup "mask" [-      unitTest "mask" test_mask+      unitTestTimes 10 "mask" test_mask     ],     testGroup "monitor" [-      unitTest "basic" test_monitorBasic,-      unitTest "clock skew" test_monitorClockSkew+      unitTestTimes 100 "basic" test_monitorBasic,+      unitTestTimes 100 "clock skew" test_monitorClockSkew     ]   ]  main :: IO ()-main =-  defaultMain tests+main = defaultMain tests
− test/Polysemy/Conc/Test/InterruptTest.hs 
@@ -1,31 +0,0 @@-module Polysemy.Conc.Test.InterruptTest where--import Control.Concurrent.STM (TVar, atomically, modifyTVar, newTVarIO, readTVarIO)-import Polysemy.Test (UnitTest, assertEq, runTestAuto)-import System.Posix (Handler (CatchInfoOnce), SignalInfo, installHandler, keyboardSignal, raiseSignal)--import qualified Polysemy.Conc.Effect.Interrupt as Interrupt-import Polysemy.Conc.Interpreter.Critical (interpretCritical)-import Polysemy.Conc.Interpreter.Interrupt (interpretInterrupt)-import Polysemy.Conc.Interpreter.Race (interpretRace)--handler :: MVar () -> TVar Int -> SignalInfo -> IO ()-handler mv tv _ = do-  atomically (modifyTVar tv (5 +))-  putMVar mv ()--test_interrupt :: UnitTest-test_interrupt = do-  runTestAuto do-    tv <- embed (newTVarIO 0)-    mv <- embed newEmptyMVar-    embed (installHandler keyboardSignal (CatchInfoOnce (handler mv tv)) Nothing)-    asyncToIOFinal $ interpretCritical $ interpretRace $ interpretInterrupt do-      Interrupt.register "test 1" do-        atomically (modifyTVar tv (3 +))-      Interrupt.register "test 2" do-        atomically (modifyTVar tv (9 +))-      embed (raiseSignal keyboardSignal)-    embed (takeMVar mv)-    result <- embed (readTVarIO tv)-    assertEq @_ @IO 17 result
test/Polysemy/Conc/Test/LockTest.hs view
@@ -2,7 +2,7 @@  module Polysemy.Conc.Test.LockTest where -import Polysemy.Test (UnitTest, assert, assertJust, runTestAuto, unitTest)+import Polysemy.Test (UnitTest, assert, assertJust, runTestAuto) import Polysemy.Time (GhcTime, MilliSeconds (MilliSeconds), Seconds (Seconds), interpretTimeGhc) import Test.Tasty (TestTree, testGroup) @@ -16,6 +16,7 @@ import Polysemy.Conc.Interpreter.Race (interpretRace) import Polysemy.Conc.Interpreter.Sync (interpretSync) import Polysemy.Conc.Race (timeout_)+import Polysemy.Conc.Test.Run (unitTestTimes)  interpretLockTest ::   Members [Resource, Embed IO, Final IO] r =>@@ -52,6 +53,6 @@ test_lock :: TestTree test_lock =   testGroup "lock" [-    unitTest "basic" test_lockBasic,-    unitTest "reentry" test_lockReentry+    unitTestTimes 10 "basic" test_lockBasic,+    unitTestTimes 10 "reentry" test_lockReentry   ]
test/Polysemy/Conc/Test/MaskTest.hs view
@@ -13,7 +13,7 @@ import Polysemy.Conc.AtomicState (interpretAtomic) import Polysemy.Conc.Effect.Mask (restore, uninterruptibleMask) import qualified Polysemy.Conc.Effect.Sync as Sync-import Polysemy.Conc.Interpreter.Mask (interpretUninterruptibleMaskFinal)+import Polysemy.Conc.Interpreter.Mask (interpretMaskFinal) import Polysemy.Conc.Interpreter.Race (interpretRace) import Polysemy.Conc.Interpreter.Sync (interpretSync) @@ -39,7 +39,7 @@   asyncToIOFinal $   interpretRace $   interpretTimeGhc $-  interpretUninterruptibleMaskFinal $+  interpretMaskFinal $   interpretAtomic (0 :: Int) $   interpretSync @(Proxy 2) $   interpretSync @(Proxy 1) do
test/Polysemy/Conc/Test/MonitorTest.hs view
@@ -2,18 +2,25 @@  module Polysemy.Conc.Test.MonitorTest where +import Control.Concurrent (threadDelay)+import qualified Data.Text as Text import Data.Time (UTCTime)-import Polysemy.Test (UnitTest, assertEq, assertJust, runTestAuto)+import Polysemy.Test (TestError (TestError), UnitTest, assertEq, assertJust, runTestAuto) import qualified Polysemy.Time as Time import Polysemy.Time (+  GhcTime,   Hours (Hours),   MilliSeconds (MilliSeconds),   Minutes (Minutes),   NanoSeconds (NanoSeconds),+  Seconds (Seconds),   Time,+  TimeUnit,+  convert,   interpretTimeGhc,   interpretTimeGhcConstantNow,   )+import Torsor (difference)  import Polysemy.Conc.AtomicState (interpretAtomic) import qualified Polysemy.Conc.Effect.Monitor as Monitor@@ -39,10 +46,9 @@  checker ::   Members [Time t d, Sync (), Embed IO] r =>-  MVar () ->-  Sem r ()-checker signal =-  Sync.takeBlock *> embed (putMVar signal ())+  Sem r Bool+checker =+  True <$ Sync.takeBlock  test_monitorBasic :: UnitTest test_monitorBasic =@@ -55,42 +61,123 @@   interpretMonitorRestart (MonitorCheck (NanoSeconds 0) checker) do     assertEq 3 =<< Monitor.restart prog +locked ::+  Members [AtomicState [Text], Error TestError, Embed IO] r =>+  Sem r a+locked = do+  embed (threadDelay 1_000_000)+  msgs <- atomicGet+  throw (TestError (Text.unlines ("Locked after:" : reverse msgs)))++takeBlock ::+  ∀ label r .+  HasCallStack =>+  Members [AtomicState [Text], Sync (Proxy label), Error TestError, Embed IO] r =>+  Text ->+  Sem r ()+takeBlock desc =+  withFrozenCallStack do+    atomicModify' (("taking '" <> desc <> "'") :)+    whenM (isNothing <$> Sync.takeWait (Seconds 1)) locked++putBlock ::+  ∀ label r .+  HasCallStack =>+  Members [AtomicState [Text], Sync (Proxy label), Error TestError, Embed IO] r =>+  Text ->+  Sem r ()+putBlock desc =+  withFrozenCallStack do+    atomicModify' (("putting '" <> desc <> "'") :)+    unlessM (Sync.putWait (Seconds 1) Proxy) locked+ progSkew ::-  Member (Sync (Proxy "start")) r =>-  Members [Monitor Restart, Time t d, AtomicState Int, Sync (Proxy 1), Sync (Proxy 2), Sync (Proxy 3)] r =>+  Members [Sync (Proxy "start"), Sync (Proxy "1"), Sync (Proxy "2"), Sync (Proxy "3"), Embed IO] r =>+  Members [Monitor Restart, AtomicState [Text], AtomicState Int, Error TestError, Time t d] r =>   Sem r Int-progSkew = do+progSkew =   Monitor.monitor do     atomicModify' (1 +)-    Sync.putBlock (Proxy @"start")-    void $ Sync.takeBlock @(Proxy 1)-    Sync.putBlock (Proxy @2)-    void $ Sync.takeBlock @(Proxy 3)+    putBlock @"start" "start"+    takeBlock @"1" "1"+    putBlock @"2" "2"+    takeBlock @"3" "3"     atomicGet +sleepPoll ::+  Members [GhcTime, Embed IO] r =>+  TimeUnit u =>+  u ->+  UTCTime ->+  Sem r ()+sleepPoll duration start =+  spin+  where+    spin = do+      embed (threadDelay 10_000)+      unlessM (later <$> Time.now) spin+    later now =+      difference now start >= diff+    diff =+      convert duration++interceptTime ::+  ∀ r a .+  Members [AtomicState [Text], GhcTime, Sync (Proxy "sleep"), Error TestError, Embed IO] r =>+  Sem r a ->+  Sem r a+interceptTime =+  intercept \case+    Time.Now -> do+      atomicModify' ("now" :)+      Time.now+    Time.Today ->+      Time.today+    Time.Sleep t -> do+      atomicModify' ("sleep" :)+      now <- Time.now+      putBlock @"sleep" "sleep"+      sleepPoll t now+      atomicModify' ("slept" :)+    Time.SetTime now ->+      Time.setTime now+    Time.Adjust (diff :: u) -> do+      atomicModify' ("adjust" :)+      send (Time.Adjust diff)+    Time.SetDate startAt ->+      Time.setDate startAt+ test_monitorClockSkew :: UnitTest test_monitorClockSkew =   runTestAuto $   asyncToIOFinal $   interpretRace $-  interpretTimeGhcConstantNow $   interpretAtomic (0 :: Int) $+  interpretAtomic ([] :: [Text]) $   interpretAtomic @(Maybe UTCTime) Nothing $   interpretSync @(Proxy "start") $-  interpretSync @(Proxy 1) $-  interpretSync @(Proxy 2) $-  interpretSync @(Proxy 3) $-  interpretMonitorRestart (monitorClockSkew (clockSkewConfig (MilliSeconds 1) (Minutes 30))) do+  interpretSync @(Proxy "sleep") $+  interpretSync @(Proxy "1") $+  interpretSync @(Proxy "2") $+  interpretSync @(Proxy "3") $+  interpretTimeGhcConstantNow $+  interceptTime $+  interpretMonitorRestart monitor do     h <- async (Monitor.restart progSkew)-    _ <- Sync.takeBlock @(Proxy "start")+    takeBlock @"start" "start 1"+    takeBlock @"sleep" "sleep"     Time.adjust (Hours 1)-    _ <- Sync.takeBlock @(Proxy "start")+    _ <- takeBlock @"start" "start 2"+    takeBlock @"sleep" "sleep"     Time.adjust (Minutes 10)-    Sync.putBlock (Proxy @1)-    Sync.takeBlock @(Proxy 2)+    putBlock @"1" "1 1"+    takeBlock @"2" "2 1"+    takeBlock @"sleep" "sleep"     Time.adjust (Hours 1)-    _ <- Sync.takeBlock @(Proxy "start")-    Sync.putBlock (Proxy @1)-    Sync.takeBlock @(Proxy 2)-    Sync.putBlock (Proxy @3)+    _ <- takeBlock @"start" "start 3"+    putBlock @"1" "1 2"+    takeBlock @"2" "2 2"+    putBlock @"3" "3"     assertJust 3 =<< await h+  where+    monitor = monitorClockSkew (clockSkewConfig (MilliSeconds 1) (Minutes 30))
+ test/Polysemy/Conc/Test/Run.hs view
@@ -0,0 +1,14 @@+module Polysemy.Conc.Test.Run where++import Hedgehog (TestLimit, property, test, withTests)+import Polysemy.Test (UnitTest)+import Test.Tasty (TestName, TestTree)+import Test.Tasty.Hedgehog (testProperty)++unitTestTimes ::+  TestLimit ->+  TestName ->+  UnitTest ->+  TestTree+unitTestTimes n desc =+  testProperty desc . withTests n . property . test