{-# OPTIONS_GHC -Wno-orphans #-}
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
data AppCfg = AppCfg
{ AppCfg -> Acquire KeySink
_keySinkDev :: Acquire KeySink
, AppCfg -> Acquire KeySource
_keySourceDev :: Acquire KeySource
, AppCfg -> LMap Button
_keymapCfg :: LMap Button
, AppCfg -> LayerTag
_firstLayer :: LayerTag
, AppCfg -> Bool
_fallThrough :: Bool
, AppCfg -> Bool
_allowCmd :: Bool
}
makeClassy ''AppCfg
data AppEnv = AppEnv
{
AppEnv -> AppCfg
_keAppCfg :: AppCfg
, AppEnv -> LogFunc
_keLogFunc :: LogFunc
, AppEnv -> KeySink
_keySink :: KeySink
, AppEnv -> KeySource
_keySource :: KeySource
, AppEnv -> Dispatch
_dispatch :: Dp.Dispatch
, AppEnv -> Hooks
_inHooks :: Hs.Hooks
, AppEnv -> Sluice
_sluice :: Sl.Sluice
, 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
initAppEnv :: HasLogFunc e => AppCfg -> ContT r (RIO e) AppEnv
initAppEnv :: AppCfg -> ContT r (RIO e) AppEnv
initAppEnv cfg :: AppCfg
cfg = do
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
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
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
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)
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
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
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
}
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
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 ()
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 ()
Just a :: Action
a -> do
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
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 ()
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
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
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
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
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
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
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]
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
data KEnv = KEnv
{ KEnv -> AppEnv
_kAppEnv :: AppEnv
, KEnv -> BEnv
_kBEnv :: BEnv
}
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
instance MonadK (RIO KEnv) where
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)