Async effect (#129)

Here's an Async effect that does exactly what you'd expect.

Fixes #80

ChangeLog.md

@@ -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
 

polysemy.cabal

@@ -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

src/Polysemy/Async.hs

@@ -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 #-}
+

src/Polysemy/Trace.hs

@@ -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.
 --

test/AsyncSpec.hs

@@ -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"