Skip to content

Add Input and Output effects #289

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Draft
wants to merge 1 commit into
base: master
Choose a base branch
from
Draft
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
7 changes: 7 additions & 0 deletions effectful-core/effectful-core.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand Down
66 changes: 66 additions & 0 deletions effectful-core/src/Effectful/Input/Dynamic.hs
Original file line number Diff line number Diff line change
@@ -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
78 changes: 78 additions & 0 deletions effectful-core/src/Effectful/Input/Static/Action.hs
Original file line number Diff line number Diff line change
@@ -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
47 changes: 47 additions & 0 deletions effectful-core/src/Effectful/Input/Static/Value.hs
Original file line number Diff line number Diff line change
@@ -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
61 changes: 61 additions & 0 deletions effectful-core/src/Effectful/Output/Dynamic.hs
Original file line number Diff line number Diff line change
@@ -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
63 changes: 63 additions & 0 deletions effectful-core/src/Effectful/Output/Static/Action.hs
Original file line number Diff line number Diff line change
@@ -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
Loading
Loading