{- |
Utilities for integrating live programs into external loops, using 'IO' concurrency.
The basic idea is two wormholes (see Winograd-Court's thesis).
-}

{-# LANGUAGE Arrows #-}
{-# LANGUAGE RecordWildCards #-}
module LiveCoding.External where

-- base
import Control.Arrow
import Control.Concurrent
import Control.Monad.IO.Class

-- transformers
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Writer.Strict

-- essence-of-live-coding
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 :: 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  <- IO (MVar eIn)
forall a. IO (MVar a)
newEmptyMVar
  MVar eOut
outVar <- IO (MVar eOut)
forall a. IO (MVar a)
newEmptyMVar
  let
    cell :: Cell m a b
cell = proc a
a -> do
      eIn
eIn       <- m eIn -> Cell m () eIn
forall (m :: * -> *) b a. m b -> Cell m a b
constM (IO eIn -> m eIn
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO eIn -> m eIn) -> IO eIn -> m eIn
forall a b. (a -> b) -> a -> b
$ MVar eIn -> IO eIn
forall a. MVar a -> IO a
takeMVar MVar eIn
inVar)      -< ()
      (eOut
eOut, b
b) <- Cell (WriterT eOut m) (eIn, a) b -> Cell m (eIn, a) (eOut, b)
forall w (m :: * -> *) a b.
(Monoid w, Monad m) =>
Cell (WriterT w m) a b -> Cell m a (w, b)
runWriterC (ExternalCell m eIn eOut a b -> Cell (WriterT eOut m) (eIn, a) b
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)
      (eOut -> m ()) -> Cell m eOut ()
forall a (m :: * -> *) b. (a -> m b) -> Cell m a b
arrM (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (eOut -> IO ()) -> eOut -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar eOut -> eOut -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar eOut
outVar)                     -< eOut
eOut
      Cell m b b
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA                                            -< b
b
    externalLoop :: ExternalLoop eIn eOut
externalLoop = (eIn -> IO ()) -> Cell IO eIn ()
forall a (m :: * -> *) b. (a -> m b) -> Cell m a b
arrM (MVar eIn -> eIn -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar eIn
inVar) Cell IO eIn () -> Cell IO () eOut -> ExternalLoop eIn eOut
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> IO eOut -> Cell IO () eOut
forall (m :: * -> *) b a. m b -> Cell m a b
constM (MVar eOut -> IO eOut
forall a. MVar a -> IO a
takeMVar MVar eOut
outVar)
  (Cell m a b, ExternalLoop eIn eOut)
-> IO (Cell m a b, ExternalLoop eIn eOut)
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 :: Cell IO a b -> IO (CellHandle a b)
makeHandle = Cell IO a b -> IO (CellHandle a b)
forall a. a -> IO (MVar a)
newMVar

stepHandle :: CellHandle a b -> a -> IO b
stepHandle :: CellHandle a b -> a -> IO b
stepHandle CellHandle a b
handle a
a = CellHandle a b -> (Cell IO a b -> IO (Cell IO a b, b)) -> IO b
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar CellHandle a b
handle ((Cell IO a b -> IO (Cell IO a b, b)) -> IO b)
-> (Cell IO a b -> IO (Cell IO a b, b)) -> IO b
forall a b. (a -> b) -> a -> b
$ \Cell IO a b
cell -> do
  (b
b, Cell IO a b
cell') <- Cell IO a b -> a -> IO (b, Cell IO a b)
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
  (Cell IO a b, b) -> IO (Cell IO a b, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Cell IO a b
cell', b
b)