{-|
Module      : KMonad.App.Dispatch
Description : Component for async reading.
Copyright   : (c) David Janssen, 2019
License     : MIT
Maintainer  : janssen.dhj@gmail.com
Stability   : experimental
Portability : portable

The 'Dispatch' component of the app-loop solves the following problem: we might
at some point during execution be in the following situation:
- We have set our processing to held
- There is a timer running that might unhold at any point
- We are awaiting a key from the OS

This means we need to be able to:
1. Await events from some kind of rerun buffer
2. Await events from the OS
3. Do both of these things without ever entering a race-condition where we lose
   an event because both 1. and 2. happen at exactly the same time.

The Dispatch component provides the ability to read events from some IO action
while at the same time providing a method to write events into the Dispatch,
sending them to the head of the read-queue, while guaranteeing that no events
ever get lost.

In the sequencing of components, the 'Dispatch' occurs first, which means that
it reads directly from the KeySource. Any component after the 'Dispatch' need
not worry about wether an event is being rerun or not, it simply treats all
events as equal.

-}
module KMonad.App.Dispatch
  ( -- $env
    Dispatch
  , mkDispatch

    -- $op
  , pull
  , rerun
  )
where

import KMonad.Prelude
import KMonad.Keyboard

import RIO.Seq (Seq(..), (><))
import qualified RIO.Seq  as Seq
import qualified RIO.Text as T

--------------------------------------------------------------------------------
-- $env
--
-- The 'Dispatch' environment, describing what values are required to perform
-- the Dispatch operations, and constructors for creating such an environment.

-- | The 'Dispatch' environment
data Dispatch = Dispatch
  { Dispatch -> IO KeyEvent
_eventSrc :: IO KeyEvent            -- ^ How to read 1 event
  , Dispatch -> TMVar (Async KeyEvent)
_readProc :: TMVar (Async KeyEvent) -- ^ Store for reading process
  , Dispatch -> TVar (Seq KeyEvent)
_rerunBuf :: TVar (Seq KeyEvent)    -- ^ Buffer for rerunning events
  }
makeLenses ''Dispatch

-- | Create a new 'Dispatch' environment
mkDispatch' :: MonadUnliftIO m => m KeyEvent -> m Dispatch
mkDispatch' :: m KeyEvent -> m Dispatch
mkDispatch' s :: m KeyEvent
s = ((forall a. m a -> IO a) -> IO Dispatch) -> m Dispatch
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO Dispatch) -> m Dispatch)
-> ((forall a. m a -> IO a) -> IO Dispatch) -> m Dispatch
forall a b. (a -> b) -> a -> b
$ \u :: forall a. m a -> IO a
u -> do
  TMVar (Async KeyEvent)
rpc <- STM (TMVar (Async KeyEvent)) -> IO (TMVar (Async KeyEvent))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (TMVar (Async KeyEvent)) -> IO (TMVar (Async KeyEvent)))
-> STM (TMVar (Async KeyEvent)) -> IO (TMVar (Async KeyEvent))
forall a b. (a -> b) -> a -> b
$ STM (TMVar (Async KeyEvent))
forall a. STM (TMVar a)
newEmptyTMVar
  TVar (Seq KeyEvent)
rrb <- STM (TVar (Seq KeyEvent)) -> IO (TVar (Seq KeyEvent))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (TVar (Seq KeyEvent)) -> IO (TVar (Seq KeyEvent)))
-> STM (TVar (Seq KeyEvent)) -> IO (TVar (Seq KeyEvent))
forall a b. (a -> b) -> a -> b
$ Seq KeyEvent -> STM (TVar (Seq KeyEvent))
forall a. a -> STM (TVar a)
newTVar Seq KeyEvent
forall a. Seq a
Seq.empty
  Dispatch -> IO Dispatch
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dispatch -> IO Dispatch) -> Dispatch -> IO Dispatch
forall a b. (a -> b) -> a -> b
$ IO KeyEvent
-> TMVar (Async KeyEvent) -> TVar (Seq KeyEvent) -> Dispatch
Dispatch (m KeyEvent -> IO KeyEvent
forall a. m a -> IO a
u m KeyEvent
s) TMVar (Async KeyEvent)
rpc TVar (Seq KeyEvent)
rrb

-- | Create a new 'Dispatch' environment in a 'ContT' environment
mkDispatch :: MonadUnliftIO m => m KeyEvent -> ContT r m Dispatch
mkDispatch :: m KeyEvent -> ContT r m Dispatch
mkDispatch = m Dispatch -> ContT r m Dispatch
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Dispatch -> ContT r m Dispatch)
-> (m KeyEvent -> m Dispatch) -> m KeyEvent -> ContT r m Dispatch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m KeyEvent -> m Dispatch
forall (m :: * -> *). MonadUnliftIO m => m KeyEvent -> m Dispatch
mkDispatch'

--------------------------------------------------------------------------------
-- $op
--
-- The supported 'Dispatch' operations.

-- | Return the next event, this will return either (in order of precedence):
-- 1. The next item to be rerun
-- 2. A new item read from the OS
-- 3. Pausing until either 1. or 2. triggers
pull :: (HasLogFunc e) => Dispatch -> RIO e KeyEvent
pull :: Dispatch -> RIO e KeyEvent
pull d :: Dispatch
d = do
  -- Check for an unfinished read attempt started previously. If it exists,
  -- fetch it, otherwise, start a new read attempt.
  Async KeyEvent
a <- STM (Maybe (Async KeyEvent)) -> RIO e (Maybe (Async KeyEvent))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TMVar (Async KeyEvent) -> STM (Maybe (Async KeyEvent))
forall a. TMVar a -> STM (Maybe a)
tryTakeTMVar (TMVar (Async KeyEvent) -> STM (Maybe (Async KeyEvent)))
-> TMVar (Async KeyEvent) -> STM (Maybe (Async KeyEvent))
forall a b. (a -> b) -> a -> b
$ Dispatch
dDispatch
-> Getting
     (TMVar (Async KeyEvent)) Dispatch (TMVar (Async KeyEvent))
-> TMVar (Async KeyEvent)
forall s a. s -> Getting a s a -> a
^.Getting (TMVar (Async KeyEvent)) Dispatch (TMVar (Async KeyEvent))
Lens' Dispatch (TMVar (Async KeyEvent))
readProc) RIO e (Maybe (Async KeyEvent))
-> (Maybe (Async KeyEvent) -> RIO e (Async KeyEvent))
-> RIO e (Async KeyEvent)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Nothing -> RIO e KeyEvent -> RIO e (Async KeyEvent)
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (RIO e KeyEvent -> RIO e (Async KeyEvent))
-> (IO KeyEvent -> RIO e KeyEvent)
-> IO KeyEvent
-> RIO e (Async KeyEvent)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO KeyEvent -> RIO e KeyEvent
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO KeyEvent -> RIO e (Async KeyEvent))
-> IO KeyEvent -> RIO e (Async KeyEvent)
forall a b. (a -> b) -> a -> b
$ Dispatch
dDispatch
-> Getting (IO KeyEvent) Dispatch (IO KeyEvent) -> IO KeyEvent
forall s a. s -> Getting a s a -> a
^.Getting (IO KeyEvent) Dispatch (IO KeyEvent)
Lens' Dispatch (IO KeyEvent)
eventSrc
    Just a' :: Async KeyEvent
a' -> Async KeyEvent -> RIO e (Async KeyEvent)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Async KeyEvent
a'

  -- First try reading from the rerunBuf, or failing that, from the
  -- read-process. If both fail we enter an STM race.
  STM (Either KeyEvent KeyEvent) -> RIO e (Either KeyEvent KeyEvent)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically ((KeyEvent -> Either KeyEvent KeyEvent
forall a b. a -> Either a b
Left (KeyEvent -> Either KeyEvent KeyEvent)
-> STM KeyEvent -> STM (Either KeyEvent KeyEvent)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM KeyEvent
popRerun) STM (Either KeyEvent KeyEvent)
-> STM (Either KeyEvent KeyEvent) -> STM (Either KeyEvent KeyEvent)
forall a. STM a -> STM a -> STM a
`orElse` (KeyEvent -> Either KeyEvent KeyEvent
forall a b. b -> Either a b
Right (KeyEvent -> Either KeyEvent KeyEvent)
-> STM KeyEvent -> STM (Either KeyEvent KeyEvent)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Async KeyEvent -> STM KeyEvent
forall a. Async a -> STM a
waitSTM Async KeyEvent
a)) RIO e (Either KeyEvent KeyEvent)
-> (Either KeyEvent KeyEvent -> RIO e KeyEvent) -> RIO e KeyEvent
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    -- If we take from the rerunBuf, put the running read-process back in place
    Left e' :: KeyEvent
e' -> do
      Utf8Builder -> RIO e ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO e ()) -> Utf8Builder -> RIO e ()
forall a b. (a -> b) -> a -> b
$ "\n" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (Int -> Text -> Text
T.replicate 80 "-")
              Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> "\nRerunning event: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> KeyEvent -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display KeyEvent
e'
      STM () -> RIO e ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> RIO e ()) -> STM () -> RIO e ()
forall a b. (a -> b) -> a -> b
$ TMVar (Async KeyEvent) -> Async KeyEvent -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar (Dispatch
dDispatch
-> Getting
     (TMVar (Async KeyEvent)) Dispatch (TMVar (Async KeyEvent))
-> TMVar (Async KeyEvent)
forall s a. s -> Getting a s a -> a
^.Getting (TMVar (Async KeyEvent)) Dispatch (TMVar (Async KeyEvent))
Lens' Dispatch (TMVar (Async KeyEvent))
readProc) Async KeyEvent
a
      KeyEvent -> RIO e KeyEvent
forall (f :: * -> *) a. Applicative f => a -> f a
pure KeyEvent
e'
    Right e' :: KeyEvent
e' -> KeyEvent -> RIO e KeyEvent
forall (f :: * -> *) a. Applicative f => a -> f a
pure KeyEvent
e'

  where
    -- Pop the head off the rerun-buffer (or 'retrySTM' if empty)
    popRerun :: STM KeyEvent
popRerun = TVar (Seq KeyEvent) -> STM (Seq KeyEvent)
forall a. TVar a -> STM a
readTVar (Dispatch
dDispatch
-> Getting (TVar (Seq KeyEvent)) Dispatch (TVar (Seq KeyEvent))
-> TVar (Seq KeyEvent)
forall s a. s -> Getting a s a -> a
^.Getting (TVar (Seq KeyEvent)) Dispatch (TVar (Seq KeyEvent))
Lens' Dispatch (TVar (Seq KeyEvent))
rerunBuf) STM (Seq KeyEvent)
-> (Seq KeyEvent -> STM KeyEvent) -> STM KeyEvent
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Seq.Empty -> STM KeyEvent
forall a. STM a
retrySTM
      (e :: KeyEvent
e :<| b :: Seq KeyEvent
b) -> do
        TVar (Seq KeyEvent) -> Seq KeyEvent -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (Dispatch
dDispatch
-> Getting (TVar (Seq KeyEvent)) Dispatch (TVar (Seq KeyEvent))
-> TVar (Seq KeyEvent)
forall s a. s -> Getting a s a -> a
^.Getting (TVar (Seq KeyEvent)) Dispatch (TVar (Seq KeyEvent))
Lens' Dispatch (TVar (Seq KeyEvent))
rerunBuf) Seq KeyEvent
b
        KeyEvent -> STM KeyEvent
forall (f :: * -> *) a. Applicative f => a -> f a
pure KeyEvent
e

-- | Add a list of elements to be rerun.
rerun :: (HasLogFunc e) => Dispatch -> [KeyEvent] -> RIO e ()
rerun :: Dispatch -> [KeyEvent] -> RIO e ()
rerun d :: Dispatch
d es :: [KeyEvent]
es = STM () -> RIO e ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> RIO e ()) -> STM () -> RIO e ()
forall a b. (a -> b) -> a -> b
$ TVar (Seq KeyEvent) -> (Seq KeyEvent -> Seq KeyEvent) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar (Dispatch
dDispatch
-> Getting (TVar (Seq KeyEvent)) Dispatch (TVar (Seq KeyEvent))
-> TVar (Seq KeyEvent)
forall s a. s -> Getting a s a -> a
^.Getting (TVar (Seq KeyEvent)) Dispatch (TVar (Seq KeyEvent))
Lens' Dispatch (TVar (Seq KeyEvent))
rerunBuf) (Seq KeyEvent -> Seq KeyEvent -> Seq KeyEvent
forall a. Seq a -> Seq a -> Seq a
>< [KeyEvent] -> Seq KeyEvent
forall a. [a] -> Seq a
Seq.fromList [KeyEvent]
es)