Add Input and Output effects

Author: arybczak

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,66 @@
+-- | Support for access to read only values of a particular type.
+--
+-- /Note:/ unless you plan to change interpretations at runtime, it's
+-- recommended to use one of the statically dispatched variants,
+-- i.e. "Effectful.Input.Static.Action" or "Effectful.Input.Static.Value".
+module Effectful.Input.Dynamic
+  ( -- * Effect
+    Input
+
+    -- ** Handlers
+  , runInputAction
+  , runInputValue
+
+    -- ** Operations
+  , input
+  , inputs
+  ) where
+
+import Effectful
+import Effectful.Dispatch.Dynamic
+
+-- | Provide access to read only values of type @i@.
+data Input i :: Effect where
+  Input :: Input i m i
+
+type instance DispatchOf (Input i) = Dynamic
+
+----------------------------------------
+-- Handlers
+
+-- | Run an 'Input' effect with the given action that supplies values.
+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
+
+-- | Run an 'Input' effect with the given initial value.
+runInputValue
+  :: HasCallStack
+  => i
+  -- ^ The input value.
+  -> Eff (Input i : es) a
+  -> Eff es a
+runInputValue inputValue = interpret_ $ \case
+  Input -> pure inputValue
+
+----------------------------------------
+-- Operations
+
+-- | Fetch the value.
+input :: (HasCallStack, Input i :> es) => Eff es i
+input = send Input
+
+-- | Fetch the result of applying a function to the value.
+--
+-- @'inputs' f ≡ f '<$>' 'input'@
+inputs
+  :: (HasCallStack, Input i :> es)
+  => (i -> a) -- ^ The function to apply to the value.
+  -> Eff es a
+inputs f = f <$> input

effectful-core/src/Effectful/Input/Static/Action.hs

@@ -0,0 +1,78 @@
+{-# LANGUAGE ImplicitParams #-}
+-- | Support for access to read only values supplied by a specified monadic
+-- action.
+module Effectful.Input.Static.Action
+  ( -- * Effect
+    Input
+
+    -- ** Handlers
+  , runInput
+
+    -- ** Operations
+  , input
+  , inputs
+  ) where
+
+import Data.Kind
+import GHC.Stack
+
+import Effectful
+import Effectful.Dispatch.Static
+import Effectful.Dispatch.Static.Primitive
+import Effectful.Internal.Utils
+
+-- | Provide access to read only values of type @i@.
+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)
+
+-- | Run an 'Input' effect with the given action that supplies values.
+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
+
+-- | Fetch the value.
+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
+
+-- | Fetch the result of applying a function to the value.
+--
+-- @'inputs' f ≡ f '<$>' 'input'@
+inputs
+  :: (HasCallStack, Input i :> es)
+  => (i -> a) -- ^ The function to apply to the value.
+  -> Eff es a
+inputs f = f <$> input
+
+----------------------------------------
+-- 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,47 @@
+-- | Support for access to a read only value of a particular type.
+module Effectful.Input.Static.Value
+  ( -- * Effect
+    Input
+
+    -- ** Handlers
+  , runInput
+
+    -- ** Operations
+  , input
+  , inputs
+  ) where
+
+import Data.Kind
+
+import Effectful
+import Effectful.Dispatch.Static
+
+-- | Provide access to a read only value of type @i@.
+data Input (i :: Type) :: Effect
+
+type instance DispatchOf (Input i) = Static NoSideEffects
+newtype instance StaticRep (Input i) = Input i
+
+-- | Run an 'Input' effect with the given initial value.
+runInput
+  :: HasCallStack
+  => i
+  -- ^ The input.
+  -> Eff (Input i : es) a
+  -> Eff es a
+runInput = evalStaticRep . Input
+
+-- | Fetch the value.
+input :: (HasCallStack, Input i :> es) => Eff es i
+input = do
+  Input i <- getStaticRep
+  pure i
+
+-- | Fetch the result of applying a function to the value.
+--
+-- @'inputs' f ≡ f '<$>' 'input'@
+inputs
+  :: (HasCallStack, Input i :> es)
+  => (i -> a) -- ^ The function to apply to the value.
+  -> Eff es a
+inputs f = f <$> input

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