8000 Change release button handling to issue passthrough events by jchtt · Pull Request #524 · kmonad/kmonad · GitHub
[go: up one dir, main page]
More Web Proxy on the site http://driver.im/
Skip to content

Change release button handling to issue passthrough events #524

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Draft
wants to merge 8 commits into
base: master
Choose a base branch
from
Draft

Change release button handling to issue passthrough events #524

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
8 commits
Select commit Hold shift + click to select a range
e0cf4ea
Added WrappedKeyEvent
Apr 16, 2022
1bf9d57
First working version with WrappedKeyEvent
Apr 17, 2022
8ebb65f
Cleanup
Apr 18, 2022
007677f
Additional hooks layer fix working.
Apr 30, 2022
a03bc09
Added some comments.
Apr 30, 2022
a3c96ee
Implemented pull chain with two hooks layers.
Apr 30, 2022
5e13486
Implementing pull chain with two layers (for real this time).
Apr 30, 2022
d57f0b5
Fixed permissions on startup file
May 1, 2022
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
18 changes: 11 additions & 7 deletions src/KMonad/App/Main.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -84,16 +84,19 @@ initAppEnv cfg = do
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
itr <- atomically $ newEmptyTMVar
Copy link
Collaborator
@jokesper jokesper Sep 11, 2024 •
edited
Loading

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Apply hint

Suggested change
itr <- atomically $ newEmptyTMVar
itr <- newEmptyTMVarIO

This is a problem at a few points.
Even better rebase on master since there it's already fixed.

dsp <- Dp.mkDispatch (awaitKey src) itr
ihkPrio <- Hs.mkHooks (Dp.pull dsp) itr
slc <- Sl.mkSluice $ Hs.pull ihkPrio
ihk <- Hs.mkHooks (Sl.pull slc) itr
Comment on lines +87 to +91
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I would give itr as the first parameter since it doesn't require parenthesis.
You would also need to change the functions below.

Suggested change
itr <- atomically $ newEmptyTMVar
dsp <- Dp.mkDispatch (awaitKey src) itr
ihkPrio <- Hs.mkHooks (Dp.pull dsp) itr
slc <- Sl.mkSluice $ Hs.pull ihkPrio
ihk <- Hs.mkHooks (Sl.pull slc) itr
itr <- atomically $ newEmptyTMVar
dsp <- Dp.mkDispatch itr $ awaitKey src
ihkPrio <- Hs.mkHooks itr $ Dp.pull dsp
slc <- Sl.mkSluice $ Hs.pull ihkPrio
ihk <- Hs.mkHooks itr $ Sl.pull slc


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

-- Initialize output components
otv <- lift . atomically $ newEmptyTMVar
ohk <- Hs.mkHooks . atomically . takeTMVar $ otv
otr <- atomically $ newEmptyTMVar
ohk <- Hs.mkHooks ((atomically . takeTMVar) otv >>= pure . (WrappedKeyEvent NoCatch)) otr
Copy link
Collaborator
@jokesper jokesper Sep 11, 2024 •
edited
Loading

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

When changing the parameter order of mkHooks as described above this too would be more readable*:

Suggested change
ohk <- Hs.mkHooks ((atomically . takeTMVar) otv >>= pure . (WrappedKeyEvent NoCatch)) otr
ohk <- Hs.mkHooks otr $ pure . WrappedKeyEvent NoCatch <=< atomically . takeTMVar $ otv

* readablitiy is subjective so this is just my opinion.
EDIT:
Or even better don't use monadic stuff when you use pure, just use the functor.


-- Setup thread to read from outHooks and emit to keysink
launch_ "emitter_proc" $ do
Expand All @@ -107,8 +110,9 @@ initAppEnv cfg = do
, _keySource = src

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

, _keymap = phl
, _outHooks = ohk
Expand Down Expand Up @@ -163,8 +167,8 @@ pressKey c =
-- 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 = forever $ view sluice >>= Sl.pull >>= \case
e | e^.switch == Press -> pressKey $ e^.keycode
loop = forever $ view inHooks >>= Hs.pull >>= \case
WrappedKeyEvent c e | c == NoCatch && e^.switch == Press -> pressKey $ e^.keycode
_ -> pure ()

-- | Run KMonad using the provided configuration
Expand Down
10 changes: 6 additions & 4 deletions src/KMonad/App/Types.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -66,9 +66,10 @@ data AppEnv = AppEnv
, _keySource :: KeySource

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

-- Other components
, _keymap :: Km.Keymap
Expand Down Expand Up @@ -118,6 +119,7 @@ instance (HasAppEnv e, HasAppCfg e, HasLogFunc e) => MonadKIO (RIO e) where
-- Hooking is performed with the hooks component
register l h = do
hs <- case l of
InputHookPrio -> view inHooksPrio
InputHook -> view inHooks
OutputHook -> view outHooks
Hs.register hs h
Expand All @@ -129,7 +131,7 @@ instanc 8000 e (HasAppEnv e, HasAppCfg e, HasLogFunc e) => MonadKIO (RIO e) where
inject e = do
di <- view dispatch
logDebug $ "Injecting event: " <> display e
Dp.rerun di [e]
Dp.rerun di [WrappedKeyEvent NoCatch e]

-- Shell-command through spawnCommand
shellCmd t = do
Expand Down
43 changes: 36 additions & 7 deletions src/KMonad/Model/Action.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -26,6 +26,8 @@ module KMonad.Model.Action
, HookLocation(..)
, Hook(..)

, WrappedEvent(..)

-- * Lenses
, HasHook(..)
, HasTimeout(..)
Expand Down Expand Up @@ -58,6 +60,8 @@ module KMonad.Model.Action

where
< 5D39 br>
import Data.Unique

import KMonad.Prelude hiding (timeout)

import KMonad.Keyboard
Expand Down Expand Up @@ -93,8 +97,10 @@ makeClassy ''Trigger

-- | ADT signalling where to install a hook
data HookLocation
= InputHook -- ^ Install the hook immediately after receiving a 'KeyEvent'
| OutputHook -- ^ Install the hook just before emitting a 'KeyEvent'
= InputHookPrio -- ^ Install the hook immediately after receiving a 'KeyEvent'
-- and before the sluice
| InputHook -- ^ Installthe hook after the sluice
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

you missed a space

Suggested change
| InputHook -- ^ Installthe hook after the sluice
| InputHook -- ^ Install the hook after the sluice

Comment on lines +100 to +102
Copy link
Collaborator
@jokesper jokesper Sep 11, 2024 •
edited
Loading

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I would have added a parmater to the InputHook to differentiate whether before or after the sluice.
This would make the within function more sensical as within OutputHook is a bit wierd.
Though this is the change I'm least sure about

| OutputHook -- ^ Install the hook just before emitting a 'KeyEvent'
deriving (Eq, Show)

-- | A 'Timeout' value describes how long to wait and what to do upon timeout
Expand All @@ -111,6 +117,28 @@ data Hook m = Hook
}
makeClassy ''Hook

--------------------------------------------------------------------------------
-- $wrapped
--
-- A WrappedEvent wraps a KeyEvent or a hook tag.
-- This is used to carry enough information to allow re-running an event if it
-- was held in the sluice.
--
-- TODO: Should this live here?
data WrappedEvent =
WrappedKeyEvent {
_catch :: Catch
, _keyEvent :: KeyEvent
} |
WrappedTag {
_tag :: Unique
}

-- | Print out a WrappedKeyEvent nicely.
instance Display WrappedEvent where
textDisplay (WrappedKeyEvent c e) = "WrappedKeyEvent " <> textDisplay e <> ", " <> tshow c
textDisplay (WrappedTag t) = "WrappedKeyEvent " <> tshow (hashUnique t)


--------------------------------------------------------------------------------
-- $lop
Expand Down Expand Up @@ -218,18 +246,19 @@ awaitMy s a = matchMy s >>= flip await (const a)
-- | Try to call a function on a succesful match of a predicate within a certain
-- time period. On a timeout, perform an action.
within :: MonadK m
=> Milliseconds -- ^ The time within which this filter is active
=> HookLocation
-> Milliseconds -- ^ The time within which this filter is active
-> m KeyPred -- ^ The predicate used to find a match
-> m () -- ^ The action to call on timeout
-> (Trigger -> m Catch) -- ^ The action to call on a succesful match
-> m () -- ^ The resulting action
within d p a f = do
within l d p a f = do
p' <- p
-- define f' to run action on predicate match, or rehook on predicate mismatch
let f' t = if p' (t^.event)
then f t
else within (d - t^.elapsed) p a f *> pure NoCatch
tHookF InputHook d a f'
else within l (d - t^.elapsed) p a f *> pure NoCatch
tHookF l d a f'

-- | Like `within`, but acquires a hold when starting, and releases when done
withinHeld :: MonadK m
Expand All @@ -240,4 +269,4 @@ withinHeld :: MonadK m
-> m () -- ^ The resulting action
withinHeld d p a f = do
hold True
within d p (a <* hold False) (\x -> f x <* hold False)
within InputHookPrio d p (a <* hold False) (\x -> f x <* hold False)
10 changes: 5 additions & 5 deletions src/KMonad/Model/Button.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -200,7 +200,7 @@ aroundNextTimeout ::
-> Button -- ^ The 'Button' to use to surround next
-> Button -- ^ The 'Button' to tap on timeout
-> Button -- ^ The resulting button
aroundNextTimeout d b t = onPress $ within d (pure isPress) (tap t) $ \trig -> do
aroundNextTimeout d b t = onPress $ within InputHook d (pure isPress) (tap t) $ \trig -> do
runAction $ b^.pressAction
await (isReleaseOf $ trig^.event.keycode) $ \_ -> do
runAction $ b^.releaseAction
Expand Down Expand Up @@ -255,7 +255,7 @@ tapNext t h = onPress $ hookF InputHook $ \e -> do

-- | Like 'tapNext', except that after some interval it switches anyways
tapHoldNext :: Milliseconds -> Button -> Button -> Maybe Button -> Button
tapHoldNext ms t h mtb = onPress $ within ms (pure $ const True) onTimeout $ \tr -> do
tapHoldNext ms t h mtb = onPress $ within InputHook ms (pure $ const True) onTimeout $ \tr -> do
p <- matchMy Release
if p $ tr^.event
then tap t *> pure Catch
Expand All @@ -278,7 +278,7 @@ tapNextRelease t h = onPress $ do
go []
where
go :: MonadK m => [Keycode] -> m ()
go ks = hookF InputHook $ \e -> do
go ks = hookF InputHookPrio $ \e -> do
p <- matchMy Release
let isRel = isRelease e
if
Expand Down Expand Up @@ -322,7 +322,7 @@ tapHoldNextRelease ms t h mtb = onPress $ do
where

go :: MonadK m => Milliseconds -> [Keycode] -> m ()
go ms' ks = tHookF InputHook ms' onTimeout $ \r -> do
go ms' ks = tHookF InputHookPrio ms' onTimeout $ \r -> do
p <- matchMy Release
let e = r^.event
let isRel = isRelease e
Expand Down Expand Up @@ -438,7 +438,7 @@ stickyKey ms b = onPress $ go

doTap :: MonadK m => m ()
doTap =
within ms
within InputHook ms
(pure isPress) -- presses definitely happen after us
(pure ())
(\t -> (runAction $ b^.pressAction)
Expand Down
43 changes: 27 additions & 16 deletions src/KMonad/Model/Dispatch.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -43,7 +43,9 @@ where

import KMonad.Prelude
import KMonad.Keyboard
import KMonad.Model.Action (WrappedEvent(..), Catch(..))

import Data.Unique
import RIO.Seq (Seq(..), (><))
import qualified RIO.Seq as Seq
import qualified RIO.Text as T
Expand All @@ -58,20 +60,21 @@ import qualified RIO.Text as T
data Dispatch = Dispatch
{ _eventSrc :: IO KeyEvent -- ^ How to read 1 event
, _readProc :: TMVar (Async KeyEvent) -- ^ Store for reading process
, _rerunBuf :: TVar (Seq KeyEvent) -- ^ Buffer for rerunning events
, _rerunBuf :: TVar (Seq WrappedEvent) -- ^ Buffer for rerunning events
, _injectTmr :: TMVar Unique -- ^ Used to signal timeouts
}
makeLenses ''Dispatch

-- | Create a new 'Dispatch' environment
mkDispatch' :: MonadUnliftIO m => m KeyEvent -> m Dispatch
mkDispatch' s = withRunInIO $ \u -> do
mkDispatch' :: MonadUnliftIO m => m KeyEvent -> TMVar Unique -> m Dispatch
mkDispatch' s itr = withRunInIO $ \u -> do
Comment on lines +69 to +70
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

As mentioned above I would change the order of parameters like this and also for mkDispatch, mkHooks, ... (and maybe Dispatch, ...)

Suggested change
mkDispatch' :: MonadUnliftIO m => m KeyEvent -> TMVar Unique -> m Dispatch
mkDispatch' s itr = withRunInIO $ \u -> do
mkDispatch' :: MonadUnliftIO m => TMVar Unique -> m KeyEvent -> m Dispatch
mkDispatch' itr s = withRunInIO $ \u -> do

rpc <- atomically $ newEmptyTMVar
rrb <- atomically $ newTVar Seq.empty
pure $ Dispatch (u s) rpc rrb
pure $ Dispatch (u s) rpc rrb itr

-- | Create a new 'Dispatch' environment in a 'ContT' environment
mkDispatch :: MonadUnliftIO m => m KeyEvent -> ContT r m Dispatch
mkDispatch = lift . mkDispatch'
mkDispatch :: MonadUnliftIO m => m KeyEvent -> TMVar Unique -> ContT r m Dispatch
mkDispatch s itr = lift (mkDispatch' s itr)

--------------------------------------------------------------------------------
-- $op
Expand All @@ -82,7 +85,7 @@ mkDispatch = lift . mkDispatch'
-- 1. The next item to be rerun
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I would add the timer in the comments of what is happening.

-- 2. A new item read from the OS
-- 3. Pausing until either 1. or 2. triggers
pull :: (HasLogFunc e) => Dispatch -> RIO e KeyEvent
pull :: (HasLogFunc e) => Dispatch -> RIO e WrappedEvent
pull d = do
-- Check for an unfinished read attempt started previously. If it exists,
-- fetch it, otherwise, start a new read attempt.
Expand All @@ -92,14 +95,22 @@ pull d = do

-- First try reading from the rerunBuf, or failing that, from the
-- read-process. If both fail we enter an STM race.
atomically ((Left <$> popRerun) `orElse` (Right <$> waitSTM a)) >>= \case
-- If we take from the rerunBuf, put the running read-process back in place
Left e' -> do
logDebug $ "\n" <> display (T.replicate 80 "-")
<> "\nRerunning event: " <> display e'
atomically $ putTMVar (d^.readProc) a
pure e'
Right e' -> pure e'
atomically (
(Left <$> takeTMVar (d^.injectTmr))
`orElse`(Right . Left <$> popRerun)
`orElse` (Right . Right <$> waitSTM a)
) >>= \case
-- If there's a timer, pass it through
Left t -> do
atomically $ putTMVar (d^.readProc) a
pure (WrappedTag t)
-- If we take from the rerunBuf, put the running read-process back in place
Right (Left e') -> do
logDebug $ "\n" <> display (T.replicate 80 "-")
<> "\nRerunning event: " <> display e'
atomically $ putTMVar (d^.readProc) a
pure e'
Right (Right e') -> pure (WrappedKeyEvent NoCatch e')

where
-- Pop the head off the rerun-buffer (or 'retrySTM' if empty)
Expand All @@ -110,5 +121,5 @@ pull d = do
pure e

-- | Add a list of elements to be rerun.
rerun :: (HasLogFunc e) => Dispatch -> [KeyEvent] -> RIO e ()
rerun :: (HasLogFunc e) => Dispatch -> [WrappedEvent] -> RIO e ()
rerun d es = atomically $ modifyTVar (d^.rerunBuf) (>< Seq.fromList es)
Loading
0