{-# LANGUAGE Arrows #-}
{-# LANGUAGE RecordWildCards #-}
module LiveCoding.Cell.NonBlocking (
nonBlocking,
)
where
import Control.Concurrent
import Control.Monad (void, when, (>=>))
import Data.Data
import LiveCoding.Cell
import LiveCoding.Handle
import LiveCoding.Handle.Examples
import LiveCoding.HandlingState
threadVarHandle :: Handle IO (MVar ThreadId)
threadVarHandle :: Handle IO (MVar ThreadId)
threadVarHandle =
Handle
{ create :: IO (MVar ThreadId)
create = forall a. IO (MVar a)
newEmptyMVar
, destroy :: MVar ThreadId -> IO ()
destroy = forall a. MVar a -> IO (Maybe a)
tryTakeMVar forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ThreadId -> IO ()
killThread
}
nonBlocking ::
Typeable b =>
Bool ->
Cell IO a b ->
Cell (HandlingStateT IO) (Maybe a) (Maybe b)
nonBlocking :: forall b a.
Typeable b =>
Bool -> Cell IO a b -> Cell (HandlingStateT IO) (Maybe a) (Maybe b)
nonBlocking Bool
abort Cell {s
s -> a -> IO (b, s)
cellStep :: ()
cellState :: ()
cellStep :: s -> a -> IO (b, s)
cellState :: s
..} = proc Maybe a
aMaybe -> do
MVar ThreadId
threadVar <- forall h (m :: * -> *) arbitrary.
(Typeable h, Monad m) =>
Handle m h -> Cell (HandlingStateT m) arbitrary h
handling Handle IO (MVar ThreadId)
threadVarHandle -< ()
MVar (b, s)
resultVar <- forall h (m :: * -> *) arbitrary.
(Typeable h, Monad m) =>
Handle m h -> Cell (HandlingStateT m) arbitrary h
handling forall a. Handle IO (MVar a)
emptyMVarHandle -< ()
forall (m :: * -> *) (t :: (* -> *) -> * -> *) a b.
(Monad m, MonadTrans t) =>
Cell m a b -> Cell (t m) a b
liftCell Cell {cellStep :: s -> (Maybe a, MVar ThreadId, MVar (b, s)) -> IO (Maybe b, s)
cellStep = s -> (Maybe a, MVar ThreadId, MVar (b, s)) -> IO (Maybe b, s)
nonBlockingStep, s
cellState :: s
cellState :: s
..} -< (Maybe a
aMaybe, MVar ThreadId
threadVar, MVar (b, s)
resultVar)
where
nonBlockingStep :: s -> (Maybe a, MVar ThreadId, MVar (b, s)) -> IO (Maybe b, s)
nonBlockingStep s
s (Maybe a
Nothing, MVar ThreadId
threadVar, MVar (b, s)
resultVar) = do
Maybe (b, s)
bsMaybe <- forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar (b, s)
resultVar
case Maybe (b, s)
bsMaybe of
Just (b
b, s
s') -> do
ThreadId
threadId <- forall a. MVar a -> IO a
takeMVar MVar ThreadId
threadVar
ThreadId -> IO ()
killThread ThreadId
threadId
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just b
b, s
s')
Maybe (b, s)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, s
s)
nonBlockingStep s
s (Just a
a, MVar ThreadId
threadVar, MVar (b, s)
resultVar) = do
Bool
noThreadRunning <-
if Bool
abort
then
do
Maybe ThreadId
maybeThreadId <- forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar ThreadId
threadVar
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ThreadId -> IO ()
killThread Maybe ThreadId
maybeThreadId
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else
forall a. MVar a -> IO Bool
isEmptyMVar MVar ThreadId
threadVar
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
noThreadRunning forall a b. (a -> b) -> a -> b
$ do
ThreadId
threadId <- IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO ()
putMVar MVar (b, s)
resultVar forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< s -> a -> IO (b, s)
cellStep s
s a
a
forall a. MVar a -> a -> IO ()
putMVar MVar ThreadId
threadVar ThreadId
threadId
s -> (Maybe a, MVar ThreadId, MVar (b, s)) -> IO (Maybe b, s)
nonBlockingStep s
s (forall a. Maybe a
Nothing, MVar ThreadId
threadVar, MVar (b, s)
resultVar)
nonBlocking Bool
abort Cell IO a b
noCell = forall b a.
Typeable b =>
Bool -> Cell IO a b -> Cell (HandlingStateT IO) (Maybe a) (Maybe b)
nonBlocking Bool
abort forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b. Functor m => Cell m a b -> Cell m a b
toCell Cell IO a b
noCell