{-# LANGUAGE Arrows #-}
{-# LANGUAGE RecordWildCards #-}

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