From 9493a3e7bd38b3547096398cf50056149cc17b41 Mon Sep 17 00:00:00 2001
From: Andrzej Rybczak <andrzej@rybczak.net>
Date: Sun, 22 Dec 2024 16:18:25 +0100
Subject: [PATCH] Add Input and Output effects
---
effectful-core/effectful-core.cabal | 7 ++
effectful-core/src/Effectful/Input/Dynamic.hs | 47 ++++++++++++
.../src/Effectful/Input/Static/Action.hs | 63 ++++++++++++++++
.../src/Effectful/Input/Static/Value.hs | 33 +++++++++
.../src/Effectful/Output/Dynamic.hs | 61 +++++++++++++++
.../src/Effectful/Output/Static/Action.hs | 63 ++++++++++++++++
.../Effectful/Output/Static/Array/Local.hs | 74 +++++++++++++++++++
.../Effectful/Output/Static/Array/Shared.hs | 73 ++++++++++++++++++
.../src/Effectful/Writer/Static/Local.hs | 2 +
.../src/Effectful/Writer/Static/Shared.hs | 2 +
effectful/bench/Main.hs | 18 ++++-
effectful/effectful.cabal | 9 ++-
12 files changed, 450 insertions(+), 2 deletions(-)
create mode 100644 effectful-core/src/Effectful/Input/Dynamic.hs
create mode 100644 effectful-core/src/Effectful/Input/Static/Action.hs
create mode 100644 effectful-core/src/Effectful/Input/Static/Value.hs
create mode 100644 effectful-core/src/Effectful/Output/Dynamic.hs
create mode 100644 effectful-core/src/Effectful/Output/Static/Action.hs
create mode 100644 effectful-core/src/Effectful/Output/Static/Array/Local.hs
create mode 100644 effectful-core/src/Effectful/Output/Static/Array/Shared.hs
diff --git a/effectful-core/effectful-core.cabal b/effectful-core/effectful-core.cabal
index 0ff9a82..460474f 100644
--- a/effectful-core/effectful-core.cabal
+++ b/effectful-core/effectful-core.cabal
@@ -90,6 +90,9 @@ library
Effectful.Error.Static
Effectful.Exception
Effectful.Fail
+ Effectful.Input.Dynamic
+ Effectful.Input.Static.Action
+ Effectful.Input.Static.Value
Effectful.Internal.Effect
Effectful.Internal.Env
Effectful.Internal.Monad
@@ -101,6 +104,10 @@ library
Effectful.Labeled.State
Effectful.Labeled.Writer
Effectful.NonDet
+ Effectful.Output.Dynamic
+ Effectful.Output.Static.Action
+ Effectful.Output.Static.Array.Local
+ Effectful.Output.Static.Array.Shared
Effectful.Prim
Effectful.Provider
Effectful.Provider.List
diff --git a/effectful-core/src/Effectful/Input/Dynamic.hs b/effectful-core/src/Effectful/Input/Dynamic.hs
new file mode 100644
index 0000000..245e0b6
--- /dev/null
+++ b/effectful-core/src/Effectful/Input/Dynamic.hs
@@ -0,0 +1,47 @@
+module Effectful.Input.Dynamic
+ ( -- * Effect
+ Input
+
+ -- ** Handlers
+ , runInputAction
+ , runInputValue
+
+ -- ** Operations
+ , input
+ ) where
+
+import Effectful
+import Effectful.Dispatch.Dynamic
+
+data Input i :: Effect where
+ Input :: Input i m i
+
+type instance DispatchOf (Input i) = Dynamic
+
+----------------------------------------
+-- Handlers
+
+runInputAction
+ :: forall i es a
+ . HasCallStack
+ => (HasCallStack => Eff es i)
+ -- ^ The action for input generation.
+ -> Eff (Input i : es) a
+ -> Eff es a
+runInputAction inputAction = interpret_ $ \case
+ Input -> inputAction
+
+runInputValue
+ :: HasCallStack
+ => i
+ -- ^ The input value.
+ -> Eff (Input i : es) a
+ -> Eff es a
+runInputValue inputValue = interpret_ $ \case
+ Input -> pure inputValue
+
+----------------------------------------
+-- Operations
+
+input :: (HasCallStack, Input i :> es) => Eff es i
+input = send Input
diff --git a/effectful-core/src/Effectful/Input/Static/Action.hs b/effectful-core/src/Effectful/Input/Static/Action.hs
new file mode 100644
index 0000000..2daace4
--- /dev/null
+++ b/effectful-core/src/Effectful/Input/Static/Action.hs
@@ -0,0 +1,63 @@
+{-# LANGUAGE ImplicitParams #-}
+module Effectful.Input.Static.Action
+ ( -- * Effect
+ Input
+
+ -- ** Handlers
+ , runInput
+
+ -- ** Operations
+ , input
+ ) where
+
+import Data.Kind
+import GHC.Stack
+
+import Effectful
+import Effectful.Dispatch.Static
+import Effectful.Dispatch.Static.Primitive
+import Effectful.Internal.Utils
+
+data Input (i :: Type) :: Effect
+
+type instance DispatchOf (Input i) = Static NoSideEffects
+
+-- | Wrapper to prevent a space leak on reconstruction of 'Input' in
+-- 'relinkInput' (see https://gitlab.haskell.org/ghc/ghc/-/issues/25520).
+newtype InputImpl i es where
+ InputImpl :: (HasCallStack => Eff es i) -> InputImpl i es
+
+data instance StaticRep (Input i) where
+ Input
+ :: !(Env inputEs)
+ -> !(InputImpl i inputEs)
+ -> StaticRep (Input i)
+
+runInput
+ :: forall i es a
+ . HasCallStack
+ => (HasCallStack => Eff es i)
+ -- ^ The action for input generation.
+ -> Eff (Input i : es) a
+ -> Eff es a
+runInput inputAction action = unsafeEff $ \es -> do
+ inlineBracket
+ (consEnv (Input es inputImpl) relinkInput es)
+ unconsEnv
+ (unEff action)
+ where
+ inputImpl = InputImpl $ let ?callStack = thawCallStack ?callStack in inputAction
+
+input :: (HasCallStack, Input i :> es) => Eff es i
+input = unsafeEff $ \es -> do
+ Input inputEs (InputImpl inputAction) <- getEnv es
+ -- Corresponds to thawCallStack in runInput.
+ (`unEff` inputEs) $ withFrozenCallStack inputAction
+
+----------------------------------------
+-- Helpers
+
+relinkInput :: Relinker StaticRep (Input i)
+relinkInput = Relinker $ \relink (Input inputEs inputAction) -> do
+ newActionEs <- relink inputEs
+ pure $ Input newActionEs inputAction
diff --git a/effectful-core/src/Effectful/Input/Static/Value.hs b/effectful-core/src/Effectful/Input/Static/Value.hs
new file mode 100644
index 0000000..beab39b
--- /dev/null
+++ b/effectful-core/src/Effectful/Input/Static/Value.hs
@@ -0,0 +1,33 @@
+module Effectful.Input.Static.Value
+ ( -- * 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/Dynamic.hs b/effectful-core/src/Effectful/Output/Dynamic.hs
new file mode 100644
index 0000000..6f1c1cc
--- /dev/null
+++ b/effectful-core/src/Effectful/Output/Dynamic.hs
@@ -0,0 +1,61 @@
+module Effectful.Output.Dynamic
+ ( -- * Effect
+ Output
+
+ -- ** Handlers
+ , runOutputAction
+ , runOutputLocalArray
+ , runOutputLocalList
+ , runOutputSharedArray
+ , runOutputSharedList
+
+ -- ** Operations
+ , output
+ ) where
+
+import Data.Primitive.Array
+
+import Effectful
+import Effectful.Dispatch.Dynamic
+import Effectful.Output.Static.Array.Local qualified as LA
+import Effectful.Output.Static.Array.Shared qualified as SA
+
+data Output o :: Effect where
+ Output :: o -> Output o m ()
+
+type instance DispatchOf (Output o) = Dynamic
+
+----------------------------------------
+-- Handlers
+
+runOutputAction
+ :: forall o es a
+ . HasCallStack
+ => (HasCallStack => o -> Eff es ())
+ -- ^ The action for output generation.
+ -> Eff (Output o : es) a
+ -> Eff es a
+runOutputAction outputAction = interpret_ $ \case
+ Output o -> outputAction o
+
+runOutputLocalArray :: HasCallStack => Eff (Output o : es) a -> Eff es (a, Array o)
+runOutputLocalArray = reinterpret_ LA.runOutput $ \case
+ Output o -> LA.output o
+
+runOutputLocalList :: HasCallStack => Eff (Output o : es) a -> Eff es (a, [o])
+runOutputLocalList = reinterpret_ LA.runOutputList $ \case
+ Output o -> LA.output o
+
+runOutputSharedArray :: HasCallStack => Eff (Output o : es) a -> Eff es (a, Array o)
+runOutputSharedArray = reinterpret_ SA.runOutput $ \case
+ Output o -> SA.output o
+
+runOutputSharedList :: HasCallStack => Eff (Output o : es) a -> Eff es (a, [o])
+runOutputSharedList = reinterpret_ SA.runOutputList $ \case
+ Output o -> SA.output o
+
+----------------------------------------
+-- Operations
+
+output :: (HasCallStack, Output o :> es) => o -> Eff es ()
+output = send . Output
diff --git a/effectful-core/src/Effectful/Output/Static/Action.hs b/effectful-core/src/Effectful/Output/Static/Action.hs
new file mode 100644
index 0000000..49f6c0e
--- /dev/null
+++ b/effectful-core/src/Effectful/Output/Static/Action.hs
@@ -0,0 +1,63 @@
+{-# LANGUAGE ImplicitParams #-}
+module Effectful.Output.Static.Action
+ ( -- * Effect
+ Output
+
+ -- ** Handlers
+ , runOutput
+
+ -- ** Operations
+ , output
+ ) where
+
+import Data.Kind
+import GHC.Stack
+
+import Effectful
+import Effectful.Dispatch.Static
+import Effectful.Dispatch.Static.Primitive
+import Effectful.Internal.Utils
+
+data Output (o :: Type) :: Effect
+
+type instance DispatchOf (Output o) = Static NoSideEffects
+
+-- | Wrapper to prevent a space leak on reconstruction of 'Output' in
+-- 'relinkOutput' (see https://gitlab.haskell.org/ghc/ghc/-/issues/25520).
+newtype OutputImpl o es where
+ OutputImpl :: (HasCallStack => o -> Eff es ()) -> OutputImpl o es
+
+data instance StaticRep (Output o) where
+ Output
+ :: !(Env actionEs)
+ -> !(OutputImpl o actionEs)
+ -> StaticRep (Output o)
+
+runOutput
+ :: forall o es a
+ . HasCallStack
+ => (HasCallStack => o -> Eff es ())
+ -- ^ The action for output generation.
+ -> Eff (Output o : es) a
+ -> Eff es a
+runOutput outputAction action = unsafeEff $ \es -> do
+ inlineBracket
+ (consEnv (Output es outputImpl) relinkOutput es)
+ unconsEnv
+ (unEff action)
+ where
+ outputImpl = OutputImpl $ let ?callStack = thawCallStack ?callStack in outputAction
+
+output :: (HasCallStack, Output o :> es) => o -> Eff es ()
+output !o = unsafeEff $ \es -> do
+ Output actionEs (OutputImpl outputAction) <- getEnv es
+ -- Corresponds to thawCallStack in runOutput.
+ (`unEff` actionEs) $ withFrozenCallStack outputAction o
+
+----------------------------------------
+-- Helpers
+
+relinkOutput :: Relinker StaticRep (Output o)
+relinkOutput = Relinker $ \relink (Output actionEs outputAction) -> do
+ newActionEs <- relink actionEs
+ pure $ Output newActionEs outputAction
diff --git a/effectful-core/src/Effectful/Output/Static/Array/Local.hs b/effectful-core/src/Effectful/Output/Static/Array/Local.hs
new file mode 100644
index 0000000..bd3fe69
--- /dev/null
+++ b/effectful-core/src/Effectful/Output/Static/Array/Local.hs
@@ -0,0 +1,74 @@
+module Effectful.Output.Static.Array.Local
+ ( -- * Effect
+ Output
+
+ -- ** Handlers
+ , runOutput
+ , runOutputList
+
+ -- ** Operations
+ , output
+
+ -- * Re-exports
+ , Array
+ ) where
+
+import Control.Monad.Primitive
+import Data.Foldable qualified as F
+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 = runOutputImpl $ \(Output size arr) -> do
+ freezeArray arr 0 size
+
+runOutputList :: HasCallStack => Eff (Output o : es) a -> Eff es (a, [o])
+runOutputList = runOutputImpl $ \(Output size arr) -> do
+ take size . F.toList <$> unsafeFreezeArray arr
+
+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
+
+----------------------------------------
+-- Helpers
+
+runOutputImpl
+ :: HasCallStack
+ => (StaticRep (Output o) -> IO acc)
+ -> Eff (Output o : es) a
+ -> Eff es (a, acc)
+runOutputImpl f action = unsafeEff $ \es0 -> do
+ arr <- newArray 0 undefinedValue
+ inlineBracket
+ (consEnv (Output 0 arr) relinkOutput es0)
+ unconsEnv
+ (\es -> (,) <$> unEff action es <*> (f =<< getEnv es))
+ where
+ 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-core/src/Effectful/Output/Static/Array/Shared.hs b/effectful-core/src/Effectful/Output/Static/Array/Shared.hs
new file mode 100644
index 0000000..6127342
--- /dev/null
+++ b/effectful-core/src/Effectful/Output/Static/Array/Shared.hs
@@ -0,0 +1,73 @@
+module Effectful.Output.Static.Array.Shared
+ ( -- * Effect
+ Output
+
+ -- ** Handlers
+ , runOutput
+ , runOutputList
+
+ -- ** Operations
+ , output
+
+ -- * Re-exports
+ , Array
+ ) where
+
+import Control.Concurrent.MVar.Strict
+import Control.Monad.Primitive
+import Data.Foldable qualified as F
+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
+
+data OutputData o = OutputData !Int !(MutableArray RealWorld o)
+
+type instance DispatchOf (Output o) = Static NoSideEffects
+newtype instance StaticRep (Output o) = Output (MVar' (OutputData o))
+
+runOutput :: HasCallStack => Eff (Output o : es) a -> Eff es (a, Array o)
+runOutput = runOutputImpl $ \(OutputData size arr) -> do
+ freezeArray arr 0 size
+
+runOutputList :: HasCallStack => Eff (Output o : es) a -> Eff es (a, [o])
+runOutputList = runOutputImpl $ \(OutputData size arr) -> do
+ take size . F.toList <$> unsafeFreezeArray arr
+
+output :: (HasCallStack, Output o :> es) => o -> Eff es ()
+output !o = unsafeEff $ \es -> do
+ Output v <- getEnv es
+ modifyMVar'_ v $ \(OutputData size arr0) -> do
+ 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
+ pure $ OutputData (size + 1) arr
+
+----------------------------------------
+-- Helpers
+
+runOutputImpl
+ :: HasCallStack
+ => (OutputData o -> IO acc)
+ -> Eff (Output o : es) a
+ -> Eff es (a, acc)
+runOutputImpl f action = do
+ v <- unsafeEff_ $ newMVar' . OutputData 0 =<< newArray 0 undefinedValue
+ a <- evalStaticRep (Output v) action
+ acc <- unsafeEff_ $ f =<< readMVar' v
+ pure (a, acc)
+
+undefinedValue :: HasCallStack => a
+undefinedValue = error "Undefined value"
diff --git a/effectful-core/src/Effectful/Writer/Static/Local.hs b/effectful-core/src/Effectful/Writer/Static/Local.hs
index 05057fd..8380946 100644
--- a/effectful-core/src/Effectful/Writer/Static/Local.hs
+++ b/effectful-core/src/Effectful/Writer/Static/Local.hs
@@ -8,6 +8,8 @@
-- is inefficient. __This applies, in particular, to the standard list type__,
-- which makes the 'Writer' effect pretty niche.
--
+-- __If you just want to accumulate values, use "Effectful.Output.Static.Array.Local".__
+--
-- /Note:/ while the 'Control.Monad.Trans.Writer.Strict.Writer' from the
-- @transformers@ package includes additional operations
-- 'Control.Monad.Trans.Writer.Strict.pass' and
diff --git a/effectful-core/src/Effectful/Writer/Static/Shared.hs b/effectful-core/src/Effectful/Writer/Static/Shared.hs
index 55a4a8f..4d5b29b 100644
--- a/effectful-core/src/Effectful/Writer/Static/Shared.hs
+++ b/effectful-core/src/Effectful/Writer/Static/Shared.hs
@@ -8,6 +8,8 @@
-- is inefficient. __This applies, in particular, to the standard list type__,
-- which makes the 'Writer' effect pretty niche.
--
+-- __If you just want to accumulate values, use "Effectful.Output.Static.Array.Shared".__
+--
-- /Note:/ while the 'Control.Monad.Trans.Writer.Strict.Writer' from the
-- @transformers@ package includes additional operations
-- 'Control.Monad.Trans.Writer.Strict.pass' and
diff --git a/effectful/bench/Main.hs b/effectful/bench/Main.hs
index 2d998bf..5175506 100644
--- a/effectful/bench/Main.hs
+++ b/effectful/bench/Main.hs
@@ -15,9 +15,25 @@ import Countdown
import FileSizes
import Unlift
+----------------------------------------
+
+import Data.Foldable
+import Effectful
+import Effectful.Output.Dynamic
+
+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 runOutputLocalArray) 1000000
+ , bench "list" $ nfAppIO (benchOutput runOutputLocalList) 1000000
+ ]
+ , 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..5626b0e 100644
--- a/effectful/effectful.cabal
+++ b/effectful/effectful.cabal
@@ -115,16 +115,23 @@ library
reexported-modules: Effectful
, Effectful.Dispatch.Dynamic
, Effectful.Dispatch.Static
- , Effectful.Error.Static
, Effectful.Error.Dynamic
+ , Effectful.Error.Static
, Effectful.Exception
, Effectful.Fail
+ , Effectful.Input.Dynamic
+ , Effectful.Input.Static.Action
+ , Effectful.Input.Static.Value
, Effectful.Labeled
, Effectful.Labeled.Error
, Effectful.Labeled.Reader
, Effectful.Labeled.State
, Effectful.Labeled.Writer
, Effectful.NonDet
+ , Effectful.Output.Dynamic
+ , Effectful.Output.Static.Action
+ , Effectful.Output.Static.Array.Local
+ , Effectful.Output.Static.Array.Shared
, Effectful.Prim
, Effectful.Provider
, Effectful.Provider.List