polysemy-conc 0.2.0.0 → 0.3.0.0

raw patch · 34 files changed

+637/−532 lines, 34 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• changelog.md +7/−0
• lib/Polysemy/Conc.hs +11/−7
• lib/Polysemy/Conc/Async.hs +1/−1
• lib/Polysemy/Conc/Critical.hs +0/−32
• lib/Polysemy/Conc/Data/Critical.hs +0/−41
• lib/Polysemy/Conc/Data/Interrupt.hs +0/−44
• lib/Polysemy/Conc/Data/Queue.hs +0/−46
• lib/Polysemy/Conc/Data/Race.hs +0/−35
• lib/Polysemy/Conc/Effect/Critical.hs +41/−0
• lib/Polysemy/Conc/Effect/Interrupt.hs +44/−0
• lib/Polysemy/Conc/Effect/Queue.hs +46/−0
• lib/Polysemy/Conc/Effect/Race.hs +35/−0
• lib/Polysemy/Conc/Effect/Scoped.hs +1/−44
• lib/Polysemy/Conc/Interpreter/Critical.hs +32/−0
• lib/Polysemy/Conc/Interpreter/Events.hs +3/−2
• lib/Polysemy/Conc/Interpreter/Interrupt.hs +195/−0
• lib/Polysemy/Conc/Interpreter/Queue/Pure.hs +2/−2
• lib/Polysemy/Conc/Interpreter/Queue/TB.hs +3/−3
• lib/Polysemy/Conc/Interpreter/Queue/TBM.hs +3/−3
• lib/Polysemy/Conc/Interpreter/Race.hs +35/−0
• lib/Polysemy/Conc/Interpreter/Scoped.hs +51/−0
• lib/Polysemy/Conc/Interpreter/Sync.hs +9/−9
• lib/Polysemy/Conc/Interrupt.hs +0/−195
• lib/Polysemy/Conc/Queue.hs +18/−3
• lib/Polysemy/Conc/Queue/Timeout.hs +3/−3
• lib/Polysemy/Conc/Race.hs +43/−34
• lib/Polysemy/Conc/Retry.hs +3/−3
• lib/Polysemy/Conc/Sync.hs +22/−2
• polysemy-conc.cabal +9/−7
• test/Main.hs +7/−3
• test/Polysemy/Conc/Test/EventsTest.hs +1/−1
• test/Polysemy/Conc/Test/InterruptTest.hs +6/−6
• test/Polysemy/Conc/Test/QueueTest.hs +4/−4
• test/Polysemy/Conc/Test/SyncTest.hs +2/−2

@@ -1,5 +1,12 @@ # Unreleased +# 0.3.0.0++* Change `Race.timeout` to take a `Sem` for the fallback instead of a pure value.+* Export all `Queue` constructors from `Polysemy.Conc.Queue`.+* Export all `Sync` constructors from `Polysemy.Conc.Sync`.+* Move all interpreters to `Polysemy.Conc.Interpreter`.+ # 0.2.0.0 * Add `read*` constructors for `Sync` * Add `subscribeWhile`, a combinator that consumes events until a condition is met

@@ -40,7 +40,10 @@   race_,   timeout,   timeout_,+  timeoutAs,+  timeoutAs_,   timeoutU,+  timeoutMaybe,   retrying,   retryingWithError, @@ -86,16 +89,17 @@  import Polysemy.Conc.Async (withAsync, withAsyncBlock, withAsync_) import Polysemy.Conc.AtomicState (interpretAtomic)-import Polysemy.Conc.Critical (interpretCritical, interpretCriticalNull)-import Polysemy.Conc.Data.Critical (Critical)-import Polysemy.Conc.Data.Interrupt (Interrupt)-import Polysemy.Conc.Data.Queue (Queue) import Polysemy.Conc.Data.QueueResult (QueueResult)-import Polysemy.Conc.Data.Race (Race, race, timeout)+import Polysemy.Conc.Effect.Critical (Critical) import Polysemy.Conc.Effect.Events (EventToken, Events, consume, publish, subscribe)+import Polysemy.Conc.Effect.Interrupt (Interrupt)+import Polysemy.Conc.Effect.Queue (Queue)+import Polysemy.Conc.Effect.Race (Race, race, timeout) import Polysemy.Conc.Effect.Sync (ScopedSync, Sync) import Polysemy.Conc.Events (subscribeLoop, subscribeWhile)+import Polysemy.Conc.Interpreter.Critical (interpretCritical, interpretCriticalNull) import Polysemy.Conc.Interpreter.Events (ChanConsumer, ChanEvents, EventChan, EventConsumer, interpretEventsChan)+import Polysemy.Conc.Interpreter.Interrupt (interpretInterrupt) import Polysemy.Conc.Interpreter.Queue.Pure (   interpretQueueListReadOnlyAtomic,   interpretQueueListReadOnlyAtomicWith,@@ -104,11 +108,11 @@   ) import Polysemy.Conc.Interpreter.Queue.TB (interpretQueueTB) import Polysemy.Conc.Interpreter.Queue.TBM (interpretQueueTBM)+import Polysemy.Conc.Interpreter.Race (interpretRace) import Polysemy.Conc.Interpreter.Sync (interpretScopedSync, interpretScopedSyncAs, interpretSync, interpretSyncAs)-import Polysemy.Conc.Interrupt (interpretInterrupt) import Polysemy.Conc.Queue (loop, loopOr) import Polysemy.Conc.Queue.Result (resultToMaybe)-import Polysemy.Conc.Race (interpretRace, race_, timeoutU, timeout_)+import Polysemy.Conc.Race (race_, timeoutAs, timeoutAs_, timeoutMaybe, timeoutU, timeout_) import Polysemy.Conc.Retry (retrying, retryingWithError) import Polysemy.Conc.Sync (withSync) 

@@ -5,7 +5,7 @@ import Polysemy.Resource (Resource, bracket) import Polysemy.Time (MilliSeconds (MilliSeconds), TimeUnit) -import Polysemy.Conc.Data.Race (Race)+import Polysemy.Conc.Effect.Race (Race) import qualified Polysemy.Conc.Race as Race  -- |Run the first action asynchronously while the second action executes, then cancel the first action.

@@ -1,32 +0,0 @@--- |Description: Critical interpreters-module Polysemy.Conc.Critical where--import qualified Control.Exception as Exception-import Polysemy.Final (getInitialStateS, interpretFinal, runS)--import Polysemy.Conc.Data.Critical (Critical(..))-import Polysemy (interpretH, runT)---- |Interpret 'Critical' in terms of 'Final' 'IO'.-interpretCritical ::-  Member (Final IO) r =>-  InterpreterFor Critical r-interpretCritical =-  interpretFinal @IO \case-    Catch ma -> do-      s <- getInitialStateS-      o <- runS ma-      pure (run o s)-      where-        run ma' s =-          Exception.catch (fmap Right <$> ma') \ se -> pure (Left se <$ s)-{-# inline interpretCritical #-}---- |Interpret 'Critical' by doing nothing.-interpretCriticalNull ::-  InterpreterFor Critical r-interpretCriticalNull =-  interpretH \case-    Catch ma ->-      fmap (fmap Right) . raise . interpretCriticalNull =<< runT ma-{-# inline interpretCriticalNull #-}

@@ -1,41 +0,0 @@-{-# options_haddock prune #-}--- |Description: Critical effect-module Polysemy.Conc.Data.Critical where---- |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 :: Exception e => m a -> Critical m (Either e a)--makeSem ''Critical---- |Catch exceptions of type @e@ and return a fallback value.-catchAs ::-  ∀ e a r .-  Exception e =>-  Member Critical r =>-  a ->-  Sem r a ->-  Sem r a-catchAs a =-  fmap (fromRight a) . catch @_ @e---- |Convenience overload for 'SomeException'.-run ::-  Member Critical r =>-  Sem r a ->-  Sem r (Either SomeException a)-run =-  catch---- |Convenience overload for 'SomeException'.-runAs ::-  Member Critical r =>-  a ->-  Sem r a ->-  Sem r a-runAs a =-  fmap (fromRight a) . run

@@ -1,44 +0,0 @@-{-# options_haddock prune #-}--- |Description: Interrupt effect-module Polysemy.Conc.Data.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.Data.Interrupt".------ @--- import qualified Polysemy.Conc.Data.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)

@@ -1,46 +0,0 @@-{-# options_haddock prune #-}--- |Description: Queue effect-module Polysemy.Conc.Data.Queue where--import Polysemy.Time (TimeUnit)-import Polysemy.Conc.Data.QueueResult (QueueResult)---- |Abstracts queues like 'Control.Concurrent.STM.TBQueue'.------ For documentation on the constructors, see the module "Polysemy.Conc.Data.Queue".------ @--- import Polysemy.Conc (Queue, QueueResult)--- import Polysemy.Conc.Data.Queue as Queue------ prog :: Member (Queue Int) r => Sem r (QueueResult Int)--- prog = do---   Queue.write 5---   Queue.write 10---   Queue.read >>= \\case---     QueueResult.Success i -> fmap (i +) \<$> Queue.read---     r -> pure r--- @-data Queue d :: Effect where-  -- |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.-  TryRead :: Queue d m (QueueResult d)-  -- |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.-  Peek :: Queue d m (QueueResult d)-  -- |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 :: d -> Queue d m ()-  -- |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.-  WriteTimeout :: TimeUnit t => t -> d -> Queue d m (QueueResult ())-  -- |Indicate whether the queue is closed.-  Closed :: Queue d m Bool-  -- |Close the queue.-  Close :: Queue d m ()--makeSem ''Queue

@@ -1,35 +0,0 @@-{-# options_haddock prune #-}--- |Description: Race effect-module Polysemy.Conc.Data.Race where--import Polysemy (makeSem_)--import Polysemy.Time (TimeUnit)---- |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.-  Race :: m a -> m b -> Race m (Either a b)-  -- |Return the fallback value if the given program doesn't finish within the specified interval.-  Timeout :: TimeUnit u => a -> u -> m b -> Race m (Either a b)--makeSem_ ''Race---- |Run both programs concurrently, returning the result of the faster one.-race ::-  ∀ a b r .-  Member Race r =>-  Sem r a ->-  Sem r b ->-  Sem r (Either a b)---- |Return the fallback value if the given program doesn't finish within the specified interval.-timeout ::-  ∀ a b u r .-  TimeUnit u =>-  Member Race r =>-  a ->-  u ->-  Sem r b ->-  Sem r (Either a b)

@@ -0,0 +1,41 @@+{-# options_haddock prune #-}+-- |Description: Critical effect+module Polysemy.Conc.Effect.Critical where++-- |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 :: Exception e => m a -> Critical m (Either e a)++makeSem ''Critical++-- |Catch exceptions of type @e@ and return a fallback value.+catchAs ::+  ∀ e a r .+  Exception e =>+  Member Critical r =>+  a ->+  Sem r a ->+  Sem r a+catchAs a =+  fmap (fromRight a) . catch @_ @e++-- |Convenience overload for 'SomeException'.+run ::+  Member Critical r =>+  Sem r a ->+  Sem r (Either SomeException a)+run =+  catch++-- |Convenience overload for 'SomeException'.+runAs ::+  Member Critical r =>+  a ->+  Sem r a ->+  Sem r a+runAs a =+  fmap (fromRight a) . run

@@ -0,0 +1,44 @@+{-# 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)

@@ -0,0 +1,46 @@+{-# options_haddock prune #-}+-- |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'.+--+-- For documentation on the constructors, see the module "Polysemy.Conc.Data.Queue".+--+-- @+-- import Polysemy.Conc (Queue, QueueResult)+-- import Polysemy.Conc.Effect.Queue as Queue+--+-- prog :: Member (Queue Int) r => Sem r (QueueResult Int)+-- prog = do+--   Queue.write 5+--   Queue.write 10+--   Queue.read >>= \\case+--     QueueResult.Success i -> fmap (i +) \<$> Queue.read+--     r -> pure r+-- @+data Queue d :: Effect where+  -- |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.+  TryRead :: Queue d m (QueueResult d)+  -- |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.+  Peek :: Queue d m (QueueResult d)+  -- |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 :: d -> Queue d m ()+  -- |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.+  WriteTimeout :: TimeUnit t => t -> d -> Queue d m (QueueResult ())+  -- |Indicate whether the queue is closed.+  Closed :: Queue d m Bool+  -- |Close the queue.+  Close :: Queue d m ()++makeSem ''Queue

@@ -0,0 +1,35 @@+{-# options_haddock prune #-}+-- |Description: Race effect+module Polysemy.Conc.Effect.Race where++import Polysemy (makeSem_)++import Polysemy.Time (TimeUnit)++-- |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.+  Race :: m a -> m b -> Race m (Either a b)+  -- |Run the fallback action if the given program doesn't finish within the specified interval.+  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.+race ::+  ∀ a b r .+  Member Race r =>+  Sem r a ->+  Sem r b ->+  Sem r (Either a b)++-- |Run the fallback action if the given program doesn't finish within the specified interval.+timeout ::+  ∀ a b u r .+  TimeUnit u =>+  Member Race r =>+  Sem r a ->+  u ->+  Sem r b ->+  Sem r (Either a b)

@@ -3,8 +3,7 @@ module Polysemy.Conc.Effect.Scoped where  import Polysemy (transform)-import Polysemy.Internal (Sem (Sem, runSem), liftSem, send)-import Polysemy.Internal.Union (Weaving (Weaving), decomp, hoist, injWeaving)+import Polysemy.Internal (send)  -- |@Scoped@ transforms a program so that @effect@ is associated with a @resource@ within that program. -- This requires the interpreter for @effect@ to be parameterized by @resource@ and constructed for every program using@@ -22,15 +21,6 @@   Run :: ∀ resource effect m a . resource -> effect m a -> Scoped resource effect m a   InScope :: ∀ resource effect m a . (resource -> m a) -> Scoped resource effect m a -interpretH' ::-  ∀ e r .-  (∀ x . Weaving e (Sem (e : r)) x -> Sem r x) ->-  InterpreterFor e r-interpretH' h sem =-  Sem \ k -> runSem sem $ decomp >>> \case-    Right wav -> runSem (h wav) k-    Left g -> k $ hoist (interpretH' h) g- -- |Constructor for 'Scoped', taking a nested program and transforming all instances of @effect@ to -- @Scoped resource effect@. scoped ::@@ -40,36 +30,3 @@ scoped main =   send $ InScope @resource @effect \ resource ->     transform @effect (Run resource) main---- |Interpreter for 'Scoped', taking a @resource@ allocation function and a parameterized interpreter for the plain--- @effect@.------ @withResource@ is a callback function, allowing the user to acquire the resource for each program from other effects.------ @scopedInterpreter@ is a regular interpreter that is called with the @resource@ argument produced by @scope@.--- /Note/: This function will be called for each action in the program, so if the interpreter allocates any resources,--- they will be scoped to a single action. Move them to @withResource@ instead.-runScoped ::-  ∀ resource effect r .-  (∀ x . (resource -> Sem r x) -> Sem r x) ->-  (resource -> InterpreterFor effect r) ->-  InterpreterFor (Scoped resource effect) r-runScoped withResource scopedInterpreter =-  run-  where-    run :: InterpreterFor (Scoped resource effect) r-    run =-      interpretH' \ (Weaving effect s wv ex ins) -> case effect of-        Run resource act ->-          scopedInterpreter resource (liftSem $ injWeaving $ Weaving act s (raise . run . wv) ex ins)-        InScope main ->-          ex <$> withResource \ resource -> run (wv (main resource <$ s))---- |Variant of 'Scoped' in which the resource allocator is a plain action.-runScopedAs ::-  ∀ resource effect r .-  Sem r resource ->-  (resource -> InterpreterFor effect r) ->-  InterpreterFor (Scoped resource effect) r-runScopedAs resource =-  runScoped \ f -> f =<< resource

@@ -0,0 +1,32 @@+-- |Description: Critical interpreters+module Polysemy.Conc.Interpreter.Critical where++import qualified Control.Exception as Exception+import Polysemy (interpretH, runT)+import Polysemy.Final (getInitialStateS, interpretFinal, runS)++import Polysemy.Conc.Effect.Critical (Critical (..))++-- |Interpret 'Critical' in terms of 'Final' 'IO'.+interpretCritical ::+  Member (Final IO) r =>+  InterpreterFor Critical r+interpretCritical =+  interpretFinal @IO \case+    Catch ma -> do+      s <- getInitialStateS+      o <- runS ma+      pure (run o s)+      where+        run ma' s =+          Exception.catch (fmap Right <$> ma') \ se -> pure (Left se <$ s)+{-# inline interpretCritical #-}++-- |Interpret 'Critical' by doing nothing.+interpretCriticalNull ::+  InterpreterFor Critical r+interpretCriticalNull =+  interpretH \case+    Catch ma ->+      fmap (fmap Right) . raise . interpretCriticalNull =<< runT ma+{-# inline interpretCriticalNull #-}

@@ -8,10 +8,11 @@ import Polysemy.Resource (Resource)  import Polysemy.Conc.Async (withAsync_)-import Polysemy.Conc.Data.Race (Race) import qualified Polysemy.Conc.Effect.Events as Events import Polysemy.Conc.Effect.Events (Consume, EventToken (EventToken), Events)-import Polysemy.Conc.Effect.Scoped (Scoped, runScopedAs)+import Polysemy.Conc.Effect.Race (Race)+import Polysemy.Conc.Effect.Scoped (Scoped)+import Polysemy.Conc.Interpreter.Scoped (runScopedAs)  -- |Convenience alias for the default 'Events' that uses an 'OutChan'. type ChanEvents e =

@@ -0,0 +1,195 @@+{-# 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 qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import qualified Data.Text.IO as Text+import Polysemy (getInspectorT, inspect, interpretH, runT)+import Polysemy.Async (Async, async, await, cancel)+import Polysemy.AtomicState (runAtomicStateTVar)+import Polysemy.Internal.Tactics (liftT)+import Polysemy.Time (Seconds (Seconds))+import System.Posix.Signals (Handler (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+  readMVar mv++checkListeners ::+  Members [AtomicState InterruptState, Embed IO] r =>+  Sem r ()+checkListeners =+  whenM (atomicGets (Set.null . listeners)) do+    fin <- atomicGets finished+    void (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 [qt|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 (tryPutMVar quitSignal ()) do+    traverse_ (uncurry processHandler) . Map.toList =<< atomicGets handlers+    checkListeners+    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 [qt|killing #{desc}|]+        cancel handle+        putErr [qt|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 . 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 _ =+  const pass+{-# inline originalHandler #-}++installSignalHandler ::+  TVar InterruptState ->+  IO Handler+installSignalHandler state =+  installHandler keyboardSignal (CatchInfoOnce handler) Nothing+  where+    handler sig =+      runFinal $ embedToFinal @IO $ runAtomicStateTVar state (broadcastInterrupt sig)++-- |Interpret 'Interrupt' by installing a signal handler.+interpretInterrupt ::+  Members [Critical, Race, Async, Embed IO] r =>+  InterpreterFor Interrupt r+interpretInterrupt sem = do+  quitMVar <- newEmptyMVar+  finishMVar <- newEmptyMVar+  state <- newTVarIO (InterruptState quitMVar finishMVar Set.empty (const pass) Map.empty)+  orig <- embed $ installSignalHandler state+  runAtomicStateTVar state do+    atomicModify' \ s -> s {original = originalHandler orig}+    interpretInterruptState $ raiseUnder sem+{-# inline interpretInterrupt #-}

@@ -5,8 +5,8 @@ import Polysemy.State (State, evalState, get, gets, put)  import Polysemy.Conc.AtomicState (interpretAtomic)-import qualified Polysemy.Conc.Data.Queue as Queue-import Polysemy.Conc.Data.Queue (Queue)+import qualified Polysemy.Conc.Effect.Queue as Queue+import Polysemy.Conc.Effect.Queue (Queue) import qualified Polysemy.Conc.Data.QueueResult as QueueResult import Polysemy.Conc.Data.QueueResult (QueueResult) 

@@ -12,10 +12,10 @@   writeTBQueue,   ) -import qualified Polysemy.Conc.Data.Queue as Queue-import Polysemy.Conc.Data.Queue (Queue)+import qualified Polysemy.Conc.Effect.Queue as Queue+import Polysemy.Conc.Effect.Queue (Queue) import qualified Polysemy.Conc.Data.QueueResult as QueueResult-import Polysemy.Conc.Data.Race (Race)+import Polysemy.Conc.Effect.Race (Race) import Polysemy.Conc.Queue.Result (naResult) import Polysemy.Conc.Queue.Timeout (withTimeout) 

@@ -15,9 +15,9 @@   ) import Polysemy.Resource (Resource, bracket) -import qualified Polysemy.Conc.Data.Queue as Queue-import Polysemy.Conc.Data.Queue (Queue)-import Polysemy.Conc.Data.Race (Race)+import qualified Polysemy.Conc.Effect.Queue as Queue+import Polysemy.Conc.Effect.Queue (Queue)+import Polysemy.Conc.Effect.Race (Race) import Polysemy.Conc.Queue.Result (closedBoolResult, closedNaResult, closedResult) import Polysemy.Conc.Queue.Timeout (withTimeout) 

@@ -0,0 +1,35 @@+{-# options_haddock prune #-}+-- |Description: Race Interpreters+module Polysemy.Conc.Interpreter.Race where++import qualified Control.Concurrent.Async as Async+import Polysemy.Final (interpretFinal, runS)+import qualified Polysemy.Time as Time+import Polysemy.Time (MicroSeconds (MicroSeconds))+import qualified System.Timeout as System++import qualified Polysemy.Conc.Effect.Race as Race+import Polysemy.Conc.Effect.Race (Race)++biseqEither ::+  Functor f =>+  Either (f a) (f b) ->+  f (Either a b)+biseqEither =+  either (fmap Left) (fmap Right)+{-# inline biseqEither #-}++-- |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 =>+  InterpreterFor Race r+interpretRace =+  interpretFinal @IO \case+    Race.Race left right ->+      fmap (fmap biseqEither) . Async.race <$> runS left <*> runS right+    Race.Timeout ma (Time.convert -> MicroSeconds timeout) mb -> do+      maT <- runS ma+      mbT <- runS mb+      pure (maybe (fmap Left <$> maT) (pure . fmap Right) =<< System.timeout (fromIntegral timeout) mbT)+{-# inline interpretRace #-}

@@ -0,0 +1,51 @@+{-# options_haddock prune #-}+-- |Description: Scoped Interpreters, Internal+module Polysemy.Conc.Interpreter.Scoped where++import Polysemy.Internal (Sem (Sem, runSem), liftSem)+import Polysemy.Internal.Union (Weaving (Weaving), decomp, hoist, injWeaving)++import Polysemy.Conc.Effect.Scoped (Scoped (InScope, Run))++interpretH' ::+  ∀ e r .+  (∀ x . Weaving e (Sem (e : r)) x -> Sem r x) ->+  InterpreterFor e r+interpretH' h sem =+  Sem \ k -> runSem sem $ decomp >>> \case+    Right wav -> runSem (h wav) k+    Left g -> k $ hoist (interpretH' h) g+++-- |Interpreter for 'Scoped', taking a @resource@ allocation function and a parameterized interpreter for the plain+-- @effect@.+--+-- @withResource@ is a callback function, allowing the user to acquire the resource for each program from other effects.+--+-- @scopedInterpreter@ is a regular interpreter that is called with the @resource@ argument produced by @scope@.+-- /Note/: This function will be called for each action in the program, so if the interpreter allocates any resources,+-- they will be scoped to a single action. Move them to @withResource@ instead.+runScoped ::+  ∀ resource effect r .+  (∀ x . (resource -> Sem r x) -> Sem r x) ->+  (resource -> InterpreterFor effect r) ->+  InterpreterFor (Scoped resource effect) r+runScoped withResource scopedInterpreter =+  run+  where+    run :: InterpreterFor (Scoped resource effect) r+    run =+      interpretH' \ (Weaving effect s wv ex ins) -> case effect of+        Run resource act ->+          scopedInterpreter resource (liftSem $ injWeaving $ Weaving act s (raise . run . wv) ex ins)+        InScope main ->+          ex <$> withResource \ resource -> run (wv (main resource <$ s))++-- |Variant of 'Scoped' in which the resource allocator is a plain action.+runScopedAs ::+  ∀ resource effect r .+  Sem r resource ->+  (resource -> InterpreterFor effect r) ->+  InterpreterFor (Scoped resource effect) r+runScopedAs resource =+  runScoped \ f -> f =<< resource

@@ -1,15 +1,15 @@--- |Description: Sync interpreters+-- |Description: Sync Interpreters module Polysemy.Conc.Interpreter.Sync where  import Control.Concurrent (isEmptyMVar)+import Polysemy.Resource (Resource) -import qualified Polysemy.Conc.Data.Race as Race-import Polysemy.Conc.Data.Race (Race)-import Polysemy.Conc.Effect.Scoped (Scoped, runScopedAs)+import Polysemy.Conc.Effect.Race (Race)+import Polysemy.Conc.Effect.Scoped (Scoped) import qualified Polysemy.Conc.Effect.Sync as Sync import Polysemy.Conc.Effect.Sync (Sync, SyncResources (SyncResources), unSyncResources)+import Polysemy.Conc.Interpreter.Scoped (runScopedAs) import qualified Polysemy.Conc.Race as Race-import Polysemy.Resource (Resource)  -- |Interpret 'Sync' with the provided 'MVar'. interpretSyncWith ::@@ -22,25 +22,25 @@     Sync.Block ->       readMVar var     Sync.Wait interval ->-      rightToMaybe <$> Race.timeout () interval (readMVar var)+      rightToMaybe <$> Race.timeoutAs () interval (readMVar var)     Sync.Try ->       tryReadMVar var     Sync.TakeBlock ->       takeMVar var     Sync.TakeWait interval ->-      rightToMaybe <$> Race.timeout () interval (takeMVar var)+      rightToMaybe <$> Race.timeoutAs () interval (takeMVar var)     Sync.TakeTry ->       tryTakeMVar var     Sync.ReadBlock ->       readMVar var     Sync.ReadWait interval ->-      rightToMaybe <$> Race.timeout () interval (readMVar var)+      rightToMaybe <$> Race.timeoutAs () interval (readMVar var)     Sync.ReadTry ->       tryReadMVar var     Sync.PutBlock d ->       putMVar var d     Sync.PutWait interval d ->-      Race.timeout_ False interval (True <$ putMVar var d)+      Race.timeoutAs_ False interval (True <$ putMVar var d)     Sync.PutTry d ->       tryPutMVar var d     Sync.Empty ->

@@ -1,195 +0,0 @@-{-# options_haddock prune #-}--- |Description: Interrupt interpreters-module Polysemy.Conc.Interrupt where--import qualified Control.Concurrent.Async as A-import Control.Concurrent.Async (AsyncCancelled)-import qualified Data.Map.Strict as Map-import qualified Data.Set as Set-import qualified Data.Text.IO as Text-import Polysemy (getInspectorT, inspect, interpretH, runT)-import Polysemy.Async (Async, async, await, cancel)-import Polysemy.AtomicState (runAtomicStateTVar)-import Polysemy.Internal.Tactics (liftT)-import Polysemy.Time (Seconds (Seconds))-import System.Posix.Signals (Handler (CatchInfoOnce, CatchOnce), SignalInfo, installHandler, keyboardSignal)--import qualified Polysemy.Conc.Data.Critical as Critical-import Polysemy.Conc.Data.Critical (Critical)-import Polysemy.Conc.Data.Interrupt (Interrupt (..))-import Polysemy.Conc.Data.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-  readMVar mv--checkListeners ::-  Members [AtomicState InterruptState, Embed IO] r =>-  Sem r ()-checkListeners =-  whenM (atomicGets (Set.null . listeners)) do-    fin <- atomicGets finished-    void (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 [qt|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 (tryPutMVar quitSignal ()) do-    traverse_ (uncurry processHandler) . Map.toList =<< atomicGets handlers-    checkListeners-    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 [qt|killing #{desc}|]-        cancel handle-        putErr [qt|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 . 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 _ =-  const pass-{-# inline originalHandler #-}--installSignalHandler ::-  TVar InterruptState ->-  IO Handler-installSignalHandler state =-  installHandler keyboardSignal (CatchInfoOnce handler) Nothing-  where-    handler sig =-      runFinal $ embedToFinal @IO $ runAtomicStateTVar state (broadcastInterrupt sig)---- |Interpret 'Interrupt' by installing a signal handler.-interpretInterrupt ::-  Members [Critical, Race, Async, Embed IO] r =>-  InterpreterFor Interrupt r-interpretInterrupt sem = do-  quitMVar <- newEmptyMVar-  finishMVar <- newEmptyMVar-  state <- newTVarIO (InterruptState quitMVar finishMVar Set.empty (const pass) Map.empty)-  orig <- embed $ installSignalHandler state-  runAtomicStateTVar state do-    atomicModify' \ s -> s {original = originalHandler orig}-    interpretInterruptState $ raiseUnder sem-{-# inline interpretInterrupt #-}

@@ -1,9 +1,24 @@ -- |Description: Queue Combinators-module Polysemy.Conc.Queue where+module Polysemy.Conc.Queue (+  module Polysemy.Conc.Queue,+  module Polysemy.Conc.Effect.Queue,+) where -import qualified Polysemy.Conc.Data.Queue as Queue-import Polysemy.Conc.Data.Queue (Queue) import qualified Polysemy.Conc.Data.QueueResult as QueueResult+import qualified Polysemy.Conc.Effect.Queue as Queue+import Polysemy.Conc.Effect.Queue (+  Queue,+  close,+  closed,+  peek,+  read,+  readTimeout,+  tryPeek,+  tryRead,+  tryWrite,+  write,+  writeTimeout,+  )  -- |Read from a 'Queue' repeatedly until it is closed. --

@@ -1,11 +1,11 @@--- |Description: Timeout helper+-- |Description: Timeout Helper module Polysemy.Conc.Queue.Timeout where  import Polysemy.Time (TimeUnit)  import qualified Polysemy.Conc.Data.QueueResult as QueueResult import Polysemy.Conc.Data.QueueResult (QueueResult)-import Polysemy.Conc.Data.Race (Race)+import Polysemy.Conc.Effect.Race (Race) import qualified Polysemy.Conc.Race as Race  -- |Run an 'STM' action atomically with a time limit@@ -16,7 +16,7 @@   STM (Maybe d) ->   Sem r (QueueResult d) withTimeout timeout readQ =-  Race.timeout_ QueueResult.NotAvailable timeout reader'+  Race.timeoutAs_ QueueResult.NotAvailable timeout reader'   where     reader' =       maybe QueueResult.Closed QueueResult.Success <$> atomically readQ

@@ -1,38 +1,10 @@-{-# options_haddock prune #-}--- |Description: Race interpreters+-- |Description: Race Combinators module Polysemy.Conc.Race where -import qualified Control.Concurrent.Async as Async-import Polysemy.Final (getInitialStateS, interpretFinal, runS)-import qualified Polysemy.Time as Time-import Polysemy.Time (MicroSeconds (MicroSeconds), TimeUnit)-import qualified System.Timeout as System--import qualified Polysemy.Conc.Data.Race as Race-import Polysemy.Conc.Data.Race (Race)--biseqEither ::-  Functor f =>-  Either (f a) (f b) ->-  f (Either a b)-biseqEither =-  either (fmap Left) (fmap Right)-{-# inline biseqEither #-}+import Polysemy.Time (TimeUnit) --- |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 =>-  InterpreterFor Race r-interpretRace =-  interpretFinal @IO \case-    Race.Race left right ->-      fmap (fmap biseqEither) . Async.race <$> runS left <*> runS right-    Race.Timeout err (Time.convert -> MicroSeconds timeout) mb -> do-      mbT <- runS mb-      s <- getInitialStateS-      pure (maybe (Left err <$ s) (fmap Right) <$> System.timeout (fromIntegral timeout) mbT)-{-# inline interpretRace #-}+import qualified Polysemy.Conc.Effect.Race as Race+import Polysemy.Conc.Effect.Race (Race)  -- |Specialization of 'Race.race' for the case where both thunks return the same type, obviating the need for 'Either'. race_ ::@@ -49,7 +21,7 @@ timeout_ ::   TimeUnit u =>   Member Race r =>-  a ->+  Sem r a ->   u ->   Sem r a ->   Sem r a@@ -57,6 +29,31 @@   unify <$> Race.timeout err interval ma {-# inline timeout_ #-} +-- |Version of `Race.timeout` that takes a pure fallback value.+timeoutAs ::+  TimeUnit u =>+  Member Race r =>+  a ->+  u ->+  Sem r b ->+  Sem r (Either a b)+timeoutAs err =+  Race.timeout (pure err)+{-# inline timeoutAs #-}++-- |Specialization of 'timeoutAs' for the case where the thunk return the same type as the fallback, obviating the+-- need for 'Either'.+timeoutAs_ ::+  TimeUnit u =>+  Member Race r =>+  a ->+  u ->+  Sem r a ->+  Sem r a+timeoutAs_ err =+  timeout_ (pure err)+{-# inline timeoutAs_ #-}+ -- |Specialization of 'Race.timeout' for unit actions. timeoutU ::   TimeUnit u =>@@ -65,5 +62,17 @@   Sem r () ->   Sem r () timeoutU =-  timeout_ ()+  timeout_ pass {-# inline timeoutU #-}++-- |Variant of 'timeout' that returns 'Maybe'.+timeoutMaybe ::+  TimeUnit u =>+  Member Race r =>+  u ->+  Sem r a ->+  Sem r (Maybe a)+timeoutMaybe u ma =+  timeoutAs_ Nothing u (Just <$> ma)+{-# inline timeoutMaybe #-}+

@@ -4,7 +4,7 @@ import qualified Polysemy.Time as Time import Polysemy.Time (Time, TimeUnit) -import Polysemy.Conc.Data.Race (Race)+import Polysemy.Conc.Effect.Race (Race) import qualified Polysemy.Conc.Effect.Sync as Sync import Polysemy.Conc.Interpreter.Sync (interpretSync) import qualified Polysemy.Conc.Race as Race@@ -22,7 +22,7 @@   Sem r (Either e a) ->   Sem r (Maybe a) retrying timeout interval action =-  Race.timeout_ Nothing timeout (Just <$> spin)+  Race.timeoutMaybe timeout spin   where     spin =       action >>= \case@@ -48,7 +48,7 @@   Sem r (Maybe (Either e a)) retryingWithError timeout interval action =   interpretSync @e do-    Race.timeout_ Nothing timeout (Just <$> spin) >>= \case+    Race.timeoutMaybe timeout spin >>= \case       Just a -> pure (Just (Right a))       Nothing -> fmap Left <$> Sync.takeTry   where

@@ -1,12 +1,32 @@ -- |Description: Sync Combinators-module Polysemy.Conc.Sync where+module Polysemy.Conc.Sync (+  module Polysemy.Conc.Sync,+  module Polysemy.Conc.Effect.Sync+) where  import qualified Polysemy.Time as Time import Polysemy.Time (Time, TimeUnit)  import Polysemy.Conc.Effect.Scoped (Scoped, scoped) import qualified Polysemy.Conc.Effect.Sync as Sync-import Polysemy.Conc.Effect.Sync (Sync, SyncResources)+import Polysemy.Conc.Effect.Sync (+  ScopedSync,+  Sync,+  SyncResources,+  block,+  empty,+  putBlock,+  putTry,+  putWait,+  readBlock,+  readTry,+  readWait,+  takeBlock,+  takeTry,+  takeWait,+  try,+  wait,+  )  -- |Run an action repeatedly until the 'Sync' variable is available. whileEmpty ::

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           polysemy-conc-version:        0.2.0.0+version:        0.3.0.0 synopsis:       Polysemy Effects for Concurrency description:    See <https://hackage.haskell.org/package/polysemy-conc/docs/Polysemy-Conc.html> category:       Concurrency@@ -30,22 +30,24 @@       Polysemy.Conc       Polysemy.Conc.Async       Polysemy.Conc.AtomicState-      Polysemy.Conc.Critical-      Polysemy.Conc.Data.Critical-      Polysemy.Conc.Data.Interrupt-      Polysemy.Conc.Data.Queue       Polysemy.Conc.Data.QueueResult-      Polysemy.Conc.Data.Race+      Polysemy.Conc.Effect.Critical       Polysemy.Conc.Effect.Events+      Polysemy.Conc.Effect.Interrupt+      Polysemy.Conc.Effect.Queue+      Polysemy.Conc.Effect.Race       Polysemy.Conc.Effect.Scoped       Polysemy.Conc.Effect.Sync       Polysemy.Conc.Events+      Polysemy.Conc.Interpreter.Critical       Polysemy.Conc.Interpreter.Events+      Polysemy.Conc.Interpreter.Interrupt       Polysemy.Conc.Interpreter.Queue.Pure       Polysemy.Conc.Interpreter.Queue.TB       Polysemy.Conc.Interpreter.Queue.TBM+      Polysemy.Conc.Interpreter.Race+      Polysemy.Conc.Interpreter.Scoped       Polysemy.Conc.Interpreter.Sync-      Polysemy.Conc.Interrupt       Polysemy.Conc.Prelude       Polysemy.Conc.Queue       Polysemy.Conc.Queue.Result

@@ -1,5 +1,6 @@ module Main where +import Polysemy.Conc.Test.EventsTest (test_events) import Polysemy.Conc.Test.InterruptTest (test_interrupt) import Polysemy.Conc.Test.QueueTest (   test_queueBlockTB,@@ -23,14 +24,17 @@       unitTest "TBM block" test_queueBlockTBM,       unitTest "TB success" test_queueTB,       unitTest "TB block" test_queueBlockTB-      ],+    ],+    testGroup "events" [+      unitTest "events" test_events+    ],     testGroup "sync" [       unitTest "sync" test_sync-      ],+    ],     testGroup "interrupt" [       unitTest "interrupt" test_interrupt-      ]     ]+  ]  main :: IO () main =

@@ -7,8 +7,8 @@ import qualified Polysemy.Conc.Effect.Events as Events import qualified Polysemy.Conc.Effect.Sync as Sync import Polysemy.Conc.Interpreter.Events (interpretEventsChan)+import Polysemy.Conc.Interpreter.Race (interpretRace) import Polysemy.Conc.Interpreter.Sync (interpretSync)-import Polysemy.Conc.Race (interpretRace)  test_events :: UnitTest test_events =

@@ -1,14 +1,14 @@ module Polysemy.Conc.Test.InterruptTest where +import Control.Concurrent.STM (modifyTVar) import Polysemy.Async (asyncToIOFinal)-import Polysemy.Test (UnitTest, runTestAuto, assertEq)+import Polysemy.Test (UnitTest, assertEq, runTestAuto) import System.Posix (Handler (CatchInfoOnce), SignalInfo, installHandler, keyboardSignal, raiseSignal) -import Polysemy.Conc.Critical (interpretCritical)-import qualified Polysemy.Conc.Data.Interrupt as Interrupt-import Polysemy.Conc.Interrupt (interpretInterrupt)-import Polysemy.Conc.Race (interpretRace)-import Control.Concurrent.STM (modifyTVar)+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

@@ -5,15 +5,15 @@ import Polysemy.Time (MilliSeconds (MilliSeconds), interpretTimeGhc) import Polysemy.Time.Ghc (GhcTime) -import qualified Polysemy.Conc.Data.Queue as Queue-import Polysemy.Conc.Data.Queue (Queue) import qualified Polysemy.Conc.Data.QueueResult as QueueResult import Polysemy.Conc.Data.QueueResult (QueueResult)-import Polysemy.Conc.Data.Race (Race)+import qualified Polysemy.Conc.Effect.Queue as Queue+import Polysemy.Conc.Effect.Queue (Queue)+import Polysemy.Conc.Effect.Race (Race) import Polysemy.Conc.Interpreter.Queue.TB (interpretQueueTB) import Polysemy.Conc.Interpreter.Queue.TBM (interpretQueueTBM)+import Polysemy.Conc.Interpreter.Race (interpretRace) import Polysemy.Conc.Queue.Result (resultToMaybe)-import Polysemy.Conc.Race (interpretRace)  progSuccess ::   Member (Queue Int) r =>

@@ -3,11 +3,11 @@ import Polysemy.Async (Async, asyncToIOFinal, sequenceConcurrently) import Polysemy.Test (UnitTest, assertEq, runTestAuto) -import Polysemy.Conc.Data.Race (Race)+import Polysemy.Conc.Effect.Race (Race) import qualified Polysemy.Conc.Effect.Sync as Sync import Polysemy.Conc.Effect.Sync (Sync)+import Polysemy.Conc.Interpreter.Race (interpretRace) import Polysemy.Conc.Interpreter.Sync (interpretSync)-import Polysemy.Conc.Race (interpretRace)  data Thread1 = Thread1 data Thread2 = Thread2