mirror of
https://github.com/polysemy-research/polysemy.git
synced 2024-09-11 02:25:43 +03:00
Async effect (#129)
Here's an Async effect that does exactly what you'd expect. Fixes #80
This commit is contained in:
parent
2654d35066
commit
8f3a4bcf19
@ -86,4 +86,6 @@
|
||||
|
||||
- Lots of hard work on the package and CI infrastructure to make it green on
|
||||
GHC 8.4.4 (thanks to @jkachmar)
|
||||
- runTraceAsList
|
||||
- New effect: Async
|
||||
|
||||
|
@ -4,7 +4,7 @@ cabal-version: 1.12
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
--
|
||||
-- hash: 3f07038fea02ea788ded67449bf361c83a48d3773798a68f15b6b03ac8032e2d
|
||||
-- hash: 89bd1eac9f4b2121d6cd6394446982b43db63e8ba7c5ccd8e295dae66fd20969
|
||||
|
||||
name: polysemy
|
||||
version: 0.4.0.0
|
||||
@ -40,6 +40,7 @@ flag error-messages
|
||||
library
|
||||
exposed-modules:
|
||||
Polysemy
|
||||
Polysemy.Async
|
||||
Polysemy.Error
|
||||
Polysemy.Fixpoint
|
||||
Polysemy.Input
|
||||
@ -99,6 +100,7 @@ test-suite polysemy-test
|
||||
main-is: Main.hs
|
||||
other-modules:
|
||||
AlternativeSpec
|
||||
AsyncSpec
|
||||
BracketSpec
|
||||
DoctestSpec
|
||||
FusionSpec
|
||||
|
98
src/Polysemy/Async.hs
Normal file
98
src/Polysemy/Async.hs
Normal file
@ -0,0 +1,98 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Polysemy.Async
|
||||
( -- * Effect
|
||||
Async (..)
|
||||
|
||||
-- * Actions
|
||||
, async
|
||||
, await
|
||||
|
||||
-- * Interpretations
|
||||
, runAsync
|
||||
, runAsyncInIO
|
||||
) where
|
||||
|
||||
import qualified Control.Concurrent.Async as A
|
||||
import Polysemy
|
||||
import Polysemy.Internal.Forklift
|
||||
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- |
|
||||
--
|
||||
-- TODO(sandy): @since
|
||||
data Async m a where
|
||||
Async :: m a -> Async m (A.Async (Maybe a))
|
||||
Await :: A.Async a -> Async m a
|
||||
|
||||
makeSem ''Async
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | A more flexible --- though less performant --- version of 'runAsyncInIO'.
|
||||
--
|
||||
-- This function is capable of running 'Async' effects anywhere within an
|
||||
-- effect stack, without relying on an explicit function to lower it into 'IO'.
|
||||
-- Notably, this means that 'Polysemy.State.State' effects will be consistent
|
||||
-- in the presence of 'Async'.
|
||||
--
|
||||
-- TODO(sandy): @since
|
||||
runAsync
|
||||
:: LastMember (Lift IO) r
|
||||
=> Sem (Async ': r) a
|
||||
-> Sem r a
|
||||
runAsync m = withLowerToIO $ \lower _ -> lower $
|
||||
interpretH
|
||||
( \case
|
||||
Async a -> do
|
||||
ma <- runT a
|
||||
ins <- getInspectorT
|
||||
fa <- sendM $ A.async $ lower $ runAsync_b ma
|
||||
pureT $ fmap (inspect ins) fa
|
||||
|
||||
Await a -> pureT =<< sendM (A.wait a)
|
||||
) m
|
||||
{-# INLINE runAsync #-}
|
||||
|
||||
|
||||
runAsync_b
|
||||
:: LastMember (Lift IO) r
|
||||
=> Sem (Async ': r) a
|
||||
-> Sem r a
|
||||
runAsync_b = runAsync
|
||||
{-# NOINLINE runAsync_b #-}
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Run an 'Async' effect via in terms of 'A.async'.
|
||||
--
|
||||
--
|
||||
-- TODO(sandy): @since
|
||||
runAsyncInIO
|
||||
:: Member (Lift IO) r
|
||||
=> (forall x. Sem r x -> IO x)
|
||||
-- ^ Strategy for lowering a 'Sem' action down to 'IO'. This is likely
|
||||
-- some combination of 'runM' and other interpreters composed via '.@'.
|
||||
-> Sem (Async ': r) a
|
||||
-> Sem r a
|
||||
runAsyncInIO lower m = interpretH
|
||||
( \case
|
||||
Async a -> do
|
||||
ma <- runT a
|
||||
ins <- getInspectorT
|
||||
fa <- sendM $ A.async $ lower $ runAsyncInIO_b lower ma
|
||||
pureT $ fmap (inspect ins) fa
|
||||
|
||||
Await a -> pureT =<< sendM (A.wait a)
|
||||
) m
|
||||
{-# INLINE runAsyncInIO #-}
|
||||
|
||||
runAsyncInIO_b
|
||||
:: Member (Lift IO) r
|
||||
=> (forall x. Sem r x -> IO x)
|
||||
-> Sem (Async ': r) a
|
||||
-> Sem r a
|
||||
runAsyncInIO_b = runAsyncInIO
|
||||
{-# NOINLINE runAsyncInIO_b #-}
|
||||
|
@ -9,6 +9,7 @@ module Polysemy.Trace
|
||||
|
||||
-- * Interpretations
|
||||
, runTraceIO
|
||||
, runTraceAsList
|
||||
, runIgnoringTrace
|
||||
, runTraceAsOutput
|
||||
|
||||
@ -54,6 +55,21 @@ runTraceAsOutput = interpret $ \case
|
||||
Trace m -> output m
|
||||
{-# INLINE runTraceAsOutput #-}
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Get the result of a 'Trace' effect as a list of 'String's.
|
||||
--
|
||||
-- TODO(sandy): @since
|
||||
runTraceAsList
|
||||
:: Sem (Trace ': r) a
|
||||
-> Sem r ([String], a)
|
||||
runTraceAsList = runFoldMapOutput @String (: []) . reinterpret (
|
||||
\case
|
||||
Trace m -> output m
|
||||
)
|
||||
{-# INLINE runTraceAsList #-}
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Transform a 'Trace' effect into a 'Output' 'String' effect.
|
||||
--
|
||||
|
45
test/AsyncSpec.hs
Normal file
45
test/AsyncSpec.hs
Normal file
@ -0,0 +1,45 @@
|
||||
{-# LANGUAGE NumDecimals #-}
|
||||
|
||||
module AsyncSpec where
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Monad
|
||||
import Polysemy
|
||||
import Polysemy.Async
|
||||
import Polysemy.State
|
||||
import Polysemy.Trace
|
||||
import Test.Hspec
|
||||
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "async" $ do
|
||||
it "should thread state and not lock" $ do
|
||||
(ts, (s, r)) <- runM
|
||||
. runTraceAsList
|
||||
. runState "hello"
|
||||
. runAsync $ do
|
||||
let message :: Member Trace r => Int -> String -> Sem r ()
|
||||
message n msg = trace $ mconcat
|
||||
[ show n, "> ", msg ]
|
||||
|
||||
a1 <- async $ do
|
||||
v <- get @String
|
||||
message 1 v
|
||||
put $ reverse v
|
||||
|
||||
sendM $ threadDelay 1e5
|
||||
get >>= message 1
|
||||
|
||||
sendM $ threadDelay 1e5
|
||||
get @String
|
||||
|
||||
void $ async $ do
|
||||
sendM $ threadDelay 5e4
|
||||
get >>= message 2
|
||||
put "pong"
|
||||
|
||||
await a1 <* put "final"
|
||||
|
||||
ts `shouldContain` ["1> hello", "2> olleh", "1> pong"]
|
||||
s `shouldBe` "final"
|
||||
r `shouldBe` Just "pong"
|
Loading…
Reference in New Issue
Block a user