{-# LANGUAGE DeriveAnyClass #-}
module KMonad.Keyboard.IO
(
KeySink
, mkKeySink
, emitKey
, KeySource
, mkKeySource
, awaitKey
)
where
import KMonad.Prelude
import KMonad.Keyboard
import KMonad.Util
import qualified RIO.Text as T
newtype KeySink = KeySink { KeySink -> KeyEvent -> IO ()
emitKeyWith :: KeyEvent -> IO () }
mkKeySink :: HasLogFunc e
=> RIO e snk
-> (snk -> RIO e ())
-> (snk -> KeyEvent -> RIO e ())
-> RIO e (Acquire KeySink)
mkKeySink :: RIO e snk
-> (snk -> RIO e ())
-> (snk -> KeyEvent -> RIO e ())
-> RIO e (Acquire KeySink)
mkKeySink o :: RIO e snk
o c :: snk -> RIO e ()
c w :: snk -> KeyEvent -> RIO e ()
w = do
UnliftIO (RIO e)
u <- RIO e (UnliftIO (RIO e))
forall (m :: * -> *). MonadUnliftIO m => m (UnliftIO m)
askUnliftIO
let open :: IO snk
open = UnliftIO (RIO e) -> forall a. RIO e a -> IO a
forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO (RIO e)
u (RIO e snk -> IO snk) -> RIO e snk -> IO snk
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> RIO e ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo "Opening KeySink" RIO e () -> RIO e snk -> RIO e snk
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RIO e snk
o
let close :: snk -> IO ()
close snk :: snk
snk = UnliftIO (RIO e) -> forall a. RIO e a -> IO a
forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO (RIO e)
u (RIO e () -> IO ()) -> RIO e () -> IO ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> RIO e ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo "Closing KeySink" RIO e () -> RIO e () -> RIO e ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> snk -> RIO e ()
c snk
snk
let write :: snk -> KeyEvent -> IO ()
write snk :: snk
snk a :: KeyEvent
a = UnliftIO (RIO e) -> forall a. RIO e a -> IO a
forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO (RIO e)
u (RIO e () -> IO ()) -> RIO e () -> IO ()
forall a b. (a -> b) -> a -> b
$ snk -> KeyEvent -> RIO e ()
w snk
snk KeyEvent
a
RIO e () -> (SomeException -> RIO e ()) -> RIO e ()
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` Text -> SomeException -> RIO e ()
forall e a. HasLogFunc e => Text -> SomeException -> RIO e a
logRethrow "Encountered error in KeySink"
Acquire KeySink -> RIO e (Acquire KeySink)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Acquire KeySink -> RIO e (Acquire KeySink))
-> Acquire KeySink -> RIO e (Acquire KeySink)
forall a b. (a -> b) -> a -> b
$ (KeyEvent -> IO ()) -> KeySink
KeySink ((KeyEvent -> IO ()) -> KeySink)
-> (snk -> KeyEvent -> IO ()) -> snk -> KeySink
forall b c a. (b -> c) -> (a -> b) -> a -> c
. snk -> KeyEvent -> IO ()
write (snk -> KeySink) -> Acquire snk -> Acquire KeySink
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO snk -> (snk -> IO ()) -> Acquire snk
forall a. IO a -> (a -> IO ()) -> Acquire a
mkAcquire IO snk
open snk -> IO ()
close
emitKey :: (HasLogFunc e) => KeySink -> KeyEvent -> RIO e ()
emitKey :: KeySink -> KeyEvent -> RIO e ()
emitKey snk :: KeySink
snk 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
$ "Emitting: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> KeyEvent -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display KeyEvent
e
IO () -> RIO e ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO e ()) -> IO () -> RIO e ()
forall a b. (a -> b) -> a -> b
$ KeySink -> KeyEvent -> IO ()
emitKeyWith KeySink
snk KeyEvent
e
newtype KeySource = KeySource { KeySource -> IO KeyEvent
awaitKeyWith :: IO KeyEvent}
mkKeySource :: HasLogFunc e
=> RIO e src
-> (src -> RIO e ())
-> (src -> RIO e KeyEvent)
-> RIO e (Acquire KeySource)
mkKeySource :: RIO e src
-> (src -> RIO e ())
-> (src -> RIO e KeyEvent)
-> RIO e (Acquire KeySource)
mkKeySource o :: RIO e src
o c :: src -> RIO e ()
c r :: src -> RIO e KeyEvent
r = do
UnliftIO (RIO e)
u <- RIO e (UnliftIO (RIO e))
forall (m :: * -> *). MonadUnliftIO m => m (UnliftIO m)
askUnliftIO
let open :: IO src
open = UnliftIO (RIO e) -> forall a. RIO e a -> IO a
forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO (RIO e)
u (RIO e src -> IO src) -> RIO e src -> IO src
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> RIO e ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo "Opening KeySource" RIO e () -> RIO e src -> RIO e src
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RIO e src
o
let close :: src -> IO ()
close src :: src
src = UnliftIO (RIO e) -> forall a. RIO e a -> IO a
forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO (RIO e)
u (RIO e () -> IO ()) -> RIO e () -> IO ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> RIO e ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo "Closing KeySource" RIO e () -> RIO e () -> RIO e ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> src -> RIO e ()
c src
src
let read :: src -> IO KeyEvent
read src :: src
src = UnliftIO (RIO e) -> forall a. RIO e a -> IO a
forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO (RIO e)
u (RIO e KeyEvent -> IO KeyEvent) -> RIO e KeyEvent -> IO KeyEvent
forall a b. (a -> b) -> a -> b
$ src -> RIO e KeyEvent
r src
src
RIO e KeyEvent
-> (SomeException -> RIO e KeyEvent) -> RIO e KeyEvent
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` Text -> SomeException -> RIO e KeyEvent
forall e a. HasLogFunc e => Text -> SomeException -> RIO e a
logRethrow "Encountered error in KeySource"
Acquire KeySource -> RIO e (Acquire KeySource)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Acquire KeySource -> RIO e (Acquire KeySource))
-> Acquire KeySource -> RIO e (Acquire KeySource)
forall a b. (a -> b) -> a -> b
$ IO KeyEvent -> KeySource
KeySource (IO KeyEvent -> KeySource)
-> (src -> IO KeyEvent) -> src -> KeySource
forall b c a. (b -> c) -> (a -> b) -> a -> c
. src -> IO KeyEvent
read (src -> KeySource) -> Acquire src -> Acquire KeySource
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO src -> (src -> IO ()) -> Acquire src
forall a. IO a -> (a -> IO ()) -> Acquire a
mkAcquire IO src
open src -> IO ()
close
awaitKey :: (HasLogFunc e) => KeySource -> RIO e KeyEvent
awaitKey :: KeySource -> RIO e KeyEvent
awaitKey src :: KeySource
src = do
KeyEvent
e <- IO KeyEvent -> RIO e KeyEvent
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO KeyEvent -> RIO e KeyEvent)
-> (KeySource -> IO KeyEvent) -> KeySource -> RIO e KeyEvent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeySource -> IO KeyEvent
awaitKeyWith (KeySource -> RIO e KeyEvent) -> KeySource -> RIO e KeyEvent
forall a b. (a -> b) -> a -> b
$ KeySource
src
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
<> "\nReceived event: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> KeyEvent -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display KeyEvent
e
KeyEvent -> RIO e KeyEvent
forall (f :: * -> *) a. Applicative f => a -> f a
pure KeyEvent
e