{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Polysemy.Uncontrolled
(
Uncontrolled (..),
send,
receive,
runUncontrolledAsState,
runUncontrolledAsStateSem,
runUncontrolledAsInputOutput,
adaptUncontrolledPure,
adaptUncontrolledSem,
runInputAsUncontrolled,
runOutputAsUncontrolled,
runMethodologyAsUncontrolled,
)
where
import Polysemy
import Polysemy.Input
import Polysemy.Methodology
import Polysemy.Output
import Polysemy.State
data Uncontrolled c b m a where
Send :: c -> Uncontrolled c b m ()
Receive :: Uncontrolled c b m b
makeSem ''Uncontrolled
runUncontrolledAsState :: forall s b c r a. Members '[State s] r => (c -> s) -> (s -> b) -> Sem (Uncontrolled c b ': r) a -> Sem r a
runUncontrolledAsState :: (c -> s) -> (s -> b) -> Sem (Uncontrolled c b : r) a -> Sem r a
runUncontrolledAsState c -> s
f s -> b
g = (c -> Sem r s)
-> (s -> Sem r b) -> Sem (Uncontrolled c b : r) a -> Sem r a
forall s b c (r :: [(* -> *) -> * -> *]) a.
Members '[State s] r =>
(c -> Sem r s)
-> (s -> Sem r b) -> Sem (Uncontrolled c b : r) a -> Sem r a
runUncontrolledAsStateSem (s -> Sem r s
forall (f :: * -> *) a. Applicative f => a -> f a
pure (s -> Sem r s) -> (c -> s) -> c -> Sem r s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> s
f) (b -> Sem r b
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> Sem r b) -> (s -> b) -> s -> Sem r b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> b
g)
{-# INLINE runUncontrolledAsState #-}
runUncontrolledAsStateSem :: forall s b c r a. Members '[State s] r => (c -> Sem r s) -> (s -> Sem r b) -> Sem (Uncontrolled c b ': r) a -> Sem r a
runUncontrolledAsStateSem :: (c -> Sem r s)
-> (s -> Sem r b) -> Sem (Uncontrolled c b : r) a -> Sem r a
runUncontrolledAsStateSem c -> Sem r s
f s -> Sem r b
g = (forall (rInitial :: [(* -> *) -> * -> *]) x.
Uncontrolled c b (Sem rInitial) x -> Sem r x)
-> Sem (Uncontrolled c b : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
FirstOrder e "interpret" =>
(forall (rInitial :: [(* -> *) -> * -> *]) x.
e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret ((forall (rInitial :: [(* -> *) -> * -> *]) x.
Uncontrolled c b (Sem rInitial) x -> Sem r x)
-> Sem (Uncontrolled c b : r) a -> Sem r a)
-> (forall (rInitial :: [(* -> *) -> * -> *]) x.
Uncontrolled c b (Sem rInitial) x -> Sem r x)
-> Sem (Uncontrolled c b : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
Send c -> c -> Sem r s
f c
c Sem r s -> (s -> Sem r ()) -> Sem r ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= s -> Sem r ()
forall s (r :: [(* -> *) -> * -> *]).
MemberWithError (State s) r =>
s -> Sem r ()
put
Uncontrolled c b (Sem rInitial) x
Receive -> Sem r s
forall s (r :: [(* -> *) -> * -> *]).
MemberWithError (State s) r =>
Sem r s
get Sem r s -> (s -> Sem r b) -> Sem r b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= s -> Sem r b
g
{-# INLINE runUncontrolledAsStateSem #-}
runUncontrolledAsInputOutput :: Members '[Input b, Output c] r => Sem (Uncontrolled c b ': r) a -> Sem r a
runUncontrolledAsInputOutput :: Sem (Uncontrolled c b : r) a -> Sem r a
runUncontrolledAsInputOutput = (forall (rInitial :: [(* -> *) -> * -> *]) x.
Uncontrolled c b (Sem rInitial) x -> Sem r x)
-> Sem (Uncontrolled c b : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
FirstOrder e "interpret" =>
(forall (rInitial :: [(* -> *) -> * -> *]) x.
e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret ((forall (rInitial :: [(* -> *) -> * -> *]) x.
Uncontrolled c b (Sem rInitial) x -> Sem r x)
-> Sem (Uncontrolled c b : r) a -> Sem r a)
-> (forall (rInitial :: [(* -> *) -> * -> *]) x.
Uncontrolled c b (Sem rInitial) x -> Sem r x)
-> Sem (Uncontrolled c b : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
Send c -> c -> Sem r ()
forall o (r :: [(* -> *) -> * -> *]).
MemberWithError (Output o) r =>
o -> Sem r ()
output c
c
Uncontrolled c b (Sem rInitial) x
Receive -> Sem r x
forall i (r :: [(* -> *) -> * -> *]).
MemberWithError (Input i) r =>
Sem r i
input
{-# INLINE runUncontrolledAsInputOutput #-}
adaptUncontrolledPure :: Members '[Uncontrolled c' b'] r => (c -> c') -> (b' -> b) -> Sem (Uncontrolled c b ': r) a -> Sem r a
adaptUncontrolledPure :: (c -> c') -> (b' -> b) -> Sem (Uncontrolled c b : r) a -> Sem r a
adaptUncontrolledPure c -> c'
f b' -> b
g = (c -> Sem r c')
-> (b' -> Sem r b) -> Sem (Uncontrolled c b : r) a -> Sem r a
forall c b c' b' (r :: [(* -> *) -> * -> *]) a.
Members '[Uncontrolled c' b'] r =>
(c -> Sem r c')
-> (b' -> Sem r b) -> Sem (Uncontrolled c b : r) a -> Sem r a
adaptUncontrolledSem (c' -> Sem r c'
forall (f :: * -> *) a. Applicative f => a -> f a
pure (c' -> Sem r c') -> (c -> c') -> c -> Sem r c'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> c'
f) (b -> Sem r b
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> Sem r b) -> (b' -> b) -> b' -> Sem r b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b' -> b
g)
{-# INLINE adaptUncontrolledPure #-}
adaptUncontrolledSem :: forall c b c' b' r a. Members '[Uncontrolled c' b'] r => (c -> Sem r c') -> (b' -> Sem r b) -> Sem (Uncontrolled c b ': r) a -> Sem r a
adaptUncontrolledSem :: (c -> Sem r c')
-> (b' -> Sem r b) -> Sem (Uncontrolled c b : r) a -> Sem r a
adaptUncontrolledSem c -> Sem r c'
f b' -> Sem r b
g = (forall (rInitial :: [(* -> *) -> * -> *]) x.
Uncontrolled c b (Sem rInitial) x -> Sem r x)
-> Sem (Uncontrolled c b : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
FirstOrder e "interpret" =>
(forall (rInitial :: [(* -> *) -> * -> *]) x.
e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret ((forall (rInitial :: [(* -> *) -> * -> *]) x.
Uncontrolled c b (Sem rInitial) x -> Sem r x)
-> Sem (Uncontrolled c b : r) a -> Sem r a)
-> (forall (rInitial :: [(* -> *) -> * -> *]) x.
Uncontrolled c b (Sem rInitial) x -> Sem r x)
-> Sem (Uncontrolled c b : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
Send c -> c -> Sem r c'
f c
c Sem r c' -> (c' -> Sem r ()) -> Sem r ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (r :: [(* -> *) -> * -> *]).
MemberWithError (Uncontrolled c' b') r =>
c' -> Sem r ()
forall c b (r :: [(* -> *) -> * -> *]).
MemberWithError (Uncontrolled c b) r =>
c -> Sem r ()
send @c' @b'
Uncontrolled c b (Sem rInitial) x
Receive -> forall (r :: [(* -> *) -> * -> *]).
MemberWithError (Uncontrolled c' b') r =>
Sem r b'
forall c b (r :: [(* -> *) -> * -> *]).
MemberWithError (Uncontrolled c b) r =>
Sem r b
receive @c' @b' Sem r b' -> (b' -> Sem r b) -> Sem r b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= b' -> Sem r b
g
{-# INLINE adaptUncontrolledSem #-}
runInputAsUncontrolled :: forall c b r a. Members '[Uncontrolled c b] r => Sem (Input b ': r) a -> Sem r a
runInputAsUncontrolled :: Sem (Input b : r) a -> Sem r a
runInputAsUncontrolled = (forall (rInitial :: [(* -> *) -> * -> *]) x.
Input b (Sem rInitial) x -> Sem r x)
-> Sem (Input b : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
FirstOrder e "interpret" =>
(forall (rInitial :: [(* -> *) -> * -> *]) x.
e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret ((forall (rInitial :: [(* -> *) -> * -> *]) x.
Input b (Sem rInitial) x -> Sem r x)
-> Sem (Input b : r) a -> Sem r a)
-> (forall (rInitial :: [(* -> *) -> * -> *]) x.
Input b (Sem rInitial) x -> Sem r x)
-> Sem (Input b : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
Input b (Sem rInitial) x
Input -> forall (r :: [(* -> *) -> * -> *]).
MemberWithError (Uncontrolled c b) r =>
Sem r b
forall c b (r :: [(* -> *) -> * -> *]).
MemberWithError (Uncontrolled c b) r =>
Sem r b
receive @c @b
{-# INLINE runInputAsUncontrolled #-}
runOutputAsUncontrolled :: forall c b r a. Members '[Uncontrolled c b] r => Sem (Output c ': r) a -> Sem r a
runOutputAsUncontrolled :: Sem (Output c : r) a -> Sem r a
runOutputAsUncontrolled = (forall (rInitial :: [(* -> *) -> * -> *]) x.
Output c (Sem rInitial) x -> Sem r x)
-> Sem (Output c : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
FirstOrder e "interpret" =>
(forall (rInitial :: [(* -> *) -> * -> *]) x.
e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret ((forall (rInitial :: [(* -> *) -> * -> *]) x.
Output c (Sem rInitial) x -> Sem r x)
-> Sem (Output c : r) a -> Sem r a)
-> (forall (rInitial :: [(* -> *) -> * -> *]) x.
Output c (Sem rInitial) x -> Sem r x)
-> Sem (Output c : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
Output c -> c -> Sem r ()
forall c b (r :: [(* -> *) -> * -> *]).
MemberWithError (Uncontrolled c b) r =>
c -> Sem r ()
send @c @b c
c
{-# INLINE runOutputAsUncontrolled #-}
runMethodologyAsUncontrolled :: forall c b r a. Members '[Uncontrolled b c] r => Sem (Methodology b c ': r) a -> Sem r a
runMethodologyAsUncontrolled :: Sem (Methodology b c : r) a -> Sem r a
runMethodologyAsUncontrolled = (forall (rInitial :: [(* -> *) -> * -> *]) x.
Methodology b c (Sem rInitial) x -> Sem r x)
-> Sem (Methodology b c : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
FirstOrder e "interpret" =>
(forall (rInitial :: [(* -> *) -> * -> *]) x.
e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret ((forall (rInitial :: [(* -> *) -> * -> *]) x.
Methodology b c (Sem rInitial) x -> Sem r x)
-> Sem (Methodology b c : r) a -> Sem r a)
-> (forall (rInitial :: [(* -> *) -> * -> *]) x.
Methodology b c (Sem rInitial) x -> Sem r x)
-> Sem (Methodology b c : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
Process b -> b -> Sem r ()
forall c b (r :: [(* -> *) -> * -> *]).
MemberWithError (Uncontrolled c b) r =>
c -> Sem r ()
send @b @c b
b Sem r () -> Sem r c -> Sem r c
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (r :: [(* -> *) -> * -> *]).
MemberWithError (Uncontrolled b c) r =>
Sem r c
forall c b (r :: [(* -> *) -> * -> *]).
MemberWithError (Uncontrolled c b) r =>
Sem r b
receive @b @c
{-# INLINE runMethodologyAsUncontrolled #-}