{-# LANGUAGE CPP #-}
{-|
Module      : KMonad.App.Main
Description : The entry-point to KMonad
Copyright   : (c) David Janssen, 2021
License     : MIT

Maintainer  : janssen.dhj@gmail.com
Stability   : experimental
Portability : non-portable

-}
module KMonad.App.Main
  ( -- * The entry-point to KMonad
    main
  )
where

import KMonad.Prelude

import KMonad.Args
import KMonad.App.Types
import KMonad.Keyboard
import KMonad.Util
import KMonad.Model



import qualified KMonad.Model.Dispatch as Dp
import qualified KMonad.Model.Hooks    as Hs
import qualified KMonad.Model.Sluice   as Sl
import qualified KMonad.Model.Keymap   as Km

-- FIXME: This should live somewhere else

#ifdef linux_HOST_OS
import System.Posix.Signals (Handler(Ignore), installHandler, sigCHLD)
#endif

--------------------------------------------------------------------------------
-- $start
--
-- How to start KMonad

-- | The first command in KMonad
--
-- Get the invocation from the command-line, then do something with it.
main :: IO ()
main :: IO ()
main = IO Cmd
getCmd IO Cmd -> (Cmd -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Cmd -> IO ()
runCmd

-- | Execute the provided 'Cmd'
--
-- 1. Construct the log-func
-- 2. Parse the config-file
-- 3. Maybe start KMonad
runCmd :: Cmd -> IO ()
runCmd :: Cmd -> IO ()
runCmd Cmd
c = do
  Handle -> BufferMode -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> BufferMode -> m ()
hSetBuffering Handle
stdout BufferMode
LineBuffering
  o <- Handle -> Bool -> IO LogOptions
forall (m :: * -> *). MonadIO m => Handle -> Bool -> m LogOptions
logOptionsHandle Handle
stdout Bool
False IO LogOptions -> (LogOptions -> LogOptions) -> IO LogOptions
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> LogLevel -> LogOptions -> LogOptions
setLogMinLevel (Cmd
cCmd -> Getting LogLevel Cmd LogLevel -> LogLevel
forall s a. s -> Getting a s a -> a
^.Getting LogLevel Cmd LogLevel
forall c. HasCmd c => Lens' c LogLevel
Lens' Cmd LogLevel
logLvl)
  withLogFunc o $ \LogFunc
f -> LogFunc -> RIO LogFunc () -> IO ()
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO LogFunc
f (RIO LogFunc () -> IO ()) -> RIO LogFunc () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    cfg <- Cmd -> RIO LogFunc AppCfg
forall e. HasLogFunc e => Cmd -> RIO e AppCfg
loadConfig Cmd
c
    unless (c^.dryRun) $ startApp cfg

--------------------------------------------------------------------------------
-- $init
--
-- The steps required to turn a configuration into the initial KMonad env

-- | Initialize all the components of the KMonad app-loop
--
-- NOTE: This is written in 'ContT' over our normal RIO monad. This is just to
-- to simplify a bunch of nesting of calls. At no point do we make use of
-- 'callCC' or other 'ContT' functionality.
--
initAppEnv :: HasLogFunc e => AppCfg -> ContT r (RIO e) AppEnv
initAppEnv :: forall e r. HasLogFunc e => AppCfg -> ContT r (RIO e) AppEnv
initAppEnv AppCfg
cfg = do
  -- Get a reference to the logging function
  lgf <- Getting LogFunc e LogFunc -> ContT r (RIO e) LogFunc
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting LogFunc e LogFunc
forall env. HasLogFunc env => Lens' env LogFunc
Lens' e LogFunc
logFuncL

  -- Wait a bit for the user to release the 'Return' key with which they started KMonad
  threadDelay $ fromIntegral (cfg^.startDelay) * 1000

  -- Acquire the key source and key sink
  snk <- using $ cfg^.keySinkDev
  src <- using $ cfg^.keySourceDev

  -- Initialize the pull-chain components
  dsp <- Dp.mkDispatch $ awaitKey src
  ihk <- Hs.mkHooks    $ Dp.pull  dsp
  slc <- Sl.mkSluice   $ Hs.pull  ihk

  -- Initialize the button environments in the keymap
  phl <- Km.mkKeymap (cfg^.firstLayer) (cfg^.keymapCfg)

  -- Initialize output components
  otv <- lift newEmptyTMVarIO
  ohk <- Hs.mkHooks . atomically . takeTMVar $ otv

  -- Setup thread to read from outHooks and emit to keysink
  launch_ "emitter_proc" $ do
    e <- atomically . takeTMVar $ otv
    emitKey snk e
    -- If delay is specified, wait for it
    for_ (cfg^.keyOutDelay) $ threadDelay . (*1000) . fromIntegral
  -- emit e = view keySink >>= flip emitKey e
  pure $ AppEnv
    { _keAppCfg  = cfg
    , _keLogFunc = lgf
    , _keySink   = snk
    , _keySource = src

    , _dispatch  = dsp
    , _inHooks   = ihk
    , _sluice    = slc

    , _keymap    = phl
    , _outHooks  = ohk
    , _outVar    = otv
    }

--------------------------------------------------------------------------------
-- $emit
--
-- How to use a KMonad env to emit keys to the OS
--
-- FIXME: this needs to live somewhere else

-- | Trigger the button-action press currently registered to 'Keycode'
pressKey :: (HasAppEnv e, HasLogFunc e, HasAppCfg e) => Keycode -> RIO e ()
pressKey :: forall e.
(HasAppEnv e, HasLogFunc e, HasAppCfg e) =>
Keycode -> RIO e ()
pressKey Keycode
c =
  Getting Keymap e Keymap -> RIO e Keymap
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Keymap e Keymap
forall c. HasAppEnv c => Lens' c Keymap
Lens' e Keymap
keymap RIO e Keymap
-> (Keymap -> RIO e (Maybe BEnv)) -> RIO e (Maybe BEnv)
forall a b. RIO e a -> (a -> RIO e b) -> RIO e b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Keymap -> Keycode -> RIO e (Maybe BEnv))
-> Keycode -> Keymap -> RIO e (Maybe BEnv)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Keymap -> Keycode -> RIO e (Maybe BEnv)
forall (m :: * -> *).
MonadIO m =>
Keymap -> Keycode -> m (Maybe BEnv)
Km.lookupKey Keycode
c RIO e (Maybe BEnv) -> (Maybe BEnv -> RIO e ()) -> RIO e ()
forall a b. RIO e a -> (a -> RIO e b) -> RIO e b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case

    -- If the keycode does not occur in our keymap
    Maybe BEnv
Nothing -> do
      ft <- Getting Bool e Bool -> RIO e Bool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Bool e Bool
forall c. HasAppCfg c => Lens' c Bool
Lens' e Bool
fallThrough
      when ft $ do
          emit $ mkPress c
          await (isReleaseOf c) $ \KeyEvent
_ -> do
            KeyEvent -> RIO e ()
forall (m :: * -> *). MonadKIO m => KeyEvent -> m ()
emit (KeyEvent -> RIO e ()) -> KeyEvent -> RIO e ()
forall a b. (a -> b) -> a -> b
$ Keycode -> KeyEvent
mkRelease Keycode
c
            Catch -> RIO e Catch
forall a. a -> RIO e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Catch
Catch

    -- If the keycode does occur in our keymap
    Just BEnv
b  -> BEnv -> Switch -> RIO e (Maybe Action)
forall (m :: * -> *).
MonadUnliftIO m =>
BEnv -> Switch -> m (Maybe Action)
runBEnv BEnv
b Switch
Press RIO e (Maybe Action) -> (Maybe Action -> RIO e ()) -> RIO e ()
forall a b. RIO e a -> (a -> RIO e b) -> RIO e b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe Action
Nothing -> () -> RIO e ()
forall a. a -> RIO e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()  -- If the previous action on this key was *not* a release
      Just Action
a  -> do
        -- Execute the press and register the release
        app <- Getting AppEnv e AppEnv -> RIO e AppEnv
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting AppEnv e AppEnv
forall c. HasAppEnv c => Lens' c AppEnv
Lens' e AppEnv
appEnv
        runRIO (KEnv app b) $ do
          runAction a
          awaitMy Release $ do
            runBEnv b Release >>= \case
              Maybe Action
Nothing -> () -> RIO KEnv ()
forall a. a -> RIO KEnv a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              Just Action
a  -> Action -> AnyK ()
runAction Action
a
            pure Catch

--------------------------------------------------------------------------------
-- $loop
--
-- The app-loop of KMonad

-- | Perform 1 step of KMonad's app loop
--
-- We forever:
-- 1. Pull from the pull-chain until an unhandled event reaches us.
-- 2. If that event is a 'Press' we use our keymap to trigger an action.
loop :: RIO AppEnv ()
loop :: RIO AppEnv ()
loop = RIO AppEnv () -> RIO AppEnv ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (RIO AppEnv () -> RIO AppEnv ()) -> RIO AppEnv () -> RIO AppEnv ()
forall a b. (a -> b) -> a -> b
$ Getting Sluice AppEnv Sluice -> RIO AppEnv Sluice
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Sluice AppEnv Sluice
forall c. HasAppEnv c => Lens' c Sluice
Lens' AppEnv Sluice
sluice RIO AppEnv Sluice
-> (Sluice -> RIO AppEnv KeyEvent) -> RIO AppEnv KeyEvent
forall a b. RIO AppEnv a -> (a -> RIO AppEnv b) -> RIO AppEnv b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Sluice -> RIO AppEnv KeyEvent
forall e. HasLogFunc e => Sluice -> RIO e KeyEvent
Sl.pull RIO AppEnv KeyEvent -> (KeyEvent -> RIO AppEnv ()) -> RIO AppEnv ()
forall a b. RIO AppEnv a -> (a -> RIO AppEnv b) -> RIO AppEnv b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  KeyEvent
e | KeyEvent
eKeyEvent -> Getting Switch KeyEvent Switch -> Switch
forall s a. s -> Getting a s a -> a
^.Getting Switch KeyEvent Switch
forall c. HasKeyEvent c => Lens' c Switch
Lens' KeyEvent Switch
switch Switch -> Switch -> Bool
forall a. Eq a => a -> a -> Bool
== Switch
Press -> Keycode -> RIO AppEnv ()
forall e.
(HasAppEnv e, HasLogFunc e, HasAppCfg e) =>
Keycode -> RIO e ()
pressKey (Keycode -> RIO AppEnv ()) -> Keycode -> RIO AppEnv ()
forall a b. (a -> b) -> a -> b
$ KeyEvent
eKeyEvent -> Getting Keycode KeyEvent Keycode -> Keycode
forall s a. s -> Getting a s a -> a
^.Getting Keycode KeyEvent Keycode
forall c. HasKeyEvent c => Lens' c Keycode
Lens' KeyEvent Keycode
keycode
  KeyEvent
_                      -> () -> RIO AppEnv ()
forall a. a -> RIO AppEnv a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Run KMonad using the provided configuration
startApp :: HasLogFunc e => AppCfg -> RIO e ()
startApp :: forall e. HasLogFunc e => AppCfg -> RIO e ()
startApp AppCfg
c = do
#ifdef linux_HOST_OS
  -- Ignore SIGCHLD to avoid zombie processes.
  IO () -> RIO e ()
forall a. IO a -> RIO e a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO e ())
-> (IO Handler -> IO ()) -> IO Handler -> RIO e ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO Handler -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Handler -> RIO e ()) -> IO Handler -> RIO e ()
forall a b. (a -> b) -> a -> b
$ Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
sigCHLD Handler
Ignore Maybe SignalSet
forall a. Maybe a
Nothing
#endif
  ContT () (RIO e) AppEnv -> (AppEnv -> RIO e ()) -> RIO e ()
forall {k} (r :: k) (m :: k -> *) a.
ContT r m a -> (a -> m r) -> m r
runContT (AppCfg -> ContT () (RIO e) AppEnv
forall e r. HasLogFunc e => AppCfg -> ContT r (RIO e) AppEnv
initAppEnv AppCfg
c) (AppEnv -> RIO AppEnv () -> RIO e ()
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
`runRIO` RIO AppEnv ()
loop)