content: {-# 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
      { create = newEmptyMVar
      , destroy = tryTakeMVar >=> mapM_ 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 abort Cell {..} = proc aMaybe -> do
    threadVar <- handling threadVarHandle -< ()
    resultVar <- handling emptyMVarHandle -< ()
    liftCell Cell {cellStep = nonBlockingStep, ..} -< (aMaybe, threadVar, resultVar)
    where
      nonBlockingStep s (Nothing, threadVar, resultVar) = do
        bsMaybe <- tryTakeMVar resultVar
        case bsMaybe of
          Just (b, s') -> do
            threadId <- takeMVar threadVar
            killThread threadId
            return (Just b, s')
          Nothing -> return (Nothing, s)
      nonBlockingStep s (Just a, threadVar, resultVar) = do
        noThreadRunning <-
          if abort
            then -- Abort the current computation if it is still running
              do
                maybeThreadId <- tryTakeMVar threadVar
                mapM_ killThread maybeThreadId
                return True
            else -- No computation currently running
              isEmptyMVar threadVar
        when noThreadRunning $ do
          threadId <- forkIO $ putMVar resultVar =<< cellStep s a
          putMVar threadVar threadId
        nonBlockingStep s (Nothing, threadVar, resultVar)
  
  -- It would have been nice to refactor this with 'hoistCellKleisli',
  -- but that would expose the existential state type to the handle.
  nonBlocking abort noCell = nonBlocking abort $ toCell noCell
  