{-# OPTIONS_GHC -Wno-orphans #-}
module KMonad.App.Types
  ( AppCfg(..)
  , AppEnv(..)
  , KEnv(..)
  , HasAppCfg(..)
  , HasAppEnv(..)
  , HasKEnv(..)
  )
where

import KMonad.Prelude

import UnliftIO.Process (CreateProcess(close_fds), createProcess_, shell)

import KMonad.Keyboard
import KMonad.Keyboard.IO
import KMonad.Model.Action
import KMonad.Model.Button
import KMonad.Model.BEnv
import KMonad.Util

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

--------------------------------------------------------------------------------
-- $appcfg
--
-- The 'AppCfg' and 'AppEnv' records store the configuration and runtime
-- environment of KMonad's app-loop respectively. This contains nearly all of
-- the components required to run KMonad.
--
-- Note that the 'AppEnv' is still not sufficient to satisfy 'MonadK', since
-- there are times where we are not processing a button push. I.e. 'MonadK' is a
-- series of operations that allow us to specify how to deal with the current
-- button-push, but it required us to have actually registered a push (or
-- release) of some button. 'AppEnv' exists before any buttons have been pushed,
-- and therefore contains no information about 'the current button push' (nor
-- could it). Later in this module we specify KEnv as a combination of AppEnv
-- and a BEnv. It is that environment that we use to satisfy 'MonadK'.

-- | Record of all the configuration options required to run KMonad's core App
-- loop.
data AppCfg = AppCfg
  { AppCfg -> Acquire KeySink
_keySinkDev   :: Acquire KeySink   -- ^ How to open a 'KeySink'
  , AppCfg -> Acquire KeySource
_keySourceDev :: Acquire KeySource -- ^ How to open a 'KeySource'
  , AppCfg -> LMap Button
_keymapCfg    :: LMap Button       -- ^ The map defining the 'Button' layout
  , AppCfg -> LayerTag
_firstLayer   :: LayerTag          -- ^ Active layer when KMonad starts
  , AppCfg -> Bool
_fallThrough  :: Bool              -- ^ Whether uncaught events should be emitted or not
  , AppCfg -> Bool
_allowCmd     :: Bool              -- ^ Whether shell-commands are allowed
  , AppCfg -> Milliseconds
_startDelay   :: Milliseconds      -- ^ How long to wait before acquiring the input keyboard
  , AppCfg -> Maybe Milliseconds
_keyOutDelay  :: Maybe Milliseconds -- ^ How long to wait after each key event outputted
  }
makeClassy ''AppCfg


-- | Environment of a running KMonad app-loop
data AppEnv = AppEnv
  { -- Stored copy of cfg
    AppEnv -> AppCfg
_keAppCfg   :: AppCfg

    -- General IO
  , AppEnv -> LogFunc
_keLogFunc  :: LogFunc
  , AppEnv -> KeySink
_keySink    :: KeySink
  , AppEnv -> KeySource
_keySource  :: KeySource

    -- Pull chain
  , AppEnv -> Dispatch
_dispatch   :: Dp.Dispatch
  , AppEnv -> Hooks
_inHooks    :: Hs.Hooks
  , AppEnv -> Sluice
_sluice     :: Sl.Sluice

    -- Other components
  , AppEnv -> Keymap
_keymap     :: Km.Keymap
  , AppEnv -> Hooks
_outHooks   :: Hs.Hooks
  , AppEnv -> TMVar KeyEvent
_outVar     :: TMVar KeyEvent
  }
makeClassy ''AppEnv

instance HasLogFunc AppEnv where logFuncL :: Lens' AppEnv LogFunc
logFuncL = (LogFunc -> f LogFunc) -> AppEnv -> f AppEnv
forall c. HasAppEnv c => Lens' c LogFunc
Lens' AppEnv LogFunc
keLogFunc
instance HasAppCfg  AppEnv where appCfg :: Lens' AppEnv AppCfg
appCfg   = (AppCfg -> f AppCfg) -> AppEnv -> f AppEnv
forall c. HasAppEnv c => Lens' c AppCfg
Lens' AppEnv AppCfg
keAppCfg

--------------------------------------------------------------------------------
-- $kenv
--

-- | The complete environment capable of satisfying 'MonadK'
data KEnv = KEnv
  { KEnv -> AppEnv
_kAppEnv :: AppEnv -- ^ The app environment containing all the components
  , KEnv -> BEnv
_kBEnv   :: BEnv   -- ^ The environment describing the currently active button
  }
makeClassy ''KEnv

instance HasAppCfg  KEnv where appCfg :: Lens' KEnv AppCfg
appCfg       = (AppEnv -> f AppEnv) -> KEnv -> f KEnv
forall c. HasKEnv c => Lens' c AppEnv
Lens' KEnv AppEnv
kAppEnv((AppEnv -> f AppEnv) -> KEnv -> f KEnv)
-> ((AppCfg -> f AppCfg) -> AppEnv -> f AppEnv)
-> (AppCfg -> f AppCfg)
-> KEnv
-> f KEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(AppCfg -> f AppCfg) -> AppEnv -> f AppEnv
forall c. HasAppCfg c => Lens' c AppCfg
Lens' AppEnv AppCfg
appCfg
instance HasAppEnv  KEnv where appEnv :: Lens' KEnv AppEnv
appEnv       = (AppEnv -> f AppEnv) -> KEnv -> f KEnv
forall c. HasKEnv c => Lens' c AppEnv
Lens' KEnv AppEnv
kAppEnv
instance HasBEnv    KEnv where bEnv :: Lens' KEnv BEnv
bEnv         = (BEnv -> f BEnv) -> KEnv -> f KEnv
forall c. HasKEnv c => Lens' c BEnv
Lens' KEnv BEnv
kBEnv
instance HasLogFunc KEnv where logFuncL :: Lens' KEnv LogFunc
logFuncL     = (AppEnv -> f AppEnv) -> KEnv -> f KEnv
forall c. HasKEnv c => Lens' c AppEnv
Lens' KEnv AppEnv
kAppEnv((AppEnv -> f AppEnv) -> KEnv -> f KEnv)
-> ((LogFunc -> f LogFunc) -> AppEnv -> f AppEnv)
-> (LogFunc -> f LogFunc)
-> KEnv
-> f KEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(LogFunc -> f LogFunc) -> AppEnv -> f AppEnv
forall env. HasLogFunc env => Lens' env LogFunc
Lens' AppEnv LogFunc
logFuncL

-- | Hook up all the components to the different 'MonadK' functionalities
instance MonadK (RIO KEnv) where
  -- Binding is found in the stored 'BEnv'
  myBinding :: RIO KEnv Keycode
myBinding = Getting Keycode KEnv Keycode -> RIO KEnv Keycode
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((BEnv -> Const Keycode BEnv) -> KEnv -> Const Keycode KEnv
forall c. HasBEnv c => Lens' c BEnv
Lens' KEnv BEnv
bEnv((BEnv -> Const Keycode BEnv) -> KEnv -> Const Keycode KEnv)
-> ((Keycode -> Const Keycode Keycode)
    -> BEnv -> Const Keycode BEnv)
-> Getting Keycode KEnv Keycode
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Keycode -> Const Keycode Keycode) -> BEnv -> Const Keycode BEnv
forall c. HasBEnv c => Lens' c Keycode
Lens' BEnv Keycode
binding)

instance (HasAppEnv e, HasAppCfg e, HasLogFunc e) => MonadKIO (RIO e) where
  -- Emitting with the keysink
  emit :: KeyEvent -> RIO e ()
emit KeyEvent
e = Getting (TMVar KeyEvent) e (TMVar KeyEvent)
-> RIO e (TMVar KeyEvent)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (TMVar KeyEvent) e (TMVar KeyEvent)
forall c. HasAppEnv c => Lens' c (TMVar KeyEvent)
Lens' e (TMVar KeyEvent)
outVar RIO e (TMVar KeyEvent) -> (TMVar KeyEvent -> 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
>>= STM () -> RIO e ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> RIO e ())
-> (TMVar KeyEvent -> STM ()) -> TMVar KeyEvent -> RIO e ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TMVar KeyEvent -> KeyEvent -> STM ())
-> KeyEvent -> TMVar KeyEvent -> STM ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip TMVar KeyEvent -> KeyEvent -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar KeyEvent
e
  -- emit e = view keySink >>= flip emitKey e

  -- Pausing is a simple IO action
  pause :: Milliseconds -> RIO e ()
pause = Int -> RIO e ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay (Int -> RIO e ())
-> (Milliseconds -> Int) -> Milliseconds -> RIO e ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
1000) (Int -> Int) -> (Milliseconds -> Int) -> Milliseconds -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Milliseconds -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral

  -- Holding and rerunning through the sluice and dispatch
  hold :: Bool -> RIO e ()
hold Bool
b = do
    Sluice
sl <- Getting Sluice e Sluice -> RIO e Sluice
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Sluice e Sluice
forall c. HasAppEnv c => Lens' c Sluice
Lens' e Sluice
sluice
    Dispatch
di <- Getting Dispatch e Dispatch -> RIO e Dispatch
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Dispatch e Dispatch
forall c. HasAppEnv c => Lens' c Dispatch
Lens' e Dispatch
dispatch
    if Bool
b then Sluice -> RIO e ()
forall e. HasLogFunc e => Sluice -> RIO e ()
Sl.block Sluice
sl else Sluice -> RIO e [KeyEvent]
forall e. HasLogFunc e => Sluice -> RIO e [KeyEvent]
Sl.unblock Sluice
sl RIO e [KeyEvent] -> ([KeyEvent] -> 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
>>= Dispatch -> [KeyEvent] -> RIO e ()
forall e. HasLogFunc e => Dispatch -> [KeyEvent] -> RIO e ()
Dp.rerun Dispatch
di

  -- Hooking is performed with the hooks component
  register :: HookLocation -> Hook (RIO e) -> RIO e ()
register HookLocation
l Hook (RIO e)
h = do
    Hooks
hs <- case HookLocation
l of
      HookLocation
InputHook  -> Getting Hooks e Hooks -> RIO e Hooks
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Hooks e Hooks
forall c. HasAppEnv c => Lens' c Hooks
Lens' e Hooks
inHooks
      HookLocation
OutputHook -> Getting Hooks e Hooks -> RIO e Hooks
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Hooks e Hooks
forall c. HasAppEnv c => Lens' c Hooks
Lens' e Hooks
outHooks
    Hooks -> Hook (RIO e) -> RIO e ()
forall e. HasLogFunc e => Hooks -> Hook (RIO e) -> RIO e ()
Hs.register Hooks
hs Hook (RIO e)
h

  -- Layer-ops are sent to the 'Keymap'
  layerOp :: LayerOp -> RIO e ()
layerOp LayerOp
o = 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 ()) -> 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
>>= \Keymap
hl -> Keymap -> LayerOp -> RIO e ()
forall e. HasLogFunc e => Keymap -> LayerOp -> RIO e ()
Km.layerOp Keymap
hl LayerOp
o

  -- Injecting by adding to Dispatch's rerun buffer
  inject :: KeyEvent -> RIO e ()
inject KeyEvent
e = do
    Dispatch
di <- Getting Dispatch e Dispatch -> RIO e Dispatch
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Dispatch e Dispatch
forall c. HasAppEnv c => Lens' c Dispatch
Lens' e Dispatch
dispatch
    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
"Injecting event: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> KeyEvent -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display KeyEvent
e
    Dispatch -> [KeyEvent] -> RIO e ()
forall e. HasLogFunc e => Dispatch -> [KeyEvent] -> RIO e ()
Dp.rerun Dispatch
di [KeyEvent
e]

  -- Shell-command through spawnCommand
  shellCmd :: LayerTag -> RIO e ()
shellCmd LayerTag
t = do
    Bool
f <- 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
allowCmd
    if Bool
f then do
      Utf8Builder -> RIO e ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO e ()) -> Utf8Builder -> RIO e ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Running command: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> LayerTag -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display LayerTag
t
      String -> RIO e ()
forall (m :: * -> *). MonadIO m => String -> m ()
spawnCommand (String -> RIO e ())
-> (LayerTag -> String) -> LayerTag -> RIO e ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayerTag -> String
unpack (LayerTag -> RIO e ()) -> LayerTag -> RIO e ()
forall a b. (a -> b) -> a -> b
$ LayerTag
t
    else
      Utf8Builder -> RIO e ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO e ()) -> Utf8Builder -> RIO e ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Received but not running: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> LayerTag -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display LayerTag
t
   where
    spawnCommand :: MonadIO m => String -> m ()
    spawnCommand :: forall (m :: * -> *). MonadIO m => String -> m ()
spawnCommand String
cmd = m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
 -> m ())
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> m ()
forall a b. (a -> b) -> a -> b
$ String
-> CreateProcess
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall (m :: * -> *).
MonadIO m =>
String
-> CreateProcess
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess_ String
"spawnCommand"
      (String -> CreateProcess
shell String
cmd){ -- We don't want the child process to inherit things like
                   -- our keyboard grab (this would, for example, make it
                   -- impossible for a command to restart KMonad).
                   close_fds   = True
                 }