Add Input and Output effects

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

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

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

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

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

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

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"