Add Effectful.Input.Const, Effectful.Output.Array and Effectful.Coroutine

Author: arybczak

effectful-core/effectful-core.cabal

@@ -82,6 +82,7 @@ library
       c-sources:     cbits/utils.c
 
     exposed-modules: Effectful
+                     Effectful.Coroutine
                      Effectful.Dispatch.Dynamic
                      Effectful.Dispatch.Static
                      Effectful.Dispatch.Static.Primitive
@@ -90,6 +91,7 @@ library
                      Effectful.Error.Static
                      Effectful.Exception
                      Effectful.Fail
+                     Effectful.Input.Const
                      Effectful.Internal.Effect
                      Effectful.Internal.Env
                      Effectful.Internal.Monad
@@ -101,6 +103,7 @@ library
                      Effectful.Labeled.State
                      Effectful.Labeled.Writer
                      Effectful.NonDet
+                     Effectful.Output.Array
                      Effectful.Prim
                      Effectful.Provider
                      Effectful.Provider.List

effectful-core/src/Effectful/Coroutine.hs

@@ -0,0 +1,92 @@
+module Effectful.Coroutine
+  ( -- * Effect
+    Coroutine(..)
+  , Input
+  , Output
+
+    -- ** Handlers
+  , runCoroutine
+  , runInputConst
+  , runOutputArray
+  , runOutputList
+
+    -- ** Operations
+  , yield
+  , input
+  , output
+  ) where
+
+import Data.Bifunctor
+import Data.Kind
+
+import Effectful
+import Effectful.Dispatch.Dynamic
+import Effectful.Input.Const qualified as IC
+import Effectful.Output.Array qualified as OA
+import Effectful.State.Static.Local qualified as S
+
+data Coroutine (a :: Type) (b :: Type) :: Effect where
+  Yield :: a -> Coroutine a b m b
+
+type instance DispatchOf (Coroutine i o) = Dynamic
+
+type Input i = Coroutine () i
+
+type Output o = Coroutine o ()
+
+----------------------------------------
+-- Handlers
+
+-- | Run the 'Coroutine' effect via a given action.
+runCoroutine
+  :: HasCallStack
+  => (a -> Eff es b)
+  -- ^ The action.
+  -> Eff (Coroutine a b : es) a
+  -> Eff es a
+runCoroutine f = interpret_ $ \case
+  Yield a -> f a
+
+-- | Run the 'Coroutine' effect via "Effectful.Input.Const".
+runInputConst
+  :: HasCallStack
+  => i
+  -- ^ The input.
+  -> Eff (Input i : es) a
+  -> Eff es a
+runInputConst i = reinterpret_ (IC.runInput i) $ \case
+  Yield () -> IC.input
+
+-- | Run the 'Coroutine' effect via "Effectful.Output.Array".
+runOutputArray
+  :: HasCallStack
+  => Eff (Output o : es) a
+  -- ^ .
+  -> Eff es (a, OA.Array o)
+runOutputArray = reinterpret_ OA.runOutput $ \case
+  Yield o -> OA.output o
+
+runOutputList
+  :: HasCallStack
+  => Eff (Output o : es) a
+  -- ^ .
+  -> Eff es (a, [o])
+runOutputList = reinterpret_ setup $ \case
+  Yield o -> S.modify (o :)
+  where
+    setup = fmap (second reverse) . S.runState []
+
+----------------------------------------
+-- Operations
+
+-- | Yield to the handler with the given value.
+yield :: forall b a es. (HasCallStack, Coroutine a b :> es) => a -> Eff es b
+yield = send . Yield
+
+-- | Request the value from the handler.
+input :: (HasCallStack, Coroutine () i :> es) => Eff es i
+input = send $ Yield ()
+
+-- | Pass the value to the handler.
+output :: (HasCallStack, Coroutine o () :> es) => o -> Eff es ()
+output = send . Yield

effectful-core/src/Effectful/Input/Const.hs

@@ -0,0 +1,33 @@
+module Effectful.Input.Const
+  ( -- * Effect
+    Input
+
+    -- ** Handlers
+  , runInput
+
+    -- ** Operations
+  , input
+  ) where
+
+import Data.Kind
+
+import Effectful
+import Effectful.Dispatch.Static
+
+data Input (i :: Type) :: Effect
+
+type instance DispatchOf (Input i) = Static NoSideEffects
+newtype instance StaticRep (Input i) = Input i
+
+runInput
+  :: HasCallStack
+  => i
+  -- ^ The input.
+  -> Eff (Input i : es) a
+  -> Eff es a
+runInput = evalStaticRep . Input
+
+input :: (HasCallStack, Input i :> es) => Eff es i
+input = do
+  Input i <- getStaticRep
+  pure i

effectful-core/src/Effectful/Output/Array.hs

@@ -0,0 +1,62 @@
+module Effectful.Output.Array
+  ( -- * Effect
+    Output
+
+    -- ** Handlers
+  , runOutput
+
+    -- ** Operations
+  , output
+
+    -- * Re-exports
+  , Array
+  ) where
+
+import Control.Monad.Primitive
+import Data.Kind
+import Data.Primitive.Array
+
+import Effectful
+import Effectful.Dispatch.Static
+import Effectful.Internal.Utils
+import Effectful.Internal.Env
+
+data Output (o :: Type) :: Effect
+
+type instance DispatchOf (Output o) = Static NoSideEffects
+data instance StaticRep (Output o) = Output !Int !(MutableArray RealWorld o)
+
+runOutput :: HasCallStack => Eff (Output o : es) a -> Eff es (a, Array o)
+runOutput action = unsafeEff $ \es0 -> do
+  arr <- newArray 0 undefinedValue
+  inlineBracket
+    (consEnv (Output 0 arr) relinkOutput es0)
+    unconsEnv
+    (\es -> (,) <$> unEff action es <*> (getArray =<< getEnv es))
+  where
+    getArray (Output size arr) = freezeArray arr 0 size
+
+output :: (HasCallStack, Output o :> es) => o -> Eff es ()
+output o = unsafeEff $ \es -> do
+  Output size arr0 <- getEnv es
+  let len0 = sizeofMutableArray arr0
+  arr <- case size `compare` len0 of
+    GT -> error $ "size (" ++ show size ++ ") > len0 (" ++ show len0 ++ ")"
+    LT -> pure arr0
+    EQ -> do
+      let len = growCapacity len0
+      arr <- newArray len undefinedValue
+      copyMutableArray arr 0 arr0 0 size
+      pure arr
+  writeArray arr size $! o
+  putEnv es $ Output (size + 1) arr
+
+----------------------------------------
+
+relinkOutput :: Relinker StaticRep (Output o)
+relinkOutput = Relinker $ \_ (Output size arr0) -> do
+  arr <- cloneMutableArray arr0 0 (sizeofMutableArray arr0)
+  pure $ Output size arr
+
+undefinedValue :: HasCallStack => a
+undefinedValue = error "Undefined value"

effectful/bench/Main.hs

@@ -15,9 +15,25 @@ import Countdown
 import FileSizes
 import Unlift
 
+----------------------------------------
+
+import Control.Monad
+import Effectful
+import Effectful.Coroutine
+
+benchOutput
+  :: (forall r es. Eff (Output Int : es) r -> Eff es (r, x))
+  -> Int
+  -> IO x
+benchOutput run n = fmap snd . runEff . run $ forM_ [1..n] output
+
 main :: IO ()
 main = defaultMain
-  [ concurrencyBenchmark
+  [ bgroup "output"
+    [ bench "array" $ nfAppIO (benchOutput runOutputArray) 1000
+    , bench "list" $ nfAppIO (benchOutput runOutputList) 1000
+    ]
+  , concurrencyBenchmark
   , unliftBenchmark
   , bgroup "countdown" $ map countdown [1000, 2000, 3000]
   , bgroup "countdown (extra)" $ map countdownExtra [1000, 2000, 3000]

effectful/effectful.cabal

@@ -113,18 +113,21 @@ library
                      Effectful.FileSystem.Effect
 
     reexported-modules:    Effectful
+                         , Effectful.Coroutine
                          , Effectful.Dispatch.Dynamic
                          , Effectful.Dispatch.Static
-                         , Effectful.Error.Static
                          , Effectful.Error.Dynamic
+                         , Effectful.Error.Static
                          , Effectful.Exception
                          , Effectful.Fail
+                         , Effectful.Input.Const
                          , Effectful.Labeled
                          , Effectful.Labeled.Error
                          , Effectful.Labeled.Reader
                          , Effectful.Labeled.State
                          , Effectful.Labeled.Writer
                          , Effectful.NonDet
+                         , Effectful.Output.Array
                          , Effectful.Prim
                          , Effectful.Provider
                          , Effectful.Provider.List