Skip to content

Commit 9493a3e

Browse files
arybczakarybczak
committed
Add Input and Output effects
1 parent 2d54743 commit 9493a3e

File tree

12 files changed

+450
-2
lines changed

12 files changed

+450
-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: 47 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,47 @@
1+
module Effectful.Input.Dynamic
2+
( -- * Effect
3+
Input
4+
5+
-- ** Handlers
6+
, runInputAction
7+
, runInputValue
8+
9+
-- ** Operations
10+
, input
11+
) where
12+
13+
import Effectful
14+
import Effectful.Dispatch.Dynamic
15+
16+
data Input i :: Effect where
17+
Input :: Input i m i
18+
19+
type instance DispatchOf (Input i) = Dynamic
20+
21+
----------------------------------------
22+
-- Handlers
23+
24+
runInputAction
25+
:: forall i es a
26+
. HasCallStack
27+
=> (HasCallStack => Eff es i)
28+
-- ^ The action for input generation.
29+
-> Eff (Input i : es) a
30+
-> Eff es a
31+
runInputAction inputAction = interpret_ $ \case
32+
Input -> inputAction
33+
34+
runInputValue
35+
:: HasCallStack
36+
=> i
37+
-- ^ The input value.
38+
-> Eff (Input i : es) a
39+
-> Eff es a
40+
runInputValue inputValue = interpret_ $ \case
41+
Input -> pure inputValue
42+
43+
----------------------------------------
44+
-- Operations
45+
46+
input :: (HasCallStack, Input i :> es) => Eff es i
47+
input = send Input

‎effectful-core/src/Effectful/Input/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.Input.Static.Action
3+
( -- * Effect
4+
Input
5+
6+
-- ** Handlers
7+
, runInput
8+
9+
-- ** Operations
10+
, input
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 Input (i :: Type) :: Effect
22+
23+
type instance DispatchOf (Input i) = Static NoSideEffects
24+
25+
-- | Wrapper to prevent a space leak on reconstruction of 'Input' in
26+
-- 'relinkInput' (see https://gitlab.haskell.org/ghc/ghc/-/issues/25520).
27+
newtype InputImpl i es where
28+
InputImpl :: (HasCallStack => Eff es i) -> InputImpl i es
29+
30+
data instance StaticRep (Input i) where
31+
Input
32+
:: !(Env inputEs)
33+
-> !(InputImpl i inputEs)
34+
-> StaticRep (Input i)
35+
36+
runInput
37+
:: forall i es a
38+
. HasCallStack
39+
=> (HasCallStack => Eff es i)
40+
-- ^ The action for input generation.
41+
-> Eff (Input i : es) a
42+
-> Eff es a
43+
runInput inputAction action = unsafeEff $ \es -> do
44+
inlineBracket
45+
(consEnv (Input es inputImpl) relinkInput es)
46+
unconsEnv
47+
(unEff action)
48+
where
49+
inputImpl = InputImpl $ let ?callStack = thawCallStack ?callStack in inputAction
50+
51+
input :: (HasCallStack, Input i :> es) => Eff es i
52+
input = unsafeEff $ \es -> do
53+
Input inputEs (InputImpl inputAction) <- getEnv es
54+
-- Corresponds to thawCallStack in runInput.
55+
(`unEff` inputEs) $ withFrozenCallStack inputAction
56+
57+
----------------------------------------
58+
-- Helpers
59+
60+
relinkInput :: Relinker StaticRep (Input i)
61+
relinkInput = Relinker $ \relink (Input inputEs inputAction) -> do
62+
newActionEs <- relink inputEs
63+
pure $ Input newActionEs inputAction

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

Lines changed: 33 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,33 @@
1+
module Effectful.Input.Static.Value
2+
( -- * Effect
3+
Input
4+
5+
-- ** Handlers
6+
, runInput
7+
8+
-- ** Operations
9+
, input
10+
) where
11+
12+
import Data.Kind
13+
14+
import Effectful
15+
import Effectful.Dispatch.Static
16+
17+
data Input (i :: Type) :: Effect
18+
19+
type instance DispatchOf (Input i) = Static NoSideEffects
20+
newtype instance StaticRep (Input i) = Input i
21+
22+
runInput
23+
:: HasCallStack
24+
=> i
25+
-- ^ The input.
26+
-> Eff (Input i : es) a
27+
-> Eff es a
28+
runInput = evalStaticRep . Input
29+
30+
input :: (HasCallStack, Input i :> es) => Eff es i
31+
input = do
32+
Input i <- getStaticRep
33+
pure i

‎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

‎effectful-core/src/Effectful/Output/Static/Array/Local.hs‎

Lines changed: 74 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,74 @@
1+
module Effectful.Output.Static.Array.Local
2+
( -- * Effect
3+
Output
4+
5+
-- ** Handlers
6+
, runOutput
7+
, runOutputList
8+
9+
-- ** Operations
10+
, output
11+
12+
-- * Re-exports
13+
, Array
14+
) where
15+
16+
import Control.Monad.Primitive
17+
import Data.Foldable qualified as F
18+
import Data.Kind
19+
import Data.Primitive.Array
20+
21+
import Effectful
22+
import Effectful.Dispatch.Static
23+
import Effectful.Internal.Utils
24+
import Effectful.Internal.Env
25+
26+
data Output (o :: Type) :: Effect
27+
28+
type instance DispatchOf (Output o) = Static NoSideEffects
29+
data instance StaticRep (Output o) = Output !Int !(MutableArray RealWorld o)
30+
31+
runOutput :: HasCallStack => Eff (Output o : es) a -> Eff es (a, Array o)
32+
runOutput = runOutputImpl $ \(Output size arr) -> do
33+
freezeArray arr 0 size
34+
35+
runOutputList :: HasCallStack => Eff (Output o : es) a -> Eff es (a, [o])
36+
runOutputList = runOutputImpl $ \(Output size arr) -> do
37+
take size . F.toList <$> unsafeFreezeArray arr
38+
39+
output :: (HasCallStack, Output o :> es) => o -> Eff es ()
40+
output !o = unsafeEff $ \es -> do
41+
Output size arr0 <- getEnv es
42+
let len0 = sizeofMutableArray arr0
43+
arr <- case size `compare` len0 of
44+
GT -> error $ "size (" ++ show size ++ ") > len0 (" ++ show len0 ++ ")"
45+
LT -> pure arr0
46+
EQ -> do
47+
let len = growCapacity len0
48+
arr <- newArray len undefinedValue
49+
copyMutableArray arr 0 arr0 0 size
50+
pure arr
51+
writeArray arr size o
52+
putEnv es $ Output (size + 1) arr
53+
54+
----------------------------------------
55+
-- Helpers
56+
57+
runOutputImpl
58+
:: HasCallStack
59+
=> (StaticRep (Output o) -> IO acc)
60+
-> Eff (Output o : es) a
61+
-> Eff es (a, acc)
62+
runOutputImpl f action = unsafeEff $ \es0 -> do
63+
arr <- newArray 0 undefinedValue
64+
inlineBracket
65+
(consEnv (Output 0 arr) relinkOutput es0)
66+
unconsEnv
67+
(\es -> (,) <$> unEff action es <*> (f =<< getEnv es))
68+
where
69+
relinkOutput = Relinker $ \_ (Output size arr0) -> do
70+
arr <- cloneMutableArray arr0 0 (sizeofMutableArray arr0)
71+
pure $ Output size arr
72+
73+
undefinedValue :: HasCallStack => a
74+
undefinedValue = error "Undefined value"

0 commit comments

Comments
 (0)