{-# OPTIONS_GHC -Wno-orphans #-}
{-|
Module      : KMonad.App
Description : The central app-loop of KMonad
Copyright   : (c) David Janssen, 2019
License     : MIT
Maintainer  : janssen.dhj@gmail.com
Stability   : experimental
Portability : portable

-}
module KMonad.App
  ( AppCfg(..)
  , HasAppCfg(..)
  , startApp
  )
where

import KMonad.Prelude

import UnliftIO.Process (spawnCommand)
import RIO.Text (unpack)

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

import qualified KMonad.App.Dispatch as Dp
import qualified KMonad.App.Hooks    as Hs
import qualified KMonad.App.Sluice   as Sl
import qualified KMonad.App.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
  }
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 :: (LogFunc -> f LogFunc) -> AppEnv -> f AppEnv
logFuncL = (LogFunc -> f LogFunc) -> AppEnv -> f AppEnv
forall c. HasAppEnv c => Lens' c LogFunc
keLogFunc
instance HasAppCfg  AppEnv where appCfg :: (AppCfg -> f AppCfg) -> AppEnv -> f AppEnv
appCfg   = (AppCfg -> f AppCfg) -> AppEnv -> f AppEnv
forall c. HasAppEnv c => Lens' c AppCfg
keAppCfg


--------------------------------------------------------------------------------
-- $init

-- | 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 :: AppCfg -> ContT r (RIO e) AppEnv
initAppEnv cfg :: AppCfg
cfg = do
  -- Get a reference to the logging function
  LogFunc
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
logFuncL

  -- Acquire the keysource and keysink
  KeySink
snk <- Acquire KeySink -> ContT r (RIO e) KeySink
forall a r e. Acquire a -> ContT r (RIO e) a
using (Acquire KeySink -> ContT r (RIO e) KeySink)
-> Acquire KeySink -> ContT r (RIO e) KeySink
forall a b. (a -> b) -> a -> b
$ AppCfg
cfgAppCfg
-> Getting (Acquire KeySink) AppCfg (Acquire KeySink)
-> Acquire KeySink
forall s a. s -> Getting a s a -> a
^.Getting (Acquire KeySink) AppCfg (Acquire KeySink)
forall c. HasAppCfg c => Lens' c (Acquire KeySink)
keySinkDev
  KeySource
src <- Acquire KeySource -> ContT r (RIO e) KeySource
forall a r e. Acquire a -> ContT r (RIO e) a
using (Acquire KeySource -> ContT r (RIO e) KeySource)
-> Acquire KeySource -> ContT r (RIO e) KeySource
forall a b. (a -> b) -> a -> b
$ AppCfg
cfgAppCfg
-> Getting (Acquire KeySource) AppCfg (Acquire KeySource)
-> Acquire KeySource
forall s a. s -> Getting a s a -> a
^.Getting (Acquire KeySource) AppCfg (Acquire KeySource)
forall c. HasAppCfg c => Lens' c (Acquire KeySource)
keySourceDev

  -- Initialize the pull-chain components
  Dispatch
dsp <- RIO e KeyEvent -> ContT r (RIO e) Dispatch
forall (m :: * -> *) r.
MonadUnliftIO m =>
m KeyEvent -> ContT r m Dispatch
Dp.mkDispatch (RIO e KeyEvent -> ContT r (RIO e) Dispatch)
-> RIO e KeyEvent -> ContT r (RIO e) Dispatch
forall a b. (a -> b) -> a -> b
$ KeySource -> RIO e KeyEvent
forall e. HasLogFunc e => KeySource -> RIO e KeyEvent
awaitKey KeySource
src
  Hooks
ihk <- RIO e KeyEvent -> ContT r (RIO e) Hooks
forall (m :: * -> *) r.
MonadUnliftIO m =>
m KeyEvent -> ContT r m Hooks
Hs.mkHooks    (RIO e KeyEvent -> ContT r (RIO e) Hooks)
-> RIO e KeyEvent -> ContT r (RIO e) Hooks
forall a b. (a -> b) -> a -> b
$ Dispatch -> RIO e KeyEvent
forall e. HasLogFunc e => Dispatch -> RIO e KeyEvent
Dp.pull  Dispatch
dsp
  Sluice
slc <- RIO e KeyEvent -> ContT r (RIO e) Sluice
forall (m :: * -> *) r.
MonadUnliftIO m =>
m KeyEvent -> ContT r m Sluice
Sl.mkSluice   (RIO e KeyEvent -> ContT r (RIO e) Sluice)
-> RIO e KeyEvent -> ContT r (RIO e) Sluice
forall a b. (a -> b) -> a -> b
$ Hooks -> RIO e KeyEvent
forall e. HasLogFunc e => Hooks -> RIO e KeyEvent
Hs.pull  Hooks
ihk

  -- Initialize the button environments in the keymap
  Keymap
phl <- LayerTag -> LMap Button -> ContT r (RIO e) Keymap
forall (m :: * -> *) r.
MonadUnliftIO m =>
LayerTag -> LMap Button -> ContT r m Keymap
Km.mkKeymap (AppCfg
cfgAppCfg -> Getting LayerTag AppCfg LayerTag -> LayerTag
forall s a. s -> Getting a s a -> a
^.Getting LayerTag AppCfg LayerTag
forall c. HasAppCfg c => Lens' c LayerTag
firstLayer) (AppCfg
cfgAppCfg -> Getting (LMap Button) AppCfg (LMap Button) -> LMap Button
forall s a. s -> Getting a s a -> a
^.Getting (LMap Button) AppCfg (LMap Button)
forall c. HasAppCfg c => Lens' c (LMap Button)
keymapCfg)

  -- Initialize output components
  TMVar KeyEvent
otv <- RIO e (TMVar KeyEvent) -> ContT r (RIO e) (TMVar KeyEvent)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RIO e (TMVar KeyEvent) -> ContT r (RIO e) (TMVar KeyEvent))
-> (STM (TMVar KeyEvent) -> RIO e (TMVar KeyEvent))
-> STM (TMVar KeyEvent)
-> ContT r (RIO e) (TMVar KeyEvent)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (TMVar KeyEvent) -> RIO e (TMVar KeyEvent)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (TMVar KeyEvent) -> ContT r (RIO e) (TMVar KeyEvent))
-> STM (TMVar KeyEvent) -> ContT r (RIO e) (TMVar KeyEvent)
forall a b. (a -> b) -> a -> b
$ STM (TMVar KeyEvent)
forall a. STM (TMVar a)
newEmptyTMVar
  Hooks
ohk <- RIO e KeyEvent -> ContT r (RIO e) Hooks
forall (m :: * -> *) r.
MonadUnliftIO m =>
m KeyEvent -> ContT r m Hooks
Hs.mkHooks (RIO e KeyEvent -> ContT r (RIO e) Hooks)
-> (TMVar KeyEvent -> RIO e KeyEvent)
-> TMVar KeyEvent
-> ContT r (RIO e) Hooks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM KeyEvent -> RIO e KeyEvent
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM KeyEvent -> RIO e KeyEvent)
-> (TMVar KeyEvent -> STM KeyEvent)
-> TMVar KeyEvent
-> RIO e KeyEvent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMVar KeyEvent -> STM KeyEvent
forall a. TMVar a -> STM a
takeTMVar (TMVar KeyEvent -> ContT r (RIO e) Hooks)
-> TMVar KeyEvent -> ContT r (RIO e) Hooks
forall a b. (a -> b) -> a -> b
$ TMVar KeyEvent
otv

  -- Setup thread to read from outHooks and emit to keysink
  LayerTag -> RIO e () -> ContT r (RIO e) ()
forall e a r.
HasLogFunc e =>
LayerTag -> RIO e a -> ContT r (RIO e) ()
launch_ "emitter_proc" (RIO e () -> ContT r (RIO e) ()) -> RIO e () -> ContT r (RIO e) ()
forall a b. (a -> b) -> a -> b
$ do
    KeyEvent
e <- STM KeyEvent -> RIO e KeyEvent
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM KeyEvent -> RIO e KeyEvent)
-> (TMVar KeyEvent -> STM KeyEvent)
-> TMVar KeyEvent
-> RIO e KeyEvent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMVar KeyEvent -> STM KeyEvent
forall a. TMVar a -> STM a
takeTMVar (TMVar KeyEvent -> RIO e KeyEvent)
-> TMVar KeyEvent -> RIO e KeyEvent
forall a b. (a -> b) -> a -> b
$ TMVar KeyEvent
otv
    KeySink -> KeyEvent -> RIO e ()
forall e. HasLogFunc e => KeySink -> KeyEvent -> RIO e ()
emitKey KeySink
snk KeyEvent
e
  -- emit e = view keySink >>= flip emitKey e
  AppEnv -> ContT r (RIO e) AppEnv
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AppEnv -> ContT r (RIO e) AppEnv)
-> AppEnv -> ContT r (RIO e) AppEnv
forall a b. (a -> b) -> a -> b
$ AppEnv :: AppCfg
-> LogFunc
-> KeySink
-> KeySource
-> Dispatch
-> Hooks
-> Sluice
-> Keymap
-> Hooks
-> TMVar KeyEvent
-> AppEnv
AppEnv
    { _keAppCfg :: AppCfg
_keAppCfg  = AppCfg
cfg
    , _keLogFunc :: LogFunc
_keLogFunc = LogFunc
lgf
    , _keySink :: KeySink
_keySink   = KeySink
snk
    , _keySource :: KeySource
_keySource = KeySource
src

    , _dispatch :: Dispatch
_dispatch  = Dispatch
dsp
    , _inHooks :: Hooks
_inHooks   = Hooks
ihk
    , _sluice :: Sluice
_sluice    = Sluice
slc

    , _keymap :: Keymap
_keymap    = Keymap
phl
    , _outHooks :: Hooks
_outHooks  = Hooks
ohk
    , _outVar :: TMVar KeyEvent
_outVar    = TMVar KeyEvent
otv
    }


--------------------------------------------------------------------------------
-- $loop
--
-- The central app-loop of KMonad.

-- | Trigger the button-action press currently registered to 'Keycode'
pressKey :: (HasAppEnv e, HasLogFunc e, HasAppCfg e) => Keycode -> RIO e ()
pressKey :: Keycode -> RIO e ()
pressKey c :: 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
keymap RIO e Keymap
-> (Keymap -> RIO e (Maybe BEnv)) -> RIO e (Maybe BEnv)
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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case

    -- If the keycode does not occur in our keymap
    Nothing -> do
      Bool
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
fallThrough
      if Bool
ft
        then 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
mkPress Keycode
c
          KeyPred -> (KeyEvent -> RIO e Catch) -> RIO e ()
forall (m :: * -> *).
MonadKIO m =>
KeyPred -> (KeyEvent -> m Catch) -> m ()
await (Keycode -> KeyPred
isReleaseOf Keycode
c) ((KeyEvent -> RIO e Catch) -> RIO e ())
-> (KeyEvent -> RIO e Catch) -> RIO e ()
forall a b. (a -> b) -> a -> b
$ \_ -> 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 (f :: * -> *) a. Applicative f => a -> f a
pure Catch
Catch
        else () -> RIO e ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    -- If the keycode does occur in our keymap
    Just b :: 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Nothing -> () -> RIO e ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()  -- If the previous action on this key was *not* a release
      Just a :: Action
a  -> do
        -- Execute the press and register the release
        AppEnv
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
appEnv
        KEnv -> RIO KEnv () -> RIO e ()
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO (AppEnv -> BEnv -> KEnv
KEnv AppEnv
app BEnv
b) (RIO KEnv () -> RIO e ()) -> RIO KEnv () -> RIO e ()
forall a b. (a -> b) -> a -> b
$ do
          Action -> forall (m :: * -> *). MonadK m => m ()
runAction Action
a
          Switch -> RIO KEnv Catch -> RIO KEnv ()
forall (m :: * -> *). MonadK m => Switch -> m Catch -> m ()
awaitMy Switch
Release (RIO KEnv Catch -> RIO KEnv ()) -> RIO KEnv Catch -> RIO KEnv ()
forall a b. (a -> b) -> a -> b
$ do
            BEnv -> Switch -> RIO KEnv (Maybe Action)
forall (m :: * -> *).
MonadUnliftIO m =>
BEnv -> Switch -> m (Maybe Action)
runBEnv BEnv
b Switch
Release RIO KEnv (Maybe Action)
-> (Maybe Action -> RIO KEnv ()) -> RIO KEnv ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RIO KEnv ()
-> (Action -> RIO KEnv ()) -> Maybe Action -> RIO KEnv ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> RIO KEnv ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) Action -> RIO KEnv ()
Action -> forall (m :: * -> *). MonadK m => m ()
runAction
            Catch -> RIO KEnv Catch
forall (f :: * -> *) a. Applicative f => a -> f a
pure Catch
Catch

-- | 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
sluice RIO AppEnv Sluice
-> (Sluice -> RIO AppEnv KeyEvent) -> RIO AppEnv KeyEvent
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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  e :: KeyEvent
e | KeyEvent
eKeyEvent -> Getting Switch KeyEvent Switch -> Switch
forall s a. s -> Getting a s a -> a
^.Getting Switch KeyEvent 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
Lens' KeyEvent Keycode
keycode
  _                      -> () -> RIO AppEnv ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Run KMonad using the provided configuration
startApp :: HasLogFunc e => AppCfg -> RIO e ()
startApp :: AppCfg -> RIO e ()
startApp c :: AppCfg
c = 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 ())
-> RIO AppEnv () -> AppEnv -> RIO e ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip AppEnv -> RIO AppEnv () -> RIO e ()
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO RIO AppEnv ()
loop)

instance (HasAppEnv e, HasAppCfg e, HasLogFunc e) => MonadKIO (RIO e) where
  -- Emitting with the keysink
  emit :: KeyEvent -> RIO e ()
emit e :: 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)
outVar RIO e (TMVar KeyEvent) -> (TMVar KeyEvent -> RIO e ()) -> RIO e ()
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
*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 b :: 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
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
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 (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 l :: HookLocation
l h :: Hook (RIO e)
h = do
    Hooks
hs <- case HookLocation
l of
      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
inHooks
      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
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 o :: 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
keymap RIO e Keymap -> (Keymap -> RIO e ()) -> RIO e ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \hl :: 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 e :: 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
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
$ "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 t :: 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
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
$ "Running command: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> LayerTag -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display LayerTag
t
      RIO e ProcessHandle -> RIO e ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (RIO e ProcessHandle -> RIO e ())
-> (LayerTag -> RIO e ProcessHandle) -> LayerTag -> RIO e ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> RIO e ProcessHandle
forall (m :: * -> *). MonadIO m => String -> m ProcessHandle
spawnCommand (String -> RIO e ProcessHandle)
-> (LayerTag -> String) -> LayerTag -> RIO e ProcessHandle
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
$ "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

--------------------------------------------------------------------------------
-- $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 :: (AppCfg -> f AppCfg) -> KEnv -> f KEnv
appCfg       = (AppEnv -> f AppEnv) -> KEnv -> f KEnv
forall c. HasKEnv c => Lens' c 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
appCfg
instance HasAppEnv  KEnv where appEnv :: (AppEnv -> f AppEnv) -> KEnv -> f KEnv
appEnv       = (AppEnv -> f AppEnv) -> KEnv -> f KEnv
forall c. HasKEnv c => Lens' c AppEnv
kAppEnv
instance HasBEnv    KEnv where bEnv :: (BEnv -> f BEnv) -> KEnv -> f KEnv
bEnv         = (BEnv -> f BEnv) -> KEnv -> f KEnv
forall c. HasKEnv c => Lens' c BEnv
kBEnv
instance HasLogFunc KEnv where logFuncL :: (LogFunc -> f LogFunc) -> KEnv -> f KEnv
logFuncL     = (AppEnv -> f AppEnv) -> KEnv -> f KEnv
forall c. HasKEnv c => Lens' c 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
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
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
binding)