polysemy-conc 0.5.1.1 → 0.6.0.0

raw patch · 42 files changed

+433/−247 lines, 42 filesdep +incipit-coredep +polysemy-resumedep −data-defaultdep −reludedep −template-haskelldep ~polysemy-plugindep ~polysemy-timesetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: incipit-core, polysemy-resume

Dependencies removed: data-default, relude, template-haskell, text

Dependency ranges changed: polysemy-plugin, polysemy-time

API changes (from Hackage documentation)

Files

• Setup.hs +2/−0
• changelog.md +3/−0
• lib/Polysemy/Conc.hs +12/−2
• lib/Polysemy/Conc/Async.hs +1/−3
• lib/Polysemy/Conc/AtomicState.hs +2/−2
• lib/Polysemy/Conc/Data/QueueResult.hs +1/−1
• lib/Polysemy/Conc/Effect/Critical.hs +3/−0
• lib/Polysemy/Conc/Effect/Events.hs +2/−2
• lib/Polysemy/Conc/Effect/Mask.hs +1/−2
• lib/Polysemy/Conc/Effect/Monitor.hs +3/−2
• lib/Polysemy/Conc/Effect/Race.hs +1/−2
• lib/Polysemy/Conc/Effect/Scoped.hs +1/−3
• lib/Polysemy/Conc/Effect/Sync.hs +1/−1
• lib/Polysemy/Conc/Interpreter/Critical.hs +3/−3
• lib/Polysemy/Conc/Interpreter/Events.hs +1/−3
• lib/Polysemy/Conc/Interpreter/Interrupt.hs +20/−13
• lib/Polysemy/Conc/Interpreter/Mask.hs +1/−1
• lib/Polysemy/Conc/Interpreter/Monitor.hs +7/−8
• lib/Polysemy/Conc/Interpreter/Queue/Pure.hs +4/−7
• lib/Polysemy/Conc/Interpreter/Queue/TB.hs +9/−8
• lib/Polysemy/Conc/Interpreter/Queue/TBM.hs +11/−10
• lib/Polysemy/Conc/Interpreter/Scoped.hs +167/−13
• lib/Polysemy/Conc/Interpreter/Stack.hs +1/−3
• lib/Polysemy/Conc/Interpreter/Sync.hs +28/−18
• lib/Polysemy/Conc/Monitor.hs +3/−2
• lib/Polysemy/Conc/Prelude.hs +0/−88
• lib/Polysemy/Conc/Queue.hs +10/−1
• lib/Polysemy/Conc/Queue/Timeout.hs +2/−1
• lib/Polysemy/Conc/Race.hs +1/−1
• lib/Polysemy/Conc/Sync.hs +0/−1
• lib/Prelude.hs +0/−5
• polysemy-conc.cabal +11/−20
• readme.md +4/−4
• test/Main.hs +5/−0
• test/Polysemy/Conc/Test/EventsTest.hs +0/−1
• test/Polysemy/Conc/Test/InterruptTest.hs +6/−6
• test/Polysemy/Conc/Test/LockTest.hs +0/−1
• test/Polysemy/Conc/Test/MaskTest.hs +3/−5
• test/Polysemy/Conc/Test/MonitorTest.hs +2/−2
• test/Polysemy/Conc/Test/QueueTest.hs +1/−1
• test/Polysemy/Conc/Test/ScopedTest.hs +99/−0
• test/Polysemy/Conc/Test/SyncTest.hs +1/−1

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -1,5 +1,8 @@ # Unreleased +* Add `Resumable` support for `Scoped`.+* Add `Scoped` interpreters that allow the allocator to interpret additional effects used by the handler.+ # 0.5.0.0  * Add `mask` effects.

@@ -104,6 +104,8 @@   interpretScoped,   interpretScopedH,   interpretScopedAs,+  interpretScopedResumable,+  interpretScopedResumableH,    -- * Monitoring   Monitor,@@ -175,7 +177,15 @@ 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 (interpretScoped, interpretScopedAs, interpretScopedH, runScoped, runScopedAs)+import Polysemy.Conc.Interpreter.Scoped (+  interpretScoped,+  interpretScopedAs,+  interpretScopedH,+  interpretScopedResumable,+  interpretScopedResumableH,+  runScoped,+  runScopedAs,+  ) import Polysemy.Conc.Interpreter.Stack (ConcStack, runConc) import Polysemy.Conc.Interpreter.Sync (interpretScopedSync, interpretScopedSyncAs, interpretSync, interpretSyncAs) import Polysemy.Conc.Monitor (ClockSkewConfig (ClockSkewConfig), clockSkewConfig, monitorClockSkew)@@ -199,7 +209,7 @@  -- $mvar -- #mvar#--- An 'MVar' is abstracted as 'Sync' since it can be used to synchronize threads.+-- An 'Control.Concurrent.MVar' is abstracted as 'Sync' since it can be used to synchronize threads.  -- $race -- #race#

@@ -2,8 +2,6 @@ module Polysemy.Conc.Async where  import qualified Control.Concurrent.Async as Base-import Polysemy.Async (Async, async, cancel)-import Polysemy.Resource (Resource, bracket) import Polysemy.Time (MilliSeconds (MilliSeconds), TimeUnit)  import Polysemy.Conc.Effect.Race (Race)@@ -92,7 +90,7 @@       raise mb     f h (Sync.putBlock ()) --- |Variant of 'scheduleAsync' that directly interprets the '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 =>

@@ -1,7 +1,7 @@ -- |Description: AtomicState Interpreters module Polysemy.Conc.AtomicState where -import Polysemy.AtomicState (runAtomicStateTVar)+import Control.Concurrent.STM (newTVarIO)  -- |Convenience wrapper around 'runAtomicStateTVar' that creates a new 'TVar'. interpretAtomic ::@@ -10,6 +10,6 @@   a ->   InterpreterFor (AtomicState a) r interpretAtomic initial sem = do-  tv <- newTVarIO initial+  tv <- embed (newTVarIO initial)   runAtomicStateTVar tv sem {-# inline interpretAtomic #-}

@@ -17,7 +17,7 @@   |   -- |The queue was closed by the user.   Closed-  deriving (Eq, Show, Ord, Functor, Generic)+  deriving stock (Eq, Show, Ord, Functor, Generic)  instance Semigroup d => Semigroup (QueueResult d) where   Success d1 <> Success d2 = Success (d1 <> d2)

@@ -1,6 +1,9 @@ {-# options_haddock prune #-}+ -- |Description: Critical effect module Polysemy.Conc.Effect.Critical where++import Prelude hiding (catch, run)  -- |An effect that catches exceptions. --

@@ -1,14 +1,14 @@ {-# options_haddock prune #-}+ -- |Description: Events/Consume Effects, Internal module Polysemy.Conc.Effect.Events where -import Polysemy (makeSem_) import Polysemy.Conc.Effect.Scoped (Scoped, scoped)  -- |Marker for the 'Scoped' resource for 'Events'. newtype EventResource resource =   EventResource { unEventToken :: resource }-  deriving (Eq, Show, Generic)+  deriving stock (Eq, Show, Generic)  -- |An event publisher that can be consumed from multiple threads. data Events (resource :: Type) (e :: Type) :: Effect where

@@ -1,8 +1,7 @@ {-# options_haddock prune #-}+ -- |Description: Mask Effect, Internal module Polysemy.Conc.Effect.Mask where--import Polysemy (makeSem_)  import Polysemy.Conc.Effect.Scoped (Scoped, scoped) 

@@ -1,8 +1,9 @@ {-# options_haddock prune #-}+ -- |Description: Monitor Effect, Internal module Polysemy.Conc.Effect.Monitor where -import Polysemy (makeSem_)+import Control.Concurrent (MVar) import Polysemy.Time (NanoSeconds)  import Polysemy.Conc.Effect.Scoped (Scoped, scoped)@@ -10,7 +11,7 @@ -- |Marker type for the restarting action for 'Monitor'. data Restart =   Restart-  deriving (Eq, Show)+  deriving stock (Eq, Show)  -- |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.

@@ -1,8 +1,7 @@ {-# options_haddock prune #-}+ -- |Description: Race effect module Polysemy.Conc.Effect.Race where--import Polysemy (makeSem_)  import Polysemy.Time (TimeUnit) 

@@ -1,9 +1,7 @@ {-# options_haddock prune #-}+ -- |Description: Scoped Effect, Internal module Polysemy.Conc.Effect.Scoped where--import Polysemy (transform)-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

@@ -5,7 +5,7 @@ import Polysemy.Time (TimeUnit) import Polysemy.Conc.Effect.Scoped (Scoped) --- |Abstracts an 'MVar'.+-- |Abstracts an 'Control.Concurrent.MVar'. -- -- For documentation on the constructors, see the module "Polysemy.Conc.Effect.Sync". --

@@ -2,8 +2,8 @@ module Polysemy.Conc.Interpreter.Critical where  import qualified Control.Exception as Exception-import Polysemy (runT) import Polysemy.Final (getInitialStateS, interpretFinal, runS)+import Prelude hiding (Catch)  import Polysemy.Conc.Effect.Critical (Critical (..)) @@ -16,9 +16,9 @@     Catch ma -> do       s <- getInitialStateS       o <- runS ma-      pure (run o s)+      pure (go o s)       where-        run ma' s =+        go ma' s =           Exception.catch (fmap Right <$> ma') \ se -> pure (Left se <$ s) {-# inline interpretCritical #-} 

@@ -1,11 +1,9 @@ {-# options_haddock prune #-}+ -- |Description: Events/Consume Interpreters, Internal module Polysemy.Conc.Interpreter.Events where  import Control.Concurrent.Chan.Unagi.Bounded (InChan, OutChan, dupChan, newChan, readChan, tryWriteChan)-import Polysemy (InterpretersFor)-import Polysemy.Async (Async)-import Polysemy.Resource (Resource)  import Polysemy.Conc.Async (withAsync_) import qualified Polysemy.Conc.Effect.Events as Events

@@ -1,18 +1,25 @@ {-# options_haddock prune #-}+ -- |Description: Interrupt interpreters module Polysemy.Conc.Interpreter.Interrupt where +import Control.Concurrent (MVar, newEmptyMVar, readMVar, takeMVar, tryPutMVar, tryReadMVar) 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 (getInspectorT, inspect, 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 (Catch, CatchInfo, CatchInfoOnce, CatchOnce), SignalInfo, installHandler, keyboardSignal)+import Prelude hiding (Catch)+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)@@ -51,7 +58,7 @@   Sem r () waitQuit = do   mv <- atomicGets quit-  readMVar mv+  embed (readMVar mv)  checkListeners ::   Members [AtomicState InterruptState, Embed IO] r =>@@ -59,7 +66,7 @@ checkListeners =   whenM (atomicGets (Set.null . listeners)) do     fin <- atomicGets finished-    void (tryPutMVar fin ())+    void (embed (tryPutMVar fin ()))  onQuit ::   Members [AtomicState InterruptState, Embed IO] r =>@@ -88,10 +95,10 @@   Sem r (SignalInfo -> Sem r ()) execInterrupt = do   InterruptState quitSignal finishSignal _ orig _ <- atomicGet-  whenM (tryPutMVar quitSignal ()) do+  whenM (embed (tryPutMVar quitSignal ())) do     traverse_ (uncurry processHandler) . Map.toList =<< atomicGets handlers     checkListeners-    takeMVar finishSignal+    embed (takeMVar finishSignal)   embed . orig <$ putErr "interrupt handlers finished"  registerHandler ::@@ -139,7 +146,7 @@         putErr "manual interrupt"         void execInterrupt     Interrupted ->-      liftT . fmap isJust . tryReadMVar =<< atomicGets quit+      liftT . fmap isJust . embed . tryReadMVar =<< atomicGets quit     KillOnQuit desc ma -> do       maT <- runT ma       ins <- getInspectorT@@ -172,7 +179,7 @@ originalHandler (CatchInfo thunk) =   thunk originalHandler _ =-  const pass+  const unit {-# inline originalHandler #-}  installSignalHandler ::@@ -193,9 +200,9 @@   ((SignalInfo -> IO ()) -> Handler) ->   InterpreterFor Interrupt r interpretInterruptWith consHandler sem = do-  quitMVar <- newEmptyMVar-  finishMVar <- newEmptyMVar-  state <- newTVarIO (InterruptState quitMVar finishMVar Set.empty (const pass) Map.empty)+  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}

@@ -1,9 +1,9 @@ {-# options_haddock prune #-}+ -- |Description: Mask Interpreters, Internal module Polysemy.Conc.Interpreter.Mask where  import qualified Control.Exception as Base-import Polysemy (runTSimple) import Polysemy.Final (runS, withStrategicToFinal, withWeavingToFinal)  import Polysemy.Conc.Effect.Mask (

@@ -1,12 +1,10 @@ {-# options_haddock prune #-}+ -- |Description: Monitor Interpreters, Internal module Polysemy.Conc.Interpreter.Monitor where +import Control.Concurrent (MVar, newEmptyMVar, readMVar, tryTakeMVar) import qualified Control.Exception as Base-import Polysemy (embedFinal, runTSimple)-import Polysemy.Async (Async)-import Polysemy.Error (errorToIOFinal, fromExceptionSem)-import Polysemy.Resource (Resource) import qualified Polysemy.Time as Time import Polysemy.Time (Time) @@ -27,7 +25,8 @@  data MonitorCancel =   MonitorCancel-  deriving (Eq, Show, Exception)+  deriving stock (Eq, Show)+  deriving anyclass (Exception)  interpretMonitorCancel ::   Members [Race, Async, Final IO] r =>@@ -36,7 +35,7 @@ interpretMonitorCancel (MonitorResource CancelResource {..}) =   interpretH \case     Monitor ma ->-      leftM (Base.throw MonitorCancel) =<< Race.race (embedFinal @IO (readMVar signal)) (runTSimple ma)+      either (const (Base.throw MonitorCancel)) pure =<< Race.race (embedFinal @IO (readMVar signal)) (runTSimple ma)  monitorRestart ::   ∀ t d r a .@@ -44,14 +43,14 @@   MonitorCheck r ->   (MonitorResource CancelResource -> Sem r a) ->   Sem r a-monitorRestart (MonitorCheck interval check) run = do+monitorRestart (MonitorCheck interval check) use = do   sig <- embedFinal @IO newEmptyMVar   withAsync_ (Time.loop_ @t @d interval (check sig)) (spin sig)   where     spin sig = do       let res = (MonitorResource (CancelResource sig))       void (embedFinal @IO (tryTakeMVar sig))-      leftM (spin sig) =<< errorToIOFinal @MonitorCancel (fromExceptionSem @MonitorCancel (raise (run res)))+      either (const (spin sig)) pure =<< errorToIOFinal @MonitorCancel (fromExceptionSem @MonitorCancel (raise (use res)))  -- |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.

@@ -1,14 +1,11 @@ -- |Description: Pure Queue Interpreters module Polysemy.Conc.Interpreter.Queue.Pure where -import Polysemy.AtomicState (atomicState')-import Polysemy.State (State, evalState, get, gets, put)- import Polysemy.Conc.AtomicState (interpretAtomic)-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)+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. -- Useful for testing.@@ -29,7 +26,7 @@     Queue.TryPeek ->       peek     Queue.Write _ ->-      pass+      unit     Queue.TryWrite _ ->       pure QueueResult.NotAvailable     Queue.WriteTimeout _ _ ->@@ -80,7 +77,7 @@     Queue.TryPeek ->       peek     Queue.Write _ ->-      pass+      unit     Queue.TryWrite _ ->       pure QueueResult.NotAvailable     Queue.WriteTimeout _ _ ->

@@ -3,6 +3,7 @@  import Control.Concurrent.STM (   TBQueue,+  atomically,   isFullTBQueue,   newTBQueueIO,   peekTBQueue,@@ -12,9 +13,9 @@   writeTBQueue,   ) +import qualified Polysemy.Conc.Data.QueueResult as QueueResult 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.Effect.Race (Race) import Polysemy.Conc.Queue.Result (naResult) import Polysemy.Conc.Queue.Timeout (withTimeout)@@ -30,26 +31,26 @@ interpretQueueTBWith queue =   interpret \case     Queue.Read ->-      atomically (QueueResult.Success <$> readTBQueue queue)+      embed (atomically (QueueResult.Success <$> readTBQueue queue))     Queue.TryRead ->-      atomically (naResult <$> tryReadTBQueue queue)+      embed (atomically (naResult <$> tryReadTBQueue queue))     Queue.ReadTimeout timeout ->       withTimeout timeout (Just <$> readTBQueue queue)     Queue.Peek ->-      atomically (QueueResult.Success <$> peekTBQueue queue)+      embed (atomically (QueueResult.Success <$> peekTBQueue queue))     Queue.TryPeek ->-      atomically (naResult <$> tryPeekTBQueue queue)+      embed (atomically (naResult <$> tryPeekTBQueue queue))     Queue.Write d ->-      atomically (writeTBQueue queue d)+      embed (atomically (writeTBQueue queue d))     Queue.TryWrite d ->-      atomically do+      embed $ atomically do         ifM (isFullTBQueue queue) (pure QueueResult.NotAvailable) (QueueResult.Success <$> writeTBQueue queue d)     Queue.WriteTimeout timeout d ->       withTimeout timeout (Just <$> writeTBQueue queue d)     Queue.Closed ->       pure False     Queue.Close ->-      pass+      unit {-# inline interpretQueueTBWith #-}  -- |Interpret 'Queue' with a 'TBQueue'.

@@ -1,7 +1,9 @@ {-# options_haddock prune #-}+ -- |Description: Queue Interpreters for 'TBMQueue' module Polysemy.Conc.Interpreter.Queue.TBM where +import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TBMQueue (   TBMQueue,   closeTBMQueue,@@ -14,7 +16,6 @@   tryWriteTBMQueue,   writeTBMQueue,   )-import Polysemy.Resource (Resource, bracket)  import qualified Polysemy.Conc.Effect.Queue as Queue import Polysemy.Conc.Effect.Queue (Queue)@@ -33,26 +34,26 @@ interpretQueueTBMWith queue =   interpret \case     Queue.Read ->-      atomically (closedResult <$> readTBMQueue queue)+      embed (atomically (closedResult <$> readTBMQueue queue))     Queue.TryRead ->-      atomically (closedNaResult <$> tryReadTBMQueue queue)+      embed (atomically (closedNaResult <$> tryReadTBMQueue queue))     Queue.ReadTimeout timeout ->       withTimeout timeout (readTBMQueue queue)     Queue.Peek ->-      atomically (closedResult <$> peekTBMQueue queue)+      embed (atomically (closedResult <$> peekTBMQueue queue))     Queue.TryPeek ->-      atomically (closedNaResult <$> tryPeekTBMQueue queue)+      embed (atomically (closedNaResult <$> tryPeekTBMQueue queue))     Queue.Write d ->-      atomically (writeTBMQueue queue d)+      embed (atomically (writeTBMQueue queue d))     Queue.TryWrite d ->-      atomically (closedBoolResult <$> tryWriteTBMQueue queue d)+      embed (atomically (closedBoolResult <$> tryWriteTBMQueue queue d))     Queue.WriteTimeout timeout d ->       withTimeout timeout do         ifM (isClosedTBMQueue queue) (pure Nothing) (Just <$> writeTBMQueue queue d)     Queue.Closed ->-      atomically (isClosedTBMQueue queue)+      embed (atomically (isClosedTBMQueue queue))     Queue.Close ->-      atomically (closeTBMQueue queue)+      embed (atomically (closeTBMQueue queue)) {-# inline interpretQueueTBMWith #-}  withTBMQueue ::@@ -62,7 +63,7 @@   (TBMQueue d -> Sem r a) ->   Sem r a withTBMQueue maxQueued =-  bracket (embed (newTBMQueueIO maxQueued)) (atomically . closeTBMQueue)+  bracket (embed (newTBMQueueIO maxQueued)) (embed . atomically . closeTBMQueue)  -- |Interpret 'Queue' with a 'TBMQueue'. interpretQueueTBM ::

@@ -1,13 +1,17 @@ {-# options_haddock prune #-}+ -- |Description: Scoped Interpreters, Internal module Polysemy.Conc.Interpreter.Scoped where  import Polysemy.Internal (Sem (Sem, runSem), liftSem)+import Polysemy.Internal.Index (InsertAtIndex)+import Polysemy.Internal.Tactics (liftT, runTactics) import Polysemy.Internal.Union (Weaving (Weaving), decomp, hoist, injWeaving)+import Polysemy.Resume (Stop, runStop, type (!!))+import Polysemy.Resume.Data.Resumable (Resumable (Resumable))+import Prelude hiding (run)  import Polysemy.Conc.Effect.Scoped (Scoped (InScope, Run))-import Polysemy (Tactical)-import Polysemy.Internal.Tactics (runTactics)  interpretH' ::   ∀ e r .@@ -76,17 +80,7 @@   (∀ r0 x . resource -> effect (Sem r0) x -> Sem r x) ->   InterpreterFor (Scoped resource effect) r interpretScoped withResource scopedHandler =-  run-  where-    run :: InterpreterFor (Scoped resource effect) r-    run =-      interpretH' \ (Weaving effect s wv ex _) -> case effect of-        Run resource act -> do-          x <- scopedHandler resource act-          pure (ex (x <$ s))-        InScope main ->-          ex <$> withResource \ resource -> run (wv (main resource <$ s))-+  interpretScopedH withResource \ r e -> liftT (scopedHandler r e)  -- |Variant of 'interpretScoped' in which the resource allocator is a plain action. interpretScopedAs ::@@ -96,3 +90,163 @@   InterpreterFor (Scoped resource effect) r interpretScopedAs resource =   interpretScoped \ f -> f =<< resource++-- |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.+interpretScopedResumableH ::+  ∀ resource effect err r .+  (∀ x . (resource -> Sem (Stop err : r) x) -> Sem (Stop err : r) x) ->+  (∀ r0 x . resource -> effect (Sem r0) x -> Tactical effect (Sem r0) (Stop err : r) x) ->+  InterpreterFor (Scoped resource effect !! err) r+interpretScopedResumableH withResource scopedHandler =+  run+  where+    run :: InterpreterFor (Scoped resource effect !! err) r+    run =+      interpretH' \ (Weaving (Resumable inner) s' dist' ex' ins') ->+        case inner of+          Weaving effect s dist ex ins -> do+            let+              handleScoped = \case+                Run resource act ->+                  scopedHandler resource act+                InScope main ->+                  raise (withResource \ resource -> Compose <$> raise (run (dist' (dist (main resource <$ s) <$ s'))))+              tac =+                runTactics+                (Compose (s <$ s'))+                (raise . raise . run . fmap Compose . dist' . fmap dist . getCompose)+                (ins <=< ins' . getCompose)+                (raise . run . fmap Compose . dist' . fmap dist . getCompose)+                (handleScoped effect)+              exFinal = ex' . \case+                Right (Compose a) -> Right . ex <$> a+                Left err -> Left err <$ s'+            exFinal <$> runStop tac++-- |Combined interpreter for 'Scoped' and 'Resumable'.+-- This allows 'Stop' to be sent from within the resource allocator so that the consumer receives it.+interpretScopedResumable ::+  ∀ resource effect err r .+  (∀ x . (resource -> Sem (Stop err : r) x) -> Sem (Stop err : r) x) ->+  (∀ r0 x . resource -> effect (Sem r0) x -> Sem (Stop err : r) x) ->+  InterpreterFor (Scoped resource effect !! err) r+interpretScopedResumable withResource scopedHandler =+  interpretScopedResumableH withResource \ r e -> liftT (scopedHandler r e)++interpretScopedWithH ::+  ∀ extra resource effect r r1 .+  r1 ~ (extra ++ r) =>+  InsertAtIndex 1 '[Scoped resource effect] r1 r (Scoped resource effect : r1) extra =>+  (∀ x . (resource -> Sem r1 x) -> Sem r x) ->+  (∀ m x . resource -> effect m x -> Tactical effect m r1 x) ->+  InterpreterFor (Scoped resource effect) r+interpretScopedWithH withResource scopedHandler =+  interpretH' \case+    Weaving (InScope main) s wv ex _ ->+      ex <$> withResource \ resource -> inScope (insertAt @1 @extra (wv (main resource <$ s)))+    _ ->+      error "top level Run"+  where+    inScope :: InterpreterFor (Scoped resource effect) r1+    inScope =+      interpretH' \case+        Weaving (Run resource act) s wv ex ins ->+          ex <$> runTactics s (raise . inScope . wv) ins (inScope . wv) (scopedHandler resource act)+        _ ->+          error "nested InScope"++interpretScopedWith ::+  ∀ extra resource effect r r1 .+  r1 ~ (extra ++ r) =>+  InsertAtIndex 1 '[Scoped resource effect] r1 r (Scoped resource effect : r1) extra =>+  (∀ x . (resource -> Sem r1 x) -> Sem r x) ->+  (∀ m x . resource -> effect m x -> Sem r1 x) ->+  InterpreterFor (Scoped resource effect) r+interpretScopedWith withResource scopedHandler =+  interpretScopedWithH @extra withResource \ r e -> liftT (scopedHandler r e)++interpretScopedWith_ ::+  ∀ extra effect r r1 .+  r1 ~ (extra ++ r) =>+  InsertAtIndex 1 '[Scoped () effect] r1 r (Scoped () effect : r1) extra =>+  (∀ x . Sem r1 x -> Sem r x) ->+  (∀ m x . effect m x -> Sem r1 x) ->+  InterpreterFor (Scoped () effect) r+interpretScopedWith_ withResource scopedHandler =+  interpretScopedWithH @extra (\ f -> withResource (f ())) \ () e -> liftT (scopedHandler e)++interpretScopedResumableWithH ::+  ∀ extra resource effect err r r1 .+  r1 ~ ((extra ++ '[Stop err]) ++ r) =>+  InsertAtIndex 1 '[Scoped resource effect !! err] r1 r (Scoped resource effect !! err : r1) (extra ++ '[Stop err]) =>+  (∀ x . (resource -> Sem r1 x) -> Sem (Stop err : r) x) ->+  (∀ r0 x . resource -> effect (Sem r0) x -> Tactical effect (Sem r0) r1 x) ->+  InterpreterFor (Scoped resource effect !! err) r+interpretScopedResumableWithH withResource scopedHandler =+  run+  where+    run :: InterpreterFor (Scoped resource effect !! err) r+    run =+      interpretH' \ (Weaving (Resumable inner) s' dist' ex' ins') ->+        case inner of+          Weaving effect s dist ex ins -> do+            let+              handleScoped = \case+                Run _ _ ->+                  error "top level Run"+                InScope main ->+                  raise (withResource \ resource -> Compose <$> inScope (insertAt @1 @(extra ++ '[Stop err]) (dist' (dist (main resource <$ s) <$ s'))))+              tac =+                runTactics+                (Compose (s <$ s'))+                (raise . raise . run . fmap Compose . dist' . fmap dist . getCompose)+                (ins <=< ins' . getCompose)+                (raise . run . fmap Compose . dist' . fmap dist . getCompose)+                (handleScoped effect)+              exFinal = ex' . \case+                Right (Compose a) -> Right . ex <$> a+                Left err -> Left err <$ s'+            exFinal <$> runStop tac+    inScope :: InterpreterFor (Scoped resource effect !! err) r1+    inScope =+      interpretH' \ (Weaving (Resumable inner) s' dist' ex' ins') ->+        case inner of+          Weaving effect s dist ex ins -> do+            let+              handleScoped = \case+                Run resource act ->+                  scopedHandler resource act+                InScope _ ->+                  error "nested InScope"+              tac =+                runTactics+                (Compose (s <$ s'))+                (raise . inScope . fmap Compose . dist' . fmap dist . getCompose)+                (ins <=< ins' . getCompose)+                (inScope . fmap Compose . dist' . fmap dist . getCompose)+                (handleScoped effect)+              exFinal = ex' . \case+                Right (Compose a) -> Right . ex <$> a+                Left err -> Left err <$ s'+            exFinal <$> runStop (raise tac)++interpretScopedResumableWith ::+  ∀ extra resource effect err r r1 .+  r1 ~ ((extra ++ '[Stop err]) ++ r) =>+  InsertAtIndex 1 '[Scoped resource effect !! err] r1 r (Scoped resource effect !! err : r1) (extra ++ '[Stop err]) =>+  (∀ x . (resource -> Sem r1 x) -> Sem (Stop err : r) x) ->+  (∀ r0 x . resource -> effect (Sem r0) x -> Sem r1 x) ->+  InterpreterFor (Scoped resource effect !! err) r+interpretScopedResumableWith withResource scopedHandler =+  interpretScopedResumableWithH @extra withResource \ r e -> liftT (scopedHandler r e)++interpretScopedResumableWith_ ::+  ∀ extra effect err r r1 .+  r1 ~ ((extra ++ '[Stop err]) ++ r) =>+  InsertAtIndex 1 '[Scoped () effect !! err] r1 r (Scoped () effect !! err : r1) (extra ++ '[Stop err]) =>+  (∀ x . Sem r1 x -> Sem (Stop err : r) x) ->+  (∀ r0 x . effect (Sem r0) x -> Sem r1 x) ->+  InterpreterFor (Scoped () effect !! err) r+interpretScopedResumableWith_ withResource scopedHandler =+  interpretScopedResumableWith @extra (\ f -> withResource (f ())) (const scopedHandler)

@@ -1,9 +1,7 @@ {-# options_haddock prune #-}+ -- |Description: Convenience Interpreters for all Conc Effects, Internal module Polysemy.Conc.Interpreter.Stack where--import Polysemy.Async (Async, asyncToIOFinal)-import Polysemy.Resource (Resource, resourceToIOFinal)  import Polysemy.Conc.Effect.Mask (Mask, UninterruptipleMask) import Polysemy.Conc.Effect.Race (Race)

@@ -1,8 +1,18 @@ -- |Description: Sync Interpreters module Polysemy.Conc.Interpreter.Sync where -import Control.Concurrent (isEmptyMVar)-import Polysemy.Resource (Resource)+import Control.Concurrent (+  MVar,+  isEmptyMVar,+  newEmptyMVar,+  newMVar,+  putMVar,+  readMVar,+  takeMVar,+  tryPutMVar,+  tryReadMVar,+  tryTakeMVar,+  )  import Polysemy.Conc.Effect.Race (Race) import Polysemy.Conc.Effect.Scoped (Scoped)@@ -20,29 +30,29 @@ interpretSyncWith var =   interpret \case     Sync.Block ->-      readMVar var+      embed (readMVar var)     Sync.Wait interval ->-      rightToMaybe <$> Race.timeoutAs () interval (readMVar var)+      rightToMaybe <$> Race.timeoutAs () interval (embed (readMVar var))     Sync.Try ->-      tryReadMVar var+      embed (tryReadMVar var)     Sync.TakeBlock ->-      takeMVar var+      embed (takeMVar var)     Sync.TakeWait interval ->-      rightToMaybe <$> Race.timeoutAs () interval (takeMVar var)+      rightToMaybe <$> Race.timeoutAs () interval (embed (takeMVar var))     Sync.TakeTry ->-      tryTakeMVar var+      embed (tryTakeMVar var)     Sync.ReadBlock ->-      readMVar var+      embed (readMVar var)     Sync.ReadWait interval ->-      rightToMaybe <$> Race.timeoutAs () interval (readMVar var)+      rightToMaybe <$> Race.timeoutAs () interval (embed (readMVar var))     Sync.ReadTry ->-      tryReadMVar var+      embed (tryReadMVar var)     Sync.PutBlock d ->-      putMVar var d+      embed (putMVar var d)     Sync.PutWait interval d ->-      Race.timeoutAs_ False interval (True <$ putMVar var d)+      Race.timeoutAs_ False interval (True <$ embed (putMVar var d))     Sync.PutTry d ->-      tryPutMVar var d+      embed (tryPutMVar var d)     Sync.Empty ->       embed (isEmptyMVar var) @@ -52,7 +62,7 @@   Members [Race, Embed IO] r =>   InterpreterFor (Sync d) r interpretSync sem = do-  var <- newEmptyMVar+  var <- embed newEmptyMVar   interpretSyncWith var sem  -- |Interpret 'Sync' with an 'MVar' containing the specified value.@@ -62,7 +72,7 @@   d ->   InterpreterFor (Sync d) r interpretSyncAs d sem = do-  var <- newMVar d+  var <- embed (newMVar d)   interpretSyncWith var sem  -- |Interpret 'Sync' for locally scoped use with an empty 'MVar'.@@ -71,7 +81,7 @@   Members [Resource, Race, Embed IO] r =>   InterpreterFor (Scoped (SyncResources (MVar d)) (Sync d)) r interpretScopedSync =-  runScopedAs (SyncResources <$> newEmptyMVar) \ r -> interpretSyncWith (unSyncResources r)+  runScopedAs (SyncResources <$> embed newEmptyMVar) \ r -> interpretSyncWith (unSyncResources r)  -- |Interpret 'Sync' for locally scoped use with an 'MVar' containing the specified value. interpretScopedSyncAs ::@@ -80,4 +90,4 @@   d ->   InterpreterFor (Scoped (SyncResources (MVar d)) (Sync d)) r interpretScopedSyncAs d =-  runScopedAs (SyncResources <$> newMVar d) \ r -> interpretSyncWith (unSyncResources r)+  runScopedAs (SyncResources <$> embed (newMVar d)) \ r -> interpretSyncWith (unSyncResources r)

@@ -1,8 +1,9 @@ {-# options_haddock prune #-}+ -- |Description: Monitor Implementations, Internal module Polysemy.Conc.Monitor where -import Data.Default (Default (def))+import Control.Concurrent (tryPutMVar) import qualified Polysemy.Time as Time import Polysemy.Time (Minutes (Minutes), NanoSeconds, Seconds (Seconds), Time, TimeUnit, convert) import Torsor (Torsor, difference, minus)@@ -15,7 +16,7 @@     interval :: NanoSeconds,     tolerance :: NanoSeconds   }-  deriving (Eq, Show)+  deriving stock (Eq, Show)  -- |Smart constructor for 'ClockSkewConfig' that takes arbitrary 'TimeUnit's. clockSkewConfig ::

@@ -1,88 +0,0 @@-{-# options_haddock hide #-}-{-# language NoImplicitPrelude #-}--module Polysemy.Conc.Prelude (-  module Data.Kind,-  module Polysemy.Conc.Prelude,-  module GHC.Err,-  module Polysemy,-  module Polysemy.AtomicState,-  module Relude,-) where--import Control.Exception (try)-import Data.Kind (Type)-import GHC.Err (undefined)-import Polysemy (-  Effect,-  EffectRow,-  Embed,-  Final,-  InterpreterFor,-  Member,-  Members,-  Sem,-  WithTactics,-  embed,-  embedToFinal,-  interpret,-  interpretH,-  makeSem,-  pureT,-  raise,-  raiseUnder,-  raiseUnder2,-  raiseUnder3,-  reinterpret,-  runFinal,-  )-import Polysemy.AtomicState (AtomicState, atomicGet, atomicGets, atomicModify', atomicPut)-import Polysemy.Internal.Kind (Append)-import Relude hiding (-  Reader,-  State,-  Sum,-  Type,-  ask,-  asks,-  evalState,-  filterM,-  get,-  gets,-  hoistEither,-  modify,-  modify',-  put,-  readFile,-  runReader,-  runState,-  state,-  trace,-  traceShow,-  undefined,-  )--unify :: Either a a -> a-unify =-  either id id-{-# inline unify #-}--tryAny ::-  Member (Embed IO) r =>-  IO a ->-  Sem r (Either Text a)-tryAny =-  embed @IO . fmap (first show) . try @SomeException-{-# INLINE tryAny #-}--type a ++ b =-  Append a b--leftM ::-  Applicative m =>-  m b ->-  Either a b ->-  m b-leftM f =-  either (const f) pure-{-# inline leftM #-}

@@ -20,6 +20,7 @@   write,   writeTimeout,   )+import Polysemy.Conc.Queue.Result (resultToMaybe)  -- |Read from a 'Queue' repeatedly until it is closed. --@@ -37,7 +38,7 @@       Queue.read >>= \case         QueueResult.Success d -> whenM (action d) spin         QueueResult.NotAvailable -> whenM na spin-        QueueResult.Closed -> pass+        QueueResult.Closed -> unit  -- |Read from a 'Queue' repeatedly until it is closed. --@@ -48,3 +49,11 @@   Sem r () loop action =   loopOr (pure True) \ d -> True <$ action d++-- |Read from a 'Queue' and convert the result to 'Maybe', returning 'Nothing' if there is no element available or the+-- queue has been closed.+readMaybe ::+  Member (Queue d) r =>+  Sem r (Maybe d)+readMaybe =+  resultToMaybe <$> read

@@ -1,6 +1,7 @@ -- |Description: Timeout Helper module Polysemy.Conc.Queue.Timeout where +import Control.Concurrent.STM (STM, atomically) import Polysemy.Time (TimeUnit)  import qualified Polysemy.Conc.Data.QueueResult as QueueResult@@ -19,4 +20,4 @@   Race.timeoutAs_ QueueResult.NotAvailable timeout reader'   where     reader' =-      maybe QueueResult.Closed QueueResult.Success <$> atomically readQ+      maybe QueueResult.Closed QueueResult.Success <$> embed (atomically readQ)

@@ -62,7 +62,7 @@   Sem r () ->   Sem r () timeoutU =-  timeout_ pass+  timeout_ unit {-# inline timeoutU #-}  -- |Variant of 'Race.timeout' that returns 'Maybe'.

@@ -5,7 +5,6 @@   module Polysemy.Conc.Effect.Sync ) where -import Polysemy.Resource (Resource, finally) import qualified Polysemy.Time as Time import Polysemy.Time (Time, TimeUnit) 

@@ -1,5 +0,0 @@-module Prelude (-  module Polysemy.Conc.Prelude,-) where--import Polysemy.Conc.Prelude

@@ -1,11 +1,11 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.34.4.+-- This file has been generated from package.yaml by hpack version 0.34.6. -- -- see: https://github.com/sol/hpack  name:           polysemy-conc-version:        0.5.1.1+version:        0.6.0.0 synopsis:       Polysemy Effects for Concurrency description:    See <https://hackage.haskell.org/package/polysemy-conc/docs/Polysemy-Conc.html> category:       Concurrency@@ -54,18 +54,12 @@       Polysemy.Conc.Interpreter.Stack       Polysemy.Conc.Interpreter.Sync       Polysemy.Conc.Monitor-      Polysemy.Conc.Prelude       Polysemy.Conc.Queue       Polysemy.Conc.Queue.Result       Polysemy.Conc.Queue.Timeout       Polysemy.Conc.Race       Polysemy.Conc.Retry       Polysemy.Conc.Sync-  other-modules:-      Prelude-      Paths_polysemy_conc-  autogen-modules:-      Paths_polysemy_conc   hs-source-dirs:       lib   default-extensions:@@ -126,20 +120,17 @@       UndecidableInstances       UnicodeSyntax       ViewPatterns-  ghc-options: -flate-specialise -fspecialise-aggressively -Wall -Wredundant-constraints+  ghc-options: -Wall -Wredundant-constraints -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Widentities   build-depends:       async     , base ==4.*     , containers-    , data-default >=0.2+    , incipit-core >=0.1.0.1     , polysemy >=1.6-    , polysemy-time >=0.1.4-    , relude >=0.7+    , polysemy-resume >=0.3+    , polysemy-time >=0.3     , stm     , stm-chans >=2-    , template-haskell-    , text-    , time     , torsor >=0.1     , unagi-chan >=0.4     , unix@@ -159,8 +150,8 @@       Polysemy.Conc.Test.MaskTest       Polysemy.Conc.Test.MonitorTest       Polysemy.Conc.Test.QueueTest+      Polysemy.Conc.Test.ScopedTest       Polysemy.Conc.Test.SyncTest-      Paths_polysemy_conc   hs-source-dirs:       test   default-extensions:@@ -221,13 +212,15 @@       UndecidableInstances       UnicodeSyntax       ViewPatterns-  ghc-options: -flate-specialise -fspecialise-aggressively -Wall -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+  ghc-options: -Wall -Wredundant-constraints -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Widentities -threaded -rtsopts -with-rtsopts=-N   build-depends:       async     , base ==4.*+    , incipit-core     , polysemy     , polysemy-conc-    , polysemy-plugin >=0.4+    , polysemy-plugin+    , polysemy-resume     , polysemy-test     , polysemy-time     , stm@@ -237,8 +230,6 @@     , unix   mixins:       base hiding (Prelude)-    , polysemy-conc hiding (Prelude)-    , polysemy-conc (Polysemy.Conc.Prelude as Prelude)   if impl(ghc >= 8.10)     ghc-options: -Wunused-packages   default-language: Haskell2010

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

@@ -12,6 +12,7 @@   test_queueTBM,   test_queueTimeoutTBM,   )+import Polysemy.Conc.Test.ScopedTest (test_scopedResumableWith, test_scopedWith) import Polysemy.Conc.Test.SyncTest (test_sync) import Polysemy.Test (unitTest) import Test.Tasty (TestTree, defaultMain, testGroup)@@ -42,6 +43,10 @@     testGroup "monitor" [       unitTest "basic" test_monitorBasic,       unitTest "clock skew" test_monitorClockSkew+    ],+    testGroup "scoped" [+      unitTest "scopedWith" test_scopedWith,+      unitTest "scopedResumableWith" test_scopedResumableWith     ]   ] 

@@ -1,7 +1,6 @@ module Polysemy.Conc.Test.EventsTest where  import Control.Concurrent.Chan.Unagi.Bounded (OutChan)-import Polysemy.Async (async, asyncToIOFinal, await) import Polysemy.Test (UnitTest, assertJust, runTestAuto)  import qualified Polysemy.Conc.Effect.Events as Events

@@ -1,7 +1,7 @@ module Polysemy.Conc.Test.InterruptTest where -import Control.Concurrent.STM (modifyTVar)-import Polysemy.Async (asyncToIOFinal)+import Control.Concurrent (MVar, newEmptyMVar, putMVar, takeMVar)+import Control.Concurrent.STM (TVar, atomically, modifyTVar, newTVarIO, readTVarIO) import Polysemy.Test (UnitTest, assertEq, runTestAuto) import System.Posix (Handler (CatchInfoOnce), SignalInfo, installHandler, keyboardSignal, raiseSignal) @@ -18,8 +18,8 @@ test_interrupt :: UnitTest test_interrupt = do   runTestAuto do-    tv <- newTVarIO 0-    mv <- newEmptyMVar+    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@@ -27,6 +27,6 @@       Interrupt.register "test 2" do         atomically (modifyTVar tv (9 +))       embed (raiseSignal keyboardSignal)-    takeMVar mv-    result <- readTVarIO tv+    embed (takeMVar mv)+    result <- embed (readTVarIO tv)     assertEq @_ @IO 17 result

@@ -1,7 +1,6 @@ module Polysemy.Conc.Test.LockTest where  import Data.Time (Day, UTCTime)-import Polysemy.Async (asyncToIOFinal, sequenceConcurrently) import Polysemy.Test (UnitTest, assertEq, runTestAuto) import qualified Polysemy.Time as Time import Polysemy.Time (MicroSeconds (MicroSeconds), interpretTimeGhc)

@@ -5,10 +5,10 @@ import qualified Control.Concurrent.Async as Base import Control.Concurrent.Async (asyncThreadId) import Control.Exception (throwTo)-import Polysemy (embedFinal)-import Polysemy.Async (Async, async, asyncToIOFinal, await)-import Polysemy.Error (fromExceptionSem, runError)+import GHC.Stack (withFrozenCallStack) import Polysemy.Test (Hedgehog, UnitTest, assertEq, evalLeft, runTestAuto)+import qualified Polysemy.Time as Time+import Polysemy.Time (MilliSeconds (MilliSeconds), interpretTimeGhc) import System.IO.Error (userError)  import Polysemy.Conc.AtomicState (interpretAtomic)@@ -17,8 +17,6 @@ import Polysemy.Conc.Interpreter.Mask (interpretUninterruptibleMaskFinal) import Polysemy.Conc.Interpreter.Race (interpretRace) import Polysemy.Conc.Interpreter.Sync (interpretSync)-import qualified Polysemy.Time as Time-import Polysemy.Time (interpretTimeGhc, MilliSeconds (MilliSeconds))  kill ::   Member (Final IO) r =>

@@ -2,8 +2,8 @@  module Polysemy.Conc.Test.MonitorTest where +import Control.Concurrent (MVar, putMVar) import Data.Time (UTCTime)-import Polysemy.Async (async, asyncToIOFinal, await) import Polysemy.Test (UnitTest, assertEq, assertJust, runTestAuto) import qualified Polysemy.Time as Time import Polysemy.Time (@@ -43,7 +43,7 @@   MVar () ->   Sem r () checker signal =-  Sync.takeBlock *> putMVar signal ()+  Sync.takeBlock *> embed (putMVar signal ())  test_monitorBasic :: UnitTest test_monitorBasic =

@@ -1,9 +1,9 @@ module Polysemy.Conc.Test.QueueTest where -import Polysemy.Async (Async, asyncToIOFinal) import Polysemy.Test (UnitTest, assertEq, assertJust, runTestAuto) import Polysemy.Time (MilliSeconds (MilliSeconds), interpretTimeGhc) import Polysemy.Time.Ghc (GhcTime)+import Prelude hiding (run)  import qualified Polysemy.Conc.Data.QueueResult as QueueResult import Polysemy.Conc.Data.QueueResult (QueueResult)

@@ -0,0 +1,99 @@+{-# options_ghc -fplugin=Polysemy.Plugin #-}++module Polysemy.Conc.Test.ScopedTest where++import Control.Concurrent.STM (TVar, atomically, newTVarIO, readTVarIO, writeTVar)+import Polysemy.Resume (Stop, stop, (!!))+import Polysemy.Test (UnitTest, runTestAuto, (===))++import Polysemy.Conc.Effect.Scoped (scoped)+import Polysemy.Conc.Interpreter.Scoped (interpretScopedResumableWithH, interpretScopedWithH)++data E :: Effect where+  E1 :: E m Int+  E2 :: E m Int++makeSem ''E++data F :: Effect where+  F :: F m Int++makeSem ''F++handleE ::+  Member (Embed IO) r =>+  TVar Int ->+  E m a ->+  Tactical effect m (F : r) a+handleE tv = \case+  E1 -> do+    i1 <- embed (readTVarIO tv)+    i2 <- f+    pureT (i1 + i2 + 10)+  E2 ->+    pureT (-1)++interpretF ::+  Member (Embed IO) r =>+  TVar Int ->+  InterpreterFor F r+interpretF tv =+  interpret \ F -> do+    embed (atomically (writeTVar tv 7))+    pure 5++scope ::+  Member (Embed IO) r =>+  (TVar Int -> Sem (F : r) a) ->+  Sem r a+scope use = do+  tv <- embed (newTVarIO 20)+  interpretF tv (use tv)++test_scopedWith :: UnitTest+test_scopedWith =+  runTestAuto $ interpretScopedWithH @'[F] scope handleE do+    i1 <- scoped e1+    i2 <- scoped e1+    i1 === 35+    i2 === 35++handleRE ::+  Member (Embed IO) r =>+  TVar Int ->+  E m a ->+  Tactical effect m (F : Stop Int : r) a+handleRE tv = \case+  E1 -> do+    i1 <- embed (readTVarIO tv)+    i2 <- f+    _ <- stop (i1 + i2)+    pureT (i1 + i2 + 10)+  E2 ->+    pureT =<< f++interpretFR ::+  Members [Stop Int, Embed IO] r =>+  TVar Int ->+  InterpreterFor F r+interpretFR tv =+  interpret \ F -> do+    embed (atomically (writeTVar tv 7))+    pure 5++scopeR ::+  Member (Embed IO) r =>+  (TVar Int -> Sem (F : Stop Int : r) a) ->+  Sem (Stop Int : r) a+scopeR use = do+  tv <- embed (newTVarIO 20)+  _ <- interpretF tv (use tv)+  stop . (50 +) =<< embed (readTVarIO tv)++test_scopedResumableWith :: UnitTest+test_scopedResumableWith =+  runTestAuto $ interpretScopedResumableWithH @'[F] scopeR handleRE do+    i1 <- scoped e1 !! pure+    i2 <- scoped e2 !! pure+    i1 === 25+    i2 === 57

@@ -1,7 +1,7 @@ module Polysemy.Conc.Test.SyncTest where -import Polysemy.Async (Async, asyncToIOFinal, sequenceConcurrently) import Polysemy.Test (UnitTest, assertEq, runTestAuto)+import Prelude hiding (run)  import Polysemy.Conc.Effect.Race (Race) import qualified Polysemy.Conc.Effect.Sync as Sync