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