{-|
Module      : KMonad.Keyboard.IO
Description : The logic behind sending and receiving key events to the OS
Copyright   : (c) David Janssen, 2019
License     : MIT

Maintainer  : janssen.dhj@gmail.com
Stability   : experimental
Portability : non-portable (MPTC with FD, FFI to Linux-only c-code)

-}
module KMonad.Keyboard.IO
  ( -- * KeySink: send keyboard events to the OS
    -- $snk
    KeySink
  , mkKeySink
  , emitKey

    -- * KeySource: read keyboard events from the OS
  , KeySource
  , mkKeySource
  , awaitKey
  )
where

import KMonad.Prelude

import KMonad.Keyboard.Types
import KMonad.Util

import qualified RIO.Text as T

--------------------------------------------------------------------------------
-- $snk

-- | A 'KeySink' sends key actions to the OS
newtype KeySink = KeySink { KeySink -> KeyEvent -> IO ()
emitKeyWith :: KeyEvent -> IO () }

-- | Create a new 'KeySink'
mkKeySink :: HasLogFunc e
  => RIO e snk                      -- ^ Action to acquire the keysink
  -> (snk -> RIO e ())              -- ^ Action to close the keysink
  -> (snk -> KeyEvent -> RIO e ()) -- ^ Action to write with the keysink
  -> 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
  u     <- RIO e (UnliftIO (RIO e))
forall (m :: * -> *). MonadUnliftIO m => m (UnliftIO m)
askUnliftIO
  let 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
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
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"
  pure $ KeySink . write <$> mkAcquire open close

-- | Emit a key to the OS
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


--------------------------------------------------------------------------------
-- $src

-- | A 'KeySource' is an action that awaits 'KeyEvent's from the OS
newtype KeySource = KeySource { KeySource -> IO KeyEvent
awaitKeyWith :: IO KeyEvent}

-- | Create a new KeySource
mkKeySource :: HasLogFunc e
  => RIO e src               -- ^ Action to acquire the keysource
  -> (src -> RIO e ())       -- ^ Action to close the keysource
  -> (src -> RIO e KeyEvent) -- ^ Action to write with the keysource
  -> 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
  u <- RIO e (UnliftIO (RIO e))
forall (m :: * -> *). MonadUnliftIO m => m (UnliftIO m)
askUnliftIO
  let 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
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
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"
  pure $ KeySource . read <$> mkAcquire open close

-- | Wait for the next key from the OS
awaitKey :: (HasLogFunc e) => KeySource -> RIO e KeyEvent
awaitKey :: forall e. HasLogFunc e => KeySource -> RIO e KeyEvent
awaitKey KeySource
src = do
  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
  logDebug $ "\n" <> display (T.replicate 80 "-")
          <> "\nReceived event: " <> display e
  pure e