-
Notifications
You must be signed in to change notification settings - Fork 72
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Here's an Async effect that does exactly what you'd expect. Fixes #80
- Loading branch information
Showing
5 changed files
with
164 additions
and
1 deletion.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -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 #-} | ||
|
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -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" |