{-# LANGUAGE Arrows #-}
{-# LANGUAGE RecordWildCards #-}
module LiveCoding.External where
import Control.Arrow
import Control.Concurrent
import Control.Monad.IO.Class
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Writer.Strict
import LiveCoding.Cell
import LiveCoding.Cell.Monad.Trans
import LiveCoding.Exceptions
type ExternalCell m eIn eOut a b = Cell (ReaderT eIn (WriterT eOut m)) a b
type ExternalLoop eIn eOut = Cell IO eIn eOut
concurrently :: (MonadIO m, Monoid eOut) => ExternalCell m eIn eOut a b -> IO (Cell m a b, ExternalLoop eIn eOut)
concurrently :: forall (m :: * -> *) eOut eIn a b.
(MonadIO m, Monoid eOut) =>
ExternalCell m eIn eOut a b
-> IO (Cell m a b, ExternalLoop eIn eOut)
concurrently ExternalCell m eIn eOut a b
externalCell = do
MVar eIn
inVar <- forall a. IO (MVar a)
newEmptyMVar
MVar eOut
outVar <- forall a. IO (MVar a)
newEmptyMVar
let
cell :: Cell m a b
cell = proc a
a -> do
eIn
eIn <- forall (m :: * -> *) b a. m b -> Cell m a b
constM (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
takeMVar MVar eIn
inVar) -< ()
(eOut
eOut, b
b) <- forall w (m :: * -> *) a b.
(Monoid w, Monad m) =>
Cell (WriterT w m) a b -> Cell m a (w, b)
runWriterC (forall (m :: * -> *) r a b.
Monad m =>
Cell (ReaderT r m) a b -> Cell m (r, a) b
runReaderC' ExternalCell m eIn eOut a b
externalCell) -< (eIn
eIn, a
a)
forall a (m :: * -> *) b. (a -> m b) -> Cell m a b
arrM (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. MVar a -> a -> IO ()
putMVar MVar eOut
outVar) -< eOut
eOut
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< b
b
externalLoop :: ExternalLoop eIn eOut
externalLoop = forall a (m :: * -> *) b. (a -> m b) -> Cell m a b
arrM (forall a. MVar a -> a -> IO ()
putMVar MVar eIn
inVar) forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (m :: * -> *) b a. m b -> Cell m a b
constM (forall a. MVar a -> IO a
takeMVar MVar eOut
outVar)
forall (m :: * -> *) a. Monad m => a -> m a
return (Cell m a b
cell, ExternalLoop eIn eOut
externalLoop)
type CellHandle a b = MVar (Cell IO a b)
makeHandle :: Cell IO a b -> IO (CellHandle a b)
makeHandle :: forall a b. Cell IO a b -> IO (CellHandle a b)
makeHandle = forall a. a -> IO (MVar a)
newMVar
stepHandle :: CellHandle a b -> a -> IO b
stepHandle :: forall a b. CellHandle a b -> a -> IO b
stepHandle CellHandle a b
handle a
a = forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar CellHandle a b
handle forall a b. (a -> b) -> a -> b
$ \Cell IO a b
cell -> do
(b
b, Cell IO a b
cell') <- forall (m :: * -> *) a b.
Monad m =>
Cell m a b -> a -> m (b, Cell m a b)
step Cell IO a b
cell a
a
forall (m :: * -> *) a. Monad m => a -> m a
return (Cell IO a b
cell', b
b)