Skip to content

Commit 1cbd1e3

Browse files
arybczakarybczak
committed
Add Input and Output effects
1 parent 4ac38ab commit 1cbd1e3

File tree

13 files changed

+516
-2
lines changed

13 files changed

+516
-2
lines changed

‎effectful-core/effectful-core.cabal‎

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -90,6 +90,9 @@ library
9090
Effectful.Error.Static
9191
Effectful.Exception
9292
Effectful.Fail
93+
Effectful.Input.Dynamic
94+
Effectful.Input.Static.Action
95+
Effectful.Input.Static.Value
9396
Effectful.Internal.Effect
9497
Effectful.Internal.Env
9598
Effectful.Internal.Monad
@@ -101,6 +104,10 @@ library
101104
Effectful.Labeled.State
102105
Effectful.Labeled.Writer
103106
Effectful.NonDet
107+
Effectful.Output.Dynamic
108+
Effectful.Output.Static.Action
109+
Effectful.Output.Static.Array.Local
110+
Effectful.Output.Static.Array.Shared
104111
Effectful.Prim
105112
Effectful.Provider
106113
Effectful.Provider.List

‎effectful-core/src/Effectful/Input/Dynamic.hs‎

Lines changed: 66 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,66 @@
1+
-- | Support for access to read only values of a particular type.
2+
--
3+
-- /Note:/ unless you plan to change interpretations at runtime, it's
4+
-- recommended to use one of the statically dispatched variants,
5+
-- i.e. "Effectful.Input.Static.Action" or "Effectful.Input.Static.Value".
6+
module Effectful.Input.Dynamic
7+
( -- * Effect
8+
Input
9+
10+
-- ** Handlers
11+
, runInputAction
12+
, runInputValue
13+
14+
-- ** Operations
15+
, input
16+
, inputs
17+
) where
18+
19+
import Effectful
20+
import Effectful.Dispatch.Dynamic
21+
22+
-- | Provide access to read only values of type @i@.
23+
data Input i :: Effect where
24+
Input :: Input i m i
25+
26+
type instance DispatchOf (Input i) = Dynamic
27+
28+
----------------------------------------
29+
-- Handlers
30+
31+
-- | Run an 'Input' effect with the given action that supplies values.
32+
runInputAction
33+
:: forall i es a
34+
. HasCallStack
35+
=> (HasCallStack => Eff es i)
36+
-- ^ The action for input generation.
37+
-> Eff (Input i : es) a
38+
-> Eff es a
39+
runInputAction inputAction = interpret_ $ \case
40+
Input -> inputAction
41+
42+
-- | Run an 'Input' effect with the given initial value.
43+
runInputValue
44+
:: HasCallStack
45+
=> i
46+
-- ^ The input value.
47+
-> Eff (Input i : es) a
48+
-> Eff es a
49+
runInputValue inputValue = interpret_ $ \case
50+
Input -> pure inputValue
51+
52+
----------------------------------------
53+
-- Operations
54+
55+
-- | Fetch the value.
56+
input :: (HasCallStack, Input i :> es) => Eff es i
57+
input = send Input
58+
59+
-- | Fetch the result of applying a function to the value.
60+
--
61+
-- @'inputs' f ≡ f '<$>' 'input'@
62+
inputs
63+
:: (HasCallStack, Input i :> es)
64+
=> (i -> a) -- ^ The function to apply to the value.
65+
-> Eff es a
66+
inputs f = f <$> input

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

Lines changed: 78 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,78 @@
1+
{-# LANGUAGE ImplicitParams #-}
2+
-- | Support for access to read only values supplied by a specified monadic
3+
-- action.
4+
module Effectful.Input.Static.Action
5+
( -- * Effect
6+
Input
7+
8+
-- ** Handlers
9+
, runInput
10+
11+
-- ** Operations
12+
, input
13+
, inputs
14+
) where
15+
16+
import Data.Kind
17+
import GHC.Stack
18+
19+
import Effectful
20+
import Effectful.Dispatch.Static
21+
import Effectful.Dispatch.Static.Primitive
22+
import Effectful.Internal.Utils
23+
24+
-- | Provide access to read only values of type @i@.
25+
data Input (i :: Type) :: Effect
26+
27+
type instance DispatchOf (Input i) = Static NoSideEffects
28+
29+
-- | Wrapper to prevent a space leak on reconstruction of 'Input' in
30+
-- 'relinkInput' (see https://gitlab.haskell.org/ghc/ghc/-/issues/25520).
31+
newtype InputImpl i es where
32+
InputImpl :: (HasCallStack => Eff es i) -> InputImpl i es
33+
34+
data instance StaticRep (Input i) where
35+
Input
36+
:: !(Env inputEs)
37+
-> !(InputImpl i inputEs)
38+
-> StaticRep (Input i)
39+
40+
-- | Run an 'Input' effect with the given action that supplies values.
41+
runInput
42+
:: forall i es a
43+
. HasCallStack
44+
=> (HasCallStack => Eff es i)
45+
-- ^ The action for input generation.
46+
-> Eff (Input i : es) a
47+
-> Eff es a
48+
runInput inputAction action = unsafeEff $ \es -> do
49+
inlineBracket
50+
(consEnv (Input es inputImpl) relinkInput es)
51+
unconsEnv
52+
(unEff action)
53+
where
54+
inputImpl = InputImpl $ let ?callStack = thawCallStack ?callStack in inputAction
55+
56+
-- | Fetch the value.
57+
input :: (HasCallStack, Input i :> es) => Eff es i
58+
input = unsafeEff $ \es -> do
59+
Input inputEs (InputImpl inputAction) <- getEnv es
60+
-- Corresponds to thawCallStack in runInput.
61+
(`unEff` inputEs) $ withFrozenCallStack inputAction
62+
63+
-- | Fetch the result of applying a function to the value.
64+
--
65+
-- @'inputs' f ≡ f '<$>' 'input'@
66+
inputs
67+
:: (HasCallStack, Input i :> es)
68+
=> (i -> a) -- ^ The function to apply to the value.
69+
-> Eff es a
70+
inputs f = f <$> input
71+
72+
----------------------------------------
73+
-- Helpers
74+
75+
relinkInput :: Relinker StaticRep (Input i)
76+
relinkInput = Relinker $ \relink (Input inputEs inputAction) -> do
77+
newActionEs <- relink inputEs
78+
pure $ Input newActionEs inputAction

‎effectful-core/src/Effectful/Input/Static/Value.hs‎

Lines changed: 47 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,47 @@
1+
-- | Support for access to a read only value of a particular type.
2+
module Effectful.Input.Static.Value
3+
( -- * Effect
4+
Input
5+
6+
-- ** Handlers
7+
, runInput
8+
9+
-- ** Operations
10+
, input
11+
, inputs
12+
) where
13+
14+
import Data.Kind
15+
16+
import Effectful
17+
import Effectful.Dispatch.Static
18+
19+
-- | Provide access to a read only value of type @i@.
20+
data Input (i :: Type) :: Effect
21+
22+
type instance DispatchOf (Input i) = Static NoSideEffects
23+
newtype instance StaticRep (Input i) = Input i
24+
25+
-- | Run an 'Input' effect with the given initial value.
26+
runInput
27+
:: HasCallStack
28+
=> i
29+
-- ^ The input.
30+
-> Eff (Input i : es) a
31+
-> Eff es a
32+
runInput = evalStaticRep . Input
33+
34+
-- | Fetch the value.
35+
input :: (HasCallStack, Input i :> es) => Eff es i
36+
input = do
37+
Input i <- getStaticRep
38+
pure i
39+
40+
-- | Fetch the result of applying a function to the value.
41+
--
42+
-- @'inputs' f ≡ f '<$>' 'input'@
43+
inputs
44+
:: (HasCallStack, Input i :> es)
45+
=> (i -> a) -- ^ The function to apply to the value.
46+
-> Eff es a
47+
inputs f = f <$> input

‎effectful-core/src/Effectful/Output/Dynamic.hs‎

Lines changed: 61 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,61 @@
1+
module Effectful.Output.Dynamic
2+
( -- * Effect
3+
Output(..)
4+
5+
-- ** Handlers
6+
, runOutputAction
7+
, runOutputLocalArray
8+
, runOutputLocalList
9+
, runOutputSharedArray
10+
, runOutputSharedList
11+
12+
-- ** Operations
13+
, output
14+
) where
15+
16+
import Data.Primitive.Array
17+
18+
import Effectful
19+
import Effectful.Dispatch.Dynamic
20+
import Effectful.Output.Static.Array.Local qualified as LA
21+
import Effectful.Output.Static.Array.Shared qualified as SA
22+
23+
data Output o :: Effect where
24+
Output :: o -> Output o m ()
25+
26+
type instance DispatchOf (Output o) = Dynamic
27+
28+
----------------------------------------
29+
-- Handlers
30+
31+
runOutputAction
32+
:: forall o es a
33+
. HasCallStack
34+
=> (HasCallStack => o -> Eff es ())
35+
-- ^ The action for output generation.
36+
-> Eff (Output o : es) a
37+
-> Eff es a
38+
runOutputAction outputAction = interpret_ $ \case
39+
Output o -> outputAction o
40+
41+
runOutputLocalArray :: HasCallStack => Eff (Output o : es) a -> Eff es (a, Array o)
42+
runOutputLocalArray = reinterpret_ LA.runOutput $ \case
43+
Output o -> LA.output o
44+
45+
runOutputLocalList :: HasCallStack => Eff (Output o : es) a -> Eff es (a, [o])
46+
runOutputLocalList = reinterpret_ LA.runOutputList $ \case
47+
Output o -> LA.output o
48+
49+
runOutputSharedArray :: HasCallStack => Eff (Output o : es) a -> Eff es (a, Array o)
50+
runOutputSharedArray = reinterpret_ SA.runOutput $ \case
51+
Output o -> SA.output o
52+
53+
runOutputSharedList :: HasCallStack => Eff (Output o : es) a -> Eff es (a, [o])
54+
runOutputSharedList = reinterpret_ SA.runOutputList $ \case
55+
Output o -> SA.output o
56+
57+
----------------------------------------
58+
-- Operations
59+
60+
output :: (HasCallStack, Output o :> es) => o -> Eff es ()
61+
output = send . Output

‎effectful-core/src/Effectful/Output/Static/Action.hs‎

Lines changed: 63 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,63 @@
1+
{-# LANGUAGE ImplicitParams #-}
2+
module Effectful.Output.Static.Action
3+
( -- * Effect
4+
Output
5+
6+
-- ** Handlers
7+
, runOutput
8+
9+
-- ** Operations
10+
, output
11+
) where
12+
13+
import Data.Kind
14+
import GHC.Stack
15+
16+
import Effectful
17+
import Effectful.Dispatch.Static
18+
import Effectful.Dispatch.Static.Primitive
19+
import Effectful.Internal.Utils
20+
21+
data Output (o :: Type) :: Effect
22+
23+
type instance DispatchOf (Output o) = Static NoSideEffects
24+
25+
-- | Wrapper to prevent a space leak on reconstruction of 'Output' in
26+
-- 'relinkOutput' (see https://gitlab.haskell.org/ghc/ghc/-/issues/25520).
27+
newtype OutputImpl o es where
28+
OutputImpl :: (HasCallStack => o -> Eff es ()) -> OutputImpl o es
29+
30+
data instance StaticRep (Output o) where
31+
Output
32+
:: !(Env actionEs)
33+
-> !(OutputImpl o actionEs)
34+
-> StaticRep (Output o)
35+
36+
runOutput
37+
:: forall o es a
38+
. HasCallStack
39+
=> (HasCallStack => o -> Eff es ())
40+
-- ^ The action for output generation.
41+
-> Eff (Output o : es) a
42+
-> Eff es a
43+
runOutput outputAction action = unsafeEff $ \es -> do
44+
inlineBracket
45+
(consEnv (Output es outputImpl) relinkOutput es)
46+
unconsEnv
47+
(unEff action)
48+
where
49+
outputImpl = OutputImpl $ let ?callStack = thawCallStack ?callStack in outputAction
50+
51+
output :: (HasCallStack, Output o :> es) => o -> Eff es ()
52+
output !o = unsafeEff $ \es -> do
53+
Output actionEs (OutputImpl outputAction) <- getEnv es
54+
-- Corresponds to thawCallStack in runOutput.
55+
(`unEff` actionEs) $ withFrozenCallStack outputAction o
56+
57+
----------------------------------------
58+
-- Helpers
59+
60+
relinkOutput :: Relinker StaticRep (Output o)
61+
relinkOutput = Relinker $ \relink (Output actionEs outputAction) -> do
62+
newActionEs <- relink actionEs
63+
pure $ Output newActionEs outputAction

0 commit comments

Comments
 (0)