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