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

module LiveCoding.Cell.NonBlocking
  ( nonBlocking
  )
  where

-- base
import Control.Concurrent
import Control.Monad ((>=>), void, when)
import Data.Data

-- essence-of-live-coding
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 :: forall (m :: * -> *) h. m h -> (h -> m ()) -> Handle m h
Handle
  { create :: IO (MVar ThreadId)
create = IO (MVar ThreadId)
forall a. IO (MVar a)
newEmptyMVar
  , destroy :: MVar ThreadId -> IO ()
destroy = MVar ThreadId -> IO (Maybe ThreadId)
forall a. MVar a -> IO (Maybe a)
tryTakeMVar (MVar ThreadId -> IO (Maybe ThreadId))
-> (Maybe ThreadId -> IO ()) -> MVar ThreadId -> IO ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (ThreadId -> IO ()) -> Maybe ThreadId -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ThreadId -> IO ()
killThread
  }

{- | Wrap a cell in a non-blocking way.
Every incoming sample of @nonBlocking cell@ results in an immediate output,
either @Just b@ if the value was computed since the last poll,
or @Nothing@ if no new value was computed yet.
The resulting cell can be polled by sending 'Nothing'.
The boolean flag controls whether the current computation is aborted and restarted when new data arrives.
-}
nonBlocking
  :: Typeable b
  => Bool
  -- ^ Pass 'True' to abort the computation when new data arrives. 'False' discards new data.
  -> Cell IO a b
  -> Cell (HandlingStateT IO) (Maybe a) (Maybe b)
nonBlocking :: 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 <- Handle IO (MVar ThreadId)
-> Cell (HandlingStateT IO) () (MVar ThreadId)
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 <- Handle IO (MVar (b, s))
-> Cell (HandlingStateT IO) () (MVar (b, s))
forall h (m :: * -> *) arbitrary.
(Typeable h, Monad m) =>
Handle m h -> Cell (HandlingStateT m) arbitrary h
handling Handle IO (MVar (b, s))
forall a. Handle IO (MVar a)
emptyMVarHandle            -< ()
  Cell IO (Maybe a, MVar ThreadId, MVar (b, s)) (Maybe b)
-> Cell
     (HandlingStateT IO) (Maybe a, MVar ThreadId, MVar (b, s)) (Maybe b)
forall (m :: * -> *) (t :: (* -> *) -> * -> *) a b.
(Monad m, MonadTrans t) =>
Cell m a b -> Cell (t m) a b
liftCell Cell :: forall (m :: * -> *) a b s.
Data s =>
s -> (s -> a -> m (b, s)) -> Cell m a b
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 <- MVar (b, s) -> IO (Maybe (b, s))
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 <- MVar ThreadId -> IO ThreadId
forall a. MVar a -> IO a
takeMVar MVar ThreadId
threadVar
            ThreadId -> IO ()
killThread ThreadId
threadId
            (Maybe b, s) -> IO (Maybe b, s)
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> Maybe b
forall a. a -> Maybe a
Just b
b, s
s')
          Maybe (b, s)
Nothing -> (Maybe b, s) -> IO (Maybe b, s)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe b
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
            -- Abort the current computation if it is still running
          then do
            Maybe ThreadId
maybeThreadId <- MVar ThreadId -> IO (Maybe ThreadId)
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar ThreadId
threadVar
            (ThreadId -> IO ()) -> Maybe ThreadId -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ThreadId -> IO ()
killThread Maybe ThreadId
maybeThreadId
            Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
          -- No computation currently running
          else MVar ThreadId -> IO Bool
forall a. MVar a -> IO Bool
isEmptyMVar MVar ThreadId
threadVar
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
noThreadRunning (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          ThreadId
threadId <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ MVar (b, s) -> (b, s) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (b, s)
resultVar ((b, s) -> IO ()) -> IO (b, s) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< s -> a -> IO (b, s)
cellStep s
s a
a
          MVar ThreadId -> ThreadId -> IO ()
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 (Maybe a
forall a. Maybe a
Nothing, MVar ThreadId
threadVar, MVar (b, s)
resultVar)

-- It would have been nice to refactor this with 'hoistCellKleisli',
-- but that would expose the existential state type to the handle.
nonBlocking Bool
abort Cell IO a b
noCell = Bool -> Cell IO a b -> Cell (HandlingStateT IO) (Maybe a) (Maybe b)
forall b a.
Typeable b =>
Bool -> Cell IO a b -> Cell (HandlingStateT IO) (Maybe a) (Maybe b)
nonBlocking Bool
abort (Cell IO a b -> Cell (HandlingStateT IO) (Maybe a) (Maybe b))
-> Cell IO a b -> Cell (HandlingStateT IO) (Maybe a) (Maybe b)
forall a b. (a -> b) -> a -> b
$ Cell IO a b -> Cell IO a b
forall (m :: * -> *) a b. Functor m => Cell m a b -> Cell m a b
toCell Cell IO a b
noCell