module KMonad.Keyboard.IO
(
KeySink
, mkKeySink
, emitKey
, KeySource
, mkKeySource
, awaitKey
)
where
import KMonad.Prelude
import KMonad.Keyboard.Types
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 :: forall e snk.
HasLogFunc e =>
RIO e snk
-> (snk -> RIO e ())
-> (snk -> KeyEvent -> RIO e ())
-> RIO e (Acquire KeySink)
mkKeySink RIO e snk
o snk -> RIO e ()
c 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 Utf8Builder
"Opening KeySink" RIO e () -> RIO e snk -> RIO e snk
forall a b. RIO e a -> RIO e b -> RIO e b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RIO e snk
o
let close :: snk -> IO ()
close 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 Utf8Builder
"Closing KeySink" RIO e () -> RIO e () -> RIO e ()
forall a b. RIO e a -> RIO e b -> RIO e b
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 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 Text
"Encountered error in KeySink"
Acquire KeySink -> RIO e (Acquire KeySink)
forall a. a -> RIO e a
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 :: forall e. HasLogFunc e => KeySink -> KeyEvent -> RIO e ()
emitKey KeySink
snk 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
$ Utf8Builder
"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 a. IO a -> RIO e a
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 :: forall e src.
HasLogFunc e =>
RIO e src
-> (src -> RIO e ())
-> (src -> RIO e KeyEvent)
-> RIO e (Acquire KeySource)
mkKeySource RIO e src
o src -> RIO e ()
c 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 Utf8Builder
"Opening KeySource" RIO e () -> RIO e src -> RIO e src
forall a b. RIO e a -> RIO e b -> RIO e b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RIO e src
o
let close :: src -> IO ()
close 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 Utf8Builder
"Closing KeySource" RIO e () -> RIO e () -> RIO e ()
forall a b. RIO e a -> RIO e b -> RIO e b
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 = 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 Text
"Encountered error in KeySource"
Acquire KeySource -> RIO e (Acquire KeySource)
forall a. a -> RIO e a
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 :: forall e. HasLogFunc e => KeySource -> RIO e KeyEvent
awaitKey KeySource
src = do
KeyEvent
e <- IO KeyEvent -> RIO e KeyEvent
forall a. IO a -> RIO e a
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
$ Utf8Builder
"\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 Int
80 Text
"-")
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\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 a. a -> RIO e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure KeyEvent
e