module Control.Monad.Ology.General.Coroutine where

import Control.Monad.Ology.General.Trans.Hoist
import Control.Monad.Ology.General.Trans.Trans
import Control.Monad.Ology.General.Trans.Tunnel
import Control.Monad.Ology.General.Trans.Unlift
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 =
        forall (f :: Type -> Type) (m :: Type -> Type) a.
m (Either a (f (StepT f m a))) -> StepT f m a
MkStepT forall a b. (a -> b) -> a -> b
$ do
            MVar q
invar <- forall a. IO (MVar a)
newEmptyMVar
            MVar (Either r (Turn p q (StepT (Turn p q) IO r)))
outvar <- forall a. IO (MVar a)
newEmptyMVar
            ThreadId
_ <-
                IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ do
                    r
r <-
                        (p -> IO q) -> IO r
action forall a b. (a -> b) -> a -> b
$ \p
p -> do
                            forall a. MVar a -> a -> IO ()
putMVar MVar (Either r (Turn p q (StepT (Turn p q) IO r)))
outvar forall a b. (a -> b) -> a -> b
$
                                forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$
                                forall p q a. p -> (q -> a) -> Turn p q a
MkTurn p
p forall a b. (a -> b) -> a -> b
$ \q
q ->
                                    forall (f :: Type -> Type) (m :: Type -> Type) a.
m (Either a (f (StepT f m a))) -> StepT f m a
MkStepT forall a b. (a -> b) -> a -> b
$ do
                                        forall a. MVar a -> a -> IO ()
putMVar MVar q
invar q
q
                                        forall a. MVar a -> IO a
takeMVar MVar (Either r (Turn p q (StepT (Turn p q) IO r)))
outvar
                            forall a. MVar a -> IO a
takeMVar MVar q
invar
                    forall a. MVar a -> a -> IO ()
putMVar MVar (Either r (Turn p q (StepT (Turn p q) IO r)))
outvar forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left r
r
            forall a. MVar a -> IO a
takeMVar MVar (Either r (Turn p q (StepT (Turn p q) IO r)))
outvar

instance (MonadTransUnlift t, MonadCoroutine m, MonadTunnelIO m, Monad (t 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 (f :: Type -> Type) (m :: Type -> Type) a.
m (Either a (f (StepT f m a))) -> StepT f m a
MkStepT forall a b. (a -> b) -> a -> b
$
        forall (t :: TransKind) (m :: Type -> Type) r.
(MonadTransUnlift t, MonadIO m) =>
(Unlift MonadTunnelIO t -> m r) -> t m r
liftWithUnlift forall a b. (a -> b) -> a -> b
$ \Unlift MonadTunnelIO t
unlift ->
            (forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ forall (t :: TransKind) (m1 :: Type -> Type) (m2 :: Type -> Type).
(MonadTransHoist t, Monad m1, Monad m2) =>
(m1 --> m2) -> t m1 --> t m2
hoist forall (t :: TransKind) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift) forall a b. (a -> b) -> a -> b
$ forall (f :: Type -> Type) (m :: Type -> Type) a.
StepT f m a -> m (Either a (f (StepT f m a)))
unStepT forall a b. (a -> b) -> a -> b
$ forall (m :: Type -> Type) p q r.
MonadCoroutine m =>
((p -> m q) -> m r) -> CoroutineT p q m r
coroutineSuspend forall a b. (a -> b) -> a -> b
$ \p -> m q
pmq -> Unlift MonadTunnelIO t
unlift forall a b. (a -> b) -> a -> b
$ (p -> t m q) -> t m r
call forall a b. (a -> b) -> a -> b
$ \p
p -> forall (t :: TransKind) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift 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 <- forall (f :: Type -> Type) (m :: Type -> Type) a.
StepT f m a -> m (Either a (f (StepT f m a)))
unStepT forall a b. (a -> b) -> a -> b
$ forall (m :: Type -> Type) p q r.
MonadCoroutine m =>
((p -> m q) -> m r) -> CoroutineT p q m r
coroutineSuspend With m a
w
    case Either a (Turn a a (StepT (Turn a a) m a))
etp of
        Left a
a -> forall (m :: Type -> Type) a. Monad m => a -> m a
return (a
a, forall (m :: Type -> Type) a. Monad m => a -> m a
return ())
        Right (MkTurn a
a a -> StepT (Turn a a) m a
f) -> forall (m :: Type -> Type) a. Monad m => a -> m a
return (a
a, forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (\a
_ -> ()) forall a b. (a -> b) -> a -> b
$ forall (m :: Type -> Type) p a.
Monad m =>
CoroutineT p p m a -> m a
runCoroutine 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
    forall (m :: Type -> Type) a. Monad m => a -> m a
return r
r