{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
module Control.Effects.Yield where
import Import
import Control.Effects
import Control.Effects.Signal
import Control.Effects.List
import Control.Effects.Async
import GHC.Generics
import Control.Concurrent.MVar
import Control.Concurrent.Chan
data Yield a
instance Effect (Yield a) where
data EffMethods (Yield a) m = YieldMethods
{ _yield :: a -> m () }
deriving (Generic)
yield :: forall a m. MonadEffect (Yield a) m => a -> m ()
YieldMethods yield = effect
implementYieldViaNonDeterminism ::
forall a m b. MonadEffect NonDeterminism m
=> RuntimeImplemented (Yield a) (RuntimeImplemented (Signal a ()) (ExceptT a m)) b
-> m a
implementYieldViaNonDeterminism m = m
& (>> deadEnd)
& implement (YieldMethods (signal @a))
& handleSignal @a (\a -> do
b <- choose [True, False]
return $ if b then Break a else Resume ())
implementYieldViaMVar ::
forall a m b. (MonadIO m, MonadEffect Async m)
=> RuntimeImplemented (Yield a) m b -> m (m (Maybe a))
implementYieldViaMVar m = do
mv <- liftIO newEmptyMVar
block <- liftIO newEmptyMVar
done <- liftIO $ newMVar False
void $ async $ do
liftIO $ takeMVar block
void $ m & implement (YieldMethods (\a -> liftIO $ do
putMVar mv (Just a)
takeMVar block ))
liftIO $ do
void $ swapMVar done True
void $ tryPutMVar mv Nothing
return $ liftIO $ do
d <- readMVar done
if d then return Nothing
else do
putMVar block ()
takeMVar mv
implementYieldViaChan ::
forall a m b. (MonadIO m, MonadEffect Async m)
=> RuntimeImplemented (Yield a) m b -> m (m (Maybe a))
implementYieldViaChan m = do
ch <- liftIO newChan
done <- liftIO $ newMVar False
void $ async $ do
void $ m & implement (YieldMethods (liftIO . writeChan ch . Just))
liftIO $ writeChan ch Nothing
return $ liftIO $ do
d <- readMVar done
if d then return Nothing
else readChan ch >>= \case
Nothing -> do
void $ swapMVar done True
return Nothing
Just a -> return (Just a)
traverseYielded :: Monad m => m (Maybe a) -> (a -> m b) -> m [b]
traverseYielded m f = m >>= \case
Nothing -> return []
Just a -> do
b <- f a
bs <- traverseYielded m f
return (b : bs)
traverseYielded_ :: Monad m => m (Maybe a) -> (a -> m b) -> m ()
traverseYielded_ m f = m >>= \case
Nothing -> return ()
Just a -> f a >> traverseYielded_ m f