{-# 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
    { 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
    }

{- | 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 =>
  -- | Pass 'True' to abort the computation when new data arrives. 'False' discards new data.
  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 -- Abort the current computation if it is still running
          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 -- No computation currently running
            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)

-- 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 = 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