module KMonad.App.Dispatch
(
Dispatch
, mkDispatch
, 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
data Dispatch = Dispatch
{ Dispatch -> IO KeyEvent
_eventSrc :: IO KeyEvent
, Dispatch -> TMVar (Async KeyEvent)
_readProc :: TMVar (Async KeyEvent)
, Dispatch -> TVar (Seq KeyEvent)
_rerunBuf :: TVar (Seq KeyEvent)
}
makeLenses ''Dispatch
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
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'
pull :: (HasLogFunc e) => Dispatch -> RIO e KeyEvent
pull :: Dispatch -> RIO e KeyEvent
pull d :: Dispatch
d = do
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'
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
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
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
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)