From ed4c50a944004d0e1c900d8fc995906b40ba6ba0 Mon Sep 17 00:00:00 2001 From: Andrzej Rybczak Date: Sun, 22 Dec 2024 16:18:25 +0100 Subject: [PATCH] Add Effectful.Input.Const, Effectful.Output.Array and Effectful.Coroutine --- effectful-core/effectful-core.cabal | 3 + effectful-core/src/Effectful/Coroutine.hs | 92 ++++++++++++++++++++ effectful-core/src/Effectful/Input/Const.hs | 33 +++++++ effectful-core/src/Effectful/Output/Array.hs | 62 +++++++++++++ effectful/bench/Main.hs | 18 +++- effectful/effectful.cabal | 5 +- 6 files changed, 211 insertions(+), 2 deletions(-) create mode 100644 effectful-core/src/Effectful/Coroutine.hs create mode 100644 effectful-core/src/Effectful/Input/Const.hs create mode 100644 effectful-core/src/Effectful/Output/Array.hs diff --git a/effectful-core/effectful-core.cabal b/effectful-core/effectful-core.cabal index 0ff9a82..8d24e24 100644 --- a/effectful-core/effectful-core.cabal +++ b/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 diff --git a/effectful-core/src/Effectful/Coroutine.hs b/effectful-core/src/Effectful/Coroutine.hs new file mode 100644 index 0000000..6aae04d --- /dev/null +++ b/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 diff --git a/effectful-core/src/Effectful/Input/Const.hs b/effectful-core/src/Effectful/Input/Const.hs new file mode 100644 index 0000000..207f6c8 --- /dev/null +++ b/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 diff --git a/effectful-core/src/Effectful/Output/Array.hs b/effectful-core/src/Effectful/Output/Array.hs new file mode 100644 index 0000000..43cf57c --- /dev/null +++ b/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" diff --git a/effectful/bench/Main.hs b/effectful/bench/Main.hs index 2d998bf..c5ce1de 100644 --- a/effectful/bench/Main.hs +++ b/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] diff --git a/effectful/effectful.cabal b/effectful/effectful.cabal index 0f4d484..66893d5 100644 --- a/effectful/effectful.cabal +++ b/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