module Control.Monad.Ology.General.Coroutine where

import Control.Monad.Ology.General.Trans.Trans
import Control.Monad.Ology.General.Trans.Tunnel
import Control.Monad.Ology.Specific.CoroutineT
import Control.Monad.Ology.Specific.StepT
import Import

-- | Monads in which one can do coroutines.
class Monad m => MonadCoroutine m where
    coroutineSuspend :: ((p -> m q) -> m r) -> CoroutineT p q m r

-- | Uses threads.
instance MonadCoroutine IO where
    coroutineSuspend :: ((p -> IO q) -> IO r) -> CoroutineT p q IO r
    coroutineSuspend :: forall p q r. ((p -> IO q) -> IO r) -> CoroutineT p q IO r
coroutineSuspend (p -> IO q) -> IO r
action =
        IO (Either r (Turn p q (StepT (Turn p q) IO r)))
-> StepT (Turn p q) IO r
forall (f :: Type -> Type) (m :: Type -> Type) a.
m (Either a (f (StepT f m a))) -> StepT f m a
MkStepT (IO (Either r (Turn p q (StepT (Turn p q) IO r)))
 -> StepT (Turn p q) IO r)
-> IO (Either r (Turn p q (StepT (Turn p q) IO r)))
-> StepT (Turn p q) IO r
forall a b. (a -> b) -> a -> b
$ do
            MVar q
invar <- IO (MVar q)
forall a. IO (MVar a)
newEmptyMVar
            MVar (Either r (Turn p q (StepT (Turn p q) IO r)))
outvar <- IO (MVar (Either r (Turn p q (StepT (Turn p q) IO r))))
forall a. IO (MVar a)
newEmptyMVar
            ThreadId
_ <-
                IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
                    r
r <-
                        (p -> IO q) -> IO r
action ((p -> IO q) -> IO r) -> (p -> IO q) -> IO r
forall a b. (a -> b) -> a -> b
$ \p
p -> do
                            MVar (Either r (Turn p q (StepT (Turn p q) IO r)))
-> Either r (Turn p q (StepT (Turn p q) IO r)) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either r (Turn p q (StepT (Turn p q) IO r)))
outvar (Either r (Turn p q (StepT (Turn p q) IO r)) -> IO ())
-> Either r (Turn p q (StepT (Turn p q) IO r)) -> IO ()
forall a b. (a -> b) -> a -> b
$
                                Turn p q (StepT (Turn p q) IO r)
-> Either r (Turn p q (StepT (Turn p q) IO r))
forall a b. b -> Either a b
Right (Turn p q (StepT (Turn p q) IO r)
 -> Either r (Turn p q (StepT (Turn p q) IO r)))
-> Turn p q (StepT (Turn p q) IO r)
-> Either r (Turn p q (StepT (Turn p q) IO r))
forall a b. (a -> b) -> a -> b
$
                                p
-> (q -> StepT (Turn p q) IO r) -> Turn p q (StepT (Turn p q) IO r)
forall p q a. p -> (q -> a) -> Turn p q a
MkTurn p
p ((q -> StepT (Turn p q) IO r) -> Turn p q (StepT (Turn p q) IO r))
-> (q -> StepT (Turn p q) IO r) -> Turn p q (StepT (Turn p q) IO r)
forall a b. (a -> b) -> a -> b
$ \q
q ->
                                    IO (Either r (Turn p q (StepT (Turn p q) IO r)))
-> StepT (Turn p q) IO r
forall (f :: Type -> Type) (m :: Type -> Type) a.
m (Either a (f (StepT f m a))) -> StepT f m a
MkStepT (IO (Either r (Turn p q (StepT (Turn p q) IO r)))
 -> StepT (Turn p q) IO r)
-> IO (Either r (Turn p q (StepT (Turn p q) IO r)))
-> StepT (Turn p q) IO r
forall a b. (a -> b) -> a -> b
$ do
                                        MVar q -> q -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar q
invar q
q
                                        MVar (Either r (Turn p q (StepT (Turn p q) IO r)))
-> IO (Either r (Turn p q (StepT (Turn p q) IO r)))
forall a. MVar a -> IO a
takeMVar MVar (Either r (Turn p q (StepT (Turn p q) IO r)))
outvar
                            MVar q -> IO q
forall a. MVar a -> IO a
takeMVar MVar q
invar
                    MVar (Either r (Turn p q (StepT (Turn p q) IO r)))
-> Either r (Turn p q (StepT (Turn p q) IO r)) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either r (Turn p q (StepT (Turn p q) IO r)))
outvar (Either r (Turn p q (StepT (Turn p q) IO r)) -> IO ())
-> Either r (Turn p q (StepT (Turn p q) IO r)) -> IO ()
forall a b. (a -> b) -> a -> b
$ r -> Either r (Turn p q (StepT (Turn p q) IO r))
forall a b. a -> Either a b
Left r
r
            MVar (Either r (Turn p q (StepT (Turn p q) IO r)))
-> IO (Either r (Turn p q (StepT (Turn p q) IO r)))
forall a. MVar a -> IO a
takeMVar MVar (Either r (Turn p q (StepT (Turn p q) IO r)))
outvar

instance (MonadTransTunnel t, MonadCoroutine m) => MonadCoroutine (t m) where
    coroutineSuspend :: forall p q r. ((p -> t m q) -> t m r) -> CoroutineT p q (t m) r
coroutineSuspend (p -> t m q) -> t m r
call = ((forall (m1 :: Type -> Type) a.
  Monad m1 =>
  t m1 a -> m1 (Tunnel t a))
 -> StepT (Turn p q) m (Tunnel t r))
-> StepT (Turn p q) (t m) r
forall (t :: TransKind) (m :: Type -> Type) (turn :: Type -> Type)
       r.
(MonadTransTunnel t, Monad m, Functor turn) =>
((forall (m1 :: Type -> Type) a.
  Monad m1 =>
  t m1 a -> m1 (Tunnel t a))
 -> StepT turn m (Tunnel t r))
-> StepT turn (t m) r
underTunnelStepT (((forall (m1 :: Type -> Type) a.
   Monad m1 =>
   t m1 a -> m1 (Tunnel t a))
  -> StepT (Turn p q) m (Tunnel t r))
 -> StepT (Turn p q) (t m) r)
-> ((forall (m1 :: Type -> Type) a.
     Monad m1 =>
     t m1 a -> m1 (Tunnel t a))
    -> StepT (Turn p q) m (Tunnel t r))
-> StepT (Turn p q) (t m) r
forall a b. (a -> b) -> a -> b
$ \forall (m1 :: Type -> Type) a.
Monad m1 =>
t m1 a -> m1 (Tunnel t a)
tun -> ((p -> m q) -> m (Tunnel t r)) -> StepT (Turn p q) m (Tunnel t r)
forall p q r. ((p -> m q) -> m r) -> CoroutineT p q m r
forall (m :: Type -> Type) p q r.
MonadCoroutine m =>
((p -> m q) -> m r) -> CoroutineT p q m r
coroutineSuspend (((p -> m q) -> m (Tunnel t r)) -> StepT (Turn p q) m (Tunnel t r))
-> ((p -> m q) -> m (Tunnel t r))
-> StepT (Turn p q) m (Tunnel t r)
forall a b. (a -> b) -> a -> b
$ \p -> m q
pmq -> t m r -> m (Tunnel t r)
forall (m1 :: Type -> Type) a.
Monad m1 =>
t m1 a -> m1 (Tunnel t a)
tun (t m r -> m (Tunnel t r)) -> t m r -> m (Tunnel t r)
forall a b. (a -> b) -> a -> b
$ (p -> t m q) -> t m r
call ((p -> t m q) -> t m r) -> (p -> t m q) -> t m r
forall a b. (a -> b) -> a -> b
$ \p
p -> m q -> t m q
forall (m :: Type -> Type) a. Monad m => m a -> t m a
forall (t :: TransKind) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m q -> t m q) -> m q -> t m q
forall a b. (a -> b) -> a -> b
$ p -> m q
pmq p
p

-- | A type synoynm for a common pattern for closing opened resources, e.g.
-- 'System.IO.withFile',
-- 'System.IO.withBinaryFile',
-- etc.
type With (m :: k -> Type) (t :: Type) = forall (r :: k). (t -> m r) -> m r

unpickWith ::
       forall m a. MonadCoroutine m
    => With m a
    -> m (a, m ())
unpickWith :: forall (m :: Type -> Type) a.
MonadCoroutine m =>
With m a -> m (a, m ())
unpickWith With m a
w = do
    Either a (Turn a a (StepT (Turn a a) m a))
etp <- StepT (Turn a a) m a
-> m (Either a (Turn a a (StepT (Turn a a) m a)))
forall (f :: Type -> Type) (m :: Type -> Type) a.
StepT f m a -> m (Either a (f (StepT f m a)))
unStepT (StepT (Turn a a) m a
 -> m (Either a (Turn a a (StepT (Turn a a) m a))))
-> StepT (Turn a a) m a
-> m (Either a (Turn a a (StepT (Turn a a) m a)))
forall a b. (a -> b) -> a -> b
$ ((a -> m a) -> m a) -> StepT (Turn a a) m a
forall p q r. ((p -> m q) -> m r) -> CoroutineT p q m r
forall (m :: Type -> Type) p q r.
MonadCoroutine m =>
((p -> m q) -> m r) -> CoroutineT p q m r
coroutineSuspend (a -> m a) -> m a
With m a
w
    case Either a (Turn a a (StepT (Turn a a) m a))
etp of
        Left a
a -> (a, m ()) -> m (a, m ())
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (a
a, () -> m ()
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ())
        Right (MkTurn a
a a -> StepT (Turn a a) m a
f) -> (a, m ()) -> m (a, m ())
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (a
a, (a -> ()) -> m a -> m ()
forall a b. (a -> b) -> m a -> m b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (\a
_ -> ()) (m a -> m ()) -> m a -> m ()
forall a b. (a -> b) -> a -> b
$ StepT (Turn a a) m a -> m a
forall (m :: Type -> Type) p a.
Monad m =>
CoroutineT p p m a -> m a
runCoroutine (StepT (Turn a a) m a -> m a) -> StepT (Turn a a) m a -> m a
forall a b. (a -> b) -> a -> b
$ a -> StepT (Turn a a) m a
f a
a)

pickWith ::
       forall m a. Monad m
    => m (a, m ())
    -> With m a
pickWith :: forall (m :: Type -> Type) a. Monad m => m (a, m ()) -> With m a
pickWith m (a, m ())
mac a -> m r
amr = do
    (a
a, m ()
closer) <- m (a, m ())
mac
    r
r <- a -> m r
amr a
a
    m ()
closer
    r -> m r
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return r
r