{-# LANGUAGE DeriveAnyClass #-}
{-|
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
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 :: 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

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


--------------------------------------------------------------------------------
-- $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 keysink
  -> (src -> RIO e ())       -- ^ Action to close the keysink
  -> (src -> RIO e KeyEvent) -- ^ Action to write with the keysink
  -> 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

-- | Wait for the next key from the OS
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