diff --git a/c_src/keyio_win.c b/c_src/keyio_win.c --- a/c_src/keyio_win.c +++ b/c_src/keyio_win.c @@ -41,6 +41,17 @@ exit(dw); } +// OEM Specific keys should probably not be captured as it's unclear wether +// they have the same effect if we reemit them. +bool isOEMSpecific(int nCode) { + return 0x92 <= nCode && nCode <= 0x96 // OEM specific + || 0xE1 == nCode // OEM Specific + || 0xE3 <= nCode && nCode <= 0xE4 // OEM Specific + || 0xE6 == nCode // OEM Specific + || 0xE9 <= nCode && nCode <= 0xF5 // OEM Specific + ; +} + // Callback we insert into windows that writes events to pipe LRESULT CALLBACK keyHandler(int nCode, WPARAM wParam, LPARAM lParam) { @@ -48,9 +59,14 @@ KBDLLHOOKSTRUCT* e = (KBDLLHOOKSTRUCT*)(lParam); // Skip processing if nCode is 0 or this is an injected event - if (nCode < 0 || e->flags & LLKHF_INJECTED) { + if (nCode < 0 || e->flags & LLKHF_INJECTED || isOEMSpecific(nCode)) { return CallNextHookEx(hookHandle, nCode, wParam, lParam); }; + // Also skip OEM specific keys (see comment on 'isOEMSpecific'). + if (isOEMSpecific(nCode)) { + fprintf(stderr, "Skipping unnamed OEM key\n"); + return CallNextHookEx(hookHandle, nCode, wParam, lParam); + }; // Create the KEY_EVENT matching the current event ACTION type; @@ -80,27 +96,29 @@ // Write the event to the pipe DWORD dwWritten; WriteFile(writePipe, &ev, sizeof(ev), &dwWritten, NULL); - return 1; // Block others from handeling. Since they should only use KMonad output + return 1; // Block others from handling. Since they should only use KMonad output } // Read an event from the pipe and write it to the provided pointer -void wait_key(struct KeyEvent* e) +DWORD wait_key(struct KeyEvent* e, DWORD* dwRead) { - DWORD dwRead; - ReadFile(readPipe, e, sizeof(e), &dwRead, NULL); - //printf("receiving: %d\n", e->keycode); - return; + bool ok = ReadFile(readPipe, e, sizeof(e), dwRead, NULL); + return ok ? 0 : GetLastError(); } +// Initialize the pipe used to communicate between the low-level-hook and the haskell API +void init_pipe() +{ + // Create the pipe, error on failure + if ( !CreatePipe(&readPipe, &writePipe, NULL, 0) ) last_error(); +} + // Insert the keyboard hook and start the monitoring process void grab_kb() { // Insert the hook, error on failure hookHandle = SetWindowsHookEx(WH_KEYBOARD_LL, keyHandler, NULL, 0); if (hookHandle == NULL) last_error(); - - // Create the pipe, error on failure - if ( !CreatePipe(&readPipe, &writePipe, NULL, 0) ) last_error(); // This *never* triggers, but if not included the program doesn't run..? MSG msg; diff --git a/c_src/mac/dext.cpp b/c_src/mac/dext.cpp --- a/c_src/mac/dext.cpp +++ b/c_src/mac/dext.cpp @@ -23,10 +23,13 @@ /**/ client->connected.connect([copy] { std::cout << "connected" << std::endl; - copy->async_virtual_hid_keyboard_initialize(pqrs::hid::country_code::us); + pqrs::karabiner::driverkit::virtual_hid_device_service::virtual_hid_keyboard_parameters parameters; + parameters.set_country_code(pqrs::hid::country_code::us); + copy->async_virtual_hid_keyboard_initialize(parameters); }); client->connect_failed.connect([](auto&& error_code) { std::cout << "connect_failed " << error_code << std::endl; + std::cout << "You may need to start Karabiner" << std::endl; }); client->closed.connect([] { std::cout << "closed" << std::endl; diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -6,11 +6,48 @@ ## Unreleased +### Breaking + ### Added ### Changed ### Fixed + +## 0.4.5 – 2026-05-03 + +### Breaking + +- Update Karabiner-DriverKit to 6.8.0 (#937, #1025) + You will now need to [start the server yourself](doc/installation.md#starting-the-dext-daemon). +- With systemd v258 udevd ignores `GROUP=` setting with a non-system group. + If you followed the [FAQ entry: How do I get Uinput permissions?](doc/faq.md#q-how-do-i-get-uinput-permissions) + and created the `uinput` group delete the group (`sudo groupdel uinput`) + and create a new group with the user added to it (see FAQ entry). + +### Added + +- `XX` may be used in `defsrc` as a placeholder button. + Buttons binded to it will never trigger. (#992) +- Using `:ignore-missing` in `device-file` you can wait for the device to be + connected before starting and allow reconnecting in case of disconnect. (#1017) +- Windows OEM Specific keycodes without name are now ignored. (#1043) +- Added Windows only key `VKOEM8`. (#1043) + +### Changed +- Aliases can now refer to later aliases instead of just earlier ones. (#992) +- Aliases can now be used in `defsrc` if they are a keycode (#992) +- Failure to grab or release the keyboard are now accompanied with the os error on Linux (#1017) + +### Fixed + +- Fixed excessive backtracking in the parser leading to unreadable errors (#985) +- Fixed the `c_src/mac/list-keyboards.c` on Apple SDK < 12.0 (#987) +- Fixed random crash on startup on windows. (#1005) +- Fixed nested `implicit-around`s in `tap-macro`s are inconsistent. (#1012) +- Fixed `sticky-key` as tap in `tap-hold` style buttons. (#1014) +- Fixed nix system variable renamed deprecation warning. (#1046) +- Fixed race condition when key event arrives while timeout is processed (#1049) ## 0.4.4 – 2025-04-11 diff --git a/doc/faq.md b/doc/faq.md new file mode 100644 --- /dev/null +++ b/doc/faq.md @@ -0,0 +1,336 @@ + +**Table of Contents** + +- [Linux](#linux) + - [Q: How do I get Uinput permissions?](#q-how-do-i-get-uinput-permissions) + - [Q: How do I know which event-file corresponds to my keyboard?](#q-how-do-i-know-which-event-file-corresponds-to-my-keyboard) + - [Q: `/dev/input` does not exist?](#q-dev-input-does-not-exist) + - [Q: How do I emit Hyper_L?](#q-how-do-i-emit-hyper_l) + - [Q: How does Unicode entry work?](#q-how-does-unicode-entry-work) + - [Q: How do I use the same layout definition for different keyboards?](#q-how-do-i-use-the-same-layout-definition-for-different-keyboards) +- [Windows](#windows) + - [Q: How do I start KMonad?](#q-how-do-i-start-kmonad) + - [Using the command-line](#using-the-command-line) + - [Making a launcher](#making-a-launcher) +- [Mac](#mac) + - [Q: How to use the special features printed on Apple function keys?](#q-how-to-use-the-special-features-printed-on-apple-function-keys) +- [General](#general) + - [Q: Why can't I remap certain (non US) buttons?](#q-why-cant-i-remap-certain-non-us-buttons) + - [Q: How can I remap the Copilot key / other hardware macro keys?](#q-how-can-i-remap-the-copilot-key--other-hardware-macro-keys) + - [Q: Why don't shifted symbols work (sometimes)?](#q-why-dont-shifted-symbols-work-sometimes) + - [Q: What does `Ta`, `Pa` and `Ra` stand for?](#q-what-does-ta-pa-and-ra-stand-for) + - [Q: Why doesn't the 'Print' keycode work for my print screen button?](#q-why-doesnt-the-print-keycode-work-for-my-print-screen-button) + - [Q: Why can't I remap the Fn key on my laptop?](#q-why-cant-i-remap-the-fn-key-on-my-laptop) + - [Q: Why do some key combination not work?](#q-why-do-some-key-combination-not-work) + - [Q: When I run KMonad I get error `Not available under this OS`](#q-when-i-run-kmonad-i-get-error-not-available-under-this-os) + - [Q: Where can I find a list of keycodes which can be used in KMonad?](#q-where-can-i-find-a-list-of-keycodes-which-can-be-used-in-kmonad) + - [Q: How do I provide the input and output from the command line?](#q-how-do-i-provide-the-input-and-output-from-the-command-line) + + + +## Linux + +### Q: How do I get Uinput permissions? + +A: In Linux KMonad needs to be able to access the `input` and `uinput` subsystem to inject +events. To do this, your user needs to have permissions. To achieve this, take +the following steps: + +If the `uinput` group does not exist, create a new group with: + +1. Make sure the `uinput` group exists + +``` shell +sudo groupadd --system uinput +``` + +2. Add your user to the `input` and the `uinput` group: +``` shell +sudo usermod -aG input,uinput username +``` + +Make sure that it's effective by running `groups`. You might have to logout and login. +In some cases a reboot may also be required. + +3. Make sure the uinput device file has the right permissions: +Add a udev rule (in either `/etc/udev/rules.d` or `/lib/udev/rules.d`) with the +following content: +```shell +KERNEL=="uinput", MODE="0660", GROUP="uinput", OPTIONS+="static_node=uinput" +``` + +You will need to restart `udevd` via +```shell +sudo systemctl restart systemd-udevd.service +``` +to get the new permissions. + +4. Make sure the `uinput` drivers are loaded. +You will probably have to run this command whenever you start `kmonad` for the first time. +``` shell +sudo modprobe uinput +``` + + +### Q: How do I know which event-file corresponds to my keyboard? + +A: By far the best solution is to use the keyboard devices listed +under `/dev/input/by-id`. In some case, you could also try +`/dev/input/by-path`. If you can't figure out which file just by +the filenames, the `evtest` program is very helpful. + +#### Q: `/dev/input` does not exist? + +A: This may be due to the kernel module `evdev` not being loaded. +Try to run `sudo modprobe evdev`. + +### Q: How do I emit Hyper_L? + +A: `Hyper_L` is not a core Linux keycode, but is X11 specific instead. KMonad +tries to stay as close to the kernel as possible, so you can run it on other +OSes or without X11. If you want `Hyper_L` to work, you have to make sure that +X11 lines up well with KMonad. See [this issue](https://github.com/kmonad/kmonad/issues/22) for more explanation. + +### Q: How does Unicode entry work? + +A: Unicode entry works via X11 compose-key sequences. For information on how to +configure KMonad to make use of this, please see [the tutorial](../keymap/tutorial.kbd). + +### Q: How do I use the same layout definition for different keyboards? + +A: +Create a layout file with an environment variable instead of `device-file` option, i.e. `kmonad.kbd`. + +``` +(defcfg + input (device-file "$KBD_DEV") + output (uinput-sink "KMonad kbd") + fallthrough true + cmp-seq lctl +) +``` + +Use following shell script to list available keyboard devices and select one of them. You will need +[fzf](https://github.com/junegunn/fzf) and kmonad available in your `$PATH`. + +```bash +#!/bin/bash + +KBD_DEV=$(find /dev/input/by-path/*kbd* | fzf) +export KBD_DEV +KBDCFG=$(envsubst < kmonad.kbd) + +kmonad <(echo "$KBDCFG") +``` + + +## Windows + +### Q: How do I start KMonad? + +A: This might be confusing if you are used to using a GUI and clicking on +things. Double clicking KMonad will look like it does nothing. KMonad is a +command-line utility, so, to run it you need to: + +#### Using the command-line + +1. Start a 'Command Prompt' (no need for 'as administrator') + +2. 'cd' to where you've stored KMonad, like this: +```powershell +cd "C:\Users\david\Desktop\Just an Example" +``` +NOTE: The double-tick marks around the path let you easily use directories with +spaces in the names. + +3. Run the `kmonad` command (make sure the name matches exactly, so for the + `0.4.0` version, that would be: `kmonad-0.4.0-windows.exe`, alternatively, + rename the `kmonad` file to whatever you like and use that name). Depending + on how you call it different things happen. + +This will print the help and do nothing. +```powershell +kmonad.exe +``` + +This will start KMonad with the provided configuration file: +```powershell +kmonad.exe my_config.kbd +``` + +If the `my_config.cfg` file is not in the same directory as `kmonad`, you will +need to specify the full path to this file. (See [the +tutorial](/keymap/tutorial.kbd) for more information on how to write a +configuration. + +```powershell +kmonad.exe C:\Users\david\Documents\my_config.kbd +``` + +You can even launch KMonad from anywhere (without having to do step 2. first) if +you use the full path for KMonad and the config file like this: +```powershell +"C:\Users\david\Desktop\Just an Example\kmonad.exe" C:\Users\david\Documents\my_config.kbd +``` + +If you want to really see what is happening on the inside of KMonad as it runs, +consider adding the `--log-level debug` flag like this: +```powershell +C:\pth\to\kmonad.exe some_config.kbd --log-level debug +``` + +This will cause KMonad to print out more information about what it is doing +moment to moment (without affecting anything else). + +#### Making a launcher + +If you want to start KMonad at the click of a button, consider making a shortcut +using the 'New' > 'Shortcut' entry on the right-click menu (if you right-click +the Desktop). Just select 'KMonad' and give it a name. Afterwards, right click +the shortcut and select 'Properties'. This should put you in the 'Shortcut' tab +of the properties, here there is a field called 'Target'. This field is exactly +like the shell command we used above, so copy-paste the exact command you used +to start KMonad into 'Target', then click apply, and you should now have a +clickable KMonad launcher. + +## Mac + +### Q: How to use the special features printed on Apple function keys? + +A: By default, function keys on Apple keyboards trigger special features +(changing brightness, volume, etc.) when pressed alone, and act as traditional +function keys (F1, F2, etc.) when pressed with fn. Technically, when +F1 (e.g.) is pressed on an Apple keyboard, it sends the keycode +corresponding to F1; macOS then translates this keycode to a special feature +(depending on whether fn was pressed) in the [keyboard +driver](https://github.com/pqrs-org/Karabiner-VirtualHIDDevice/issues/1). But +`kmonad` intercepts key presses before this translation can occur, and it emits +keypresses through a driver of its own. Therefore macOS does not translate any +keypresses emitted by KMonad, and the checkbox labeled "Use F1, F2, etc. keys as +standard function keys" in `System Preferences` will have no effect on keyboards +modified by KMonad. + +However, we can simulate the default behavior of Apple keyboards by emitting +keycodes that correspond to the special features printed on the function +keys. See [keymap/template/apple.kbd](../keymap/template/apple.kbd) for an +example. + +## General + +### Q: Why can't I remap certain (non US) buttons? + +KMonad works prior to your OS keymapping taking affect. +It also uses the names taken from the standard US qwerty layout. + +If you were for example looking to remap an `ü` on a german qwertz keyboard +you would specify the letter that would be there in qwerty (`[`). + +This is of course also true for buttons which are in a different place. +On the german layout the `+` is reached without shift, while on US qwerty it's +on `S-=`. This means it's also not a valid keycode to specify in your `defsrc`. + +### Q: How can I remap the Copilot key / other hardware macro keys? + +By mapping the corresponding primary key (e.g. `f23`) and optionally +dropping modifiers with `(tap-hold-next 1 XX XX :timeout ...)`. + +For a detailed explanation, see [Hardware Macro Keys](hardware-macro-keys.md). + +### Q: Why don't shifted symbols work (sometimes)? + +A: In some environments, applications cannot process key events that are too fast. +If you notice this with `tap-macro` or shifted symbols (like `A`) you +may want to increase the value for `key-seq-delay` in `defcfg` to +something like `5`ms. +Here is the [original bug report](https://github.com/kmonad/kmonad/issues/820). + +### Q: What does `Ta`, `Pa` and `Ra` stand for? + +A: Those are part of a mini-language from the tutorial: + +- `Px` signifies the press of the button (or keycode) `x` +- `Rx` signifies the release of `x` +- `Tx` signifies the sequential and near instantaneous press and release of `x` +- `100` signifies 100ms passing without any action + +So for example when talking about buttons: + +- `Tesc Pa` is a tap of `Esc` and a press of `a` +- `P@a Tb R@a` is the alias `@a` pressed around the button `b` + +This language is useful since "tap" is normally a synonym for "press" +and this may lead to confusion in discussions and issues. + +### Q: Why doesn't the 'Print' keycode work for my print screen button? + +A: Because the keycode for "print screen" is actually 'SysReq' ("ssrq" or "sys") +for relatively interesting historical reasons. Have a look at [this +issue](https://github.com/kmonad/kmonad/issues/59) if you want more +information. + +### Q: Why can't I remap the Fn key on my laptop? + +A: You cannot. Many laptops have a Fn key that mimics some of the functionality +that KMonad tries to offer: it changes the mapping of certain keys, like +creating a numpad in the middle of the laptop keyboard. This remapping happens +in the hardware, before any event is ever registered with the operating system, +therefore KMonad has no way to 'get' at any of those events. This means that we +cannot remap them in any way. + +### Q: Why do some key combination not work? + +A: Some keyboards have a low +[rollover](https://en.wikipedia.org/wiki/Key_rollover). +It is the lowest maximum number of keys which can be pressed together and +handled correctly. Most keyboards then have to resort to blocking. +So If you have buttons which work fine individually but some special +combination does not, check whether you are affected by it. +To do this you can use an +[online rollover test](https://www.mechanical-keyboard.org/key-rollover-test/). +For correct results it is recommended to turn off KMonad +(Also note that some keys cannot be captured by a website). +Another option is to try a different keyboard. +The only other fix is circumvention. + +### Q: When I run KMonad I get error `Not available under this OS` + +A: This error occurs when there are OS-specific options in the used configuration +file. Usually this happens when you are on windows, try to run the tutorial +file and do not comment out or delete the Linux options in `defcfg` and +uncomment the Windows options. Nevertheless, this still can happen on other +operating systems, the error message changes slightly based on the operating +system (e.g. `Not available under this OS: LowLevelHookSource`, `Not available +under this OS: DeviceSource`), but they all start with `Not available under +this OS` and all have the same solution. + +TL;DR: Make sure the options in `defcfg` are for your operating system. + +### Q: Where can I find a list of keycodes which can be used in KMonad? + +A: List of keycodes can be found [here.](https://github.com/kmonad/kmonad/blob/master/src/KMonad/Keyboard/Keycode.hs) + +### Q: How do I provide the input and output from the command line? + +A: The input / output can be assigned via the `--input` / `--output` +(or the short style `-i` / `-o`) options to override the value in the `.kbd` +config file. These options take exactly the same assignment as the `input` / +`output` statement in the `defcfg` block. For example, if we have this line +in our `.kbd` config file: + +```clojure + input (device-file "/dev/input/by-id/my-kbd") +``` +We may instead call KMonad using: + +```bash +kmonad --input 'device-file "/dev/input/by-id/my-kbd"' my-kbd.kbd +``` + +Notice that single quotes are used to pack the `device-file` and the path into +one string, and also note that the path needs to be wrapped with double quotes. +If your shell does not support single quotes, you can also escape the double +quotes. + +```bash +kmonad --input "device-file \"/dev/input/by-id/my-kbd\"" my-kbd.kbd +``` diff --git a/doc/hardware-macro-keys.md b/doc/hardware-macro-keys.md new file mode 100644 --- /dev/null +++ b/doc/hardware-macro-keys.md @@ -0,0 +1,151 @@ +# Hardware Macro Keys + +Some keyboards have hardware macro keys. +They are especially common with laptops shipping with some advertised Microsoft features. + +Some of those keys include: + +| Key | Macro | Further References | +|------------------------|----------------------------------------|--------------------| +| [Copilot Key][copilot] | `Plmet Plsft Pf23` | #931 | +| [Office Key][office] | `Plmet Plalt Plctl Plsft` (unverified) | | + +[copilot]: https://www.microsoft.com/en-us/windows/learning-center/unlock-productivity-with-the-copilot-key +[office]: https://support.microsoft.com/en-us/office/using-the-office-key-df8665d3-761b-4a16-84b8-2cfb830e6aff + +## Remapping + +There are multiple methods of remapping such hardware macro keys: + +- [Mapping a primary key](#mapping-a-primary-key). + The other key events are kept, and we need a "primary" (e.g. F23 for Copilot). +- [Filtering out non-primary modifiers](#filtering-out-non-primary-modifiers). + This fixes the issue of the other key events being kept but still needs a "primary". +- [Multi-layer solution](#multi-layer-solution). + Slightly improves accuracy. Wanted if we don't have a "primary" key (e.g. with the Office key). +- [Filtered multi-layer solution](#filtered-multi-layer-solution). + Same improvements as [Filtering out non-primary modifiers](#filtering-out-non-primary-modifiers) + but without the need for a "primary" key. + +There are further improvements to the detection possible +which would increase the complexity in KMonad too much +or are not worth implementing. If you want to try yourself +against this problem, there are some improvement ideas +collected in the [Further Improvement Ideas](#further-improvement-ideas) +section. + +If you have improved on the remapping possibilities found +in this document (either via a different config setup or +via an external program), please open an issue / pr to +include it here. + +### Mapping a primary key + +This is quite simple. + +If you don't care about presses of the other events and can safely +map an entire key code from the sequence which can't +be pressed any other way, it can simply be done by mapping said key. + +For the Copilot key, it would look like the following: + +```clojure +(defsrc f23) +(deflayer base + #(c o p i l o t) +) +``` + +Though if you also want to map `lmet` or `lsft` without it being triggered by `copilot`, +or don't want to open some kind of menu when pressing `lmet`, you might want to see the next option. + +### Filtering out non-primary modifiers + +For the Copilot key (according to the testing of #931), there is a delay of 0.3ms between every key event. +So a button like `(tap-hold-next 1 XX XX :timeout lmet)` should safely drop the `lmet` if it is followed +by another key within one millisecond and let it through otherwise. + +In general, if we have a config like this: + +```clojure +(defsrc lsft lmet) +(deflayer base + #(d o n ' t) + #(p r e s s spc m e) +) +``` + +and want to map `copilot` we can change it to the following: + +```clojure +(defsrc lsft lmet f23) +(deflayer base + (tap-hold-next 1 XX XX :timeout #(d o n ' t)) + (tap-hold-next 1 XX XX :timeout #(p r e s s spc m e)) + #(c o p i l o t) +) +``` + +Technically `(tap-hold-next-press 1 lmet XX :timeout lmet)` would be more accurate since +we catch some more corner cases which are not Copilot key sequences. + +Via personal testing, I could only get to ~2ms of difference between two key presses (on a laptop) +when trying to press keys simultaneously. With more load or worse scheduling, this could conceivably +be in range of causing issues. + +### Multi-layer solution + +Since the key sequence is fixed, we can define layers to detect if we are inside such a sequence. +For the unconfirmed office key sequence of `Plmet Plalt Plctl Plsft`, a mapping such as the one below is conceivable: + +```clojure +(defsrc lmet lalt lctl lsft) +(deflayer base (layer-toggle lmet) _ _ _) +(deflayer lmet _ (layer-toggle lmet-lalt) _ _) +(deflayer lmet-lalt _ _ (layer-toggle lmet-lalt-lctl) _) +(deflayer lmet-lalt-lctl _ _ _ #(o f f i c e)) +``` + +Using named `defsrc` blocks can also help a lot if other keys are also remapped. + +### Filtered multi-layer solution + +The solutions from [Filtering out non-primary modifiers](#filtering-out-non-primary-modifiers) +and [Multi-layer solution](#multi-layer-solution) can be combined to a config allowing +mapping the modifier keys while also using layers to better determine the key: + +```clojure +(defsrc lmet lalt lctl lsft) +(deflayer base (tap-hold-next 1 XX (layer-toggle lmet) :timeout lmet) _ _ _) +... +``` + +## Further Improvement Ideas + +Here we outline some ideas one could implement in an external software +to better support remapping keys. + +### Differentiating keys after `tap-hold-next-press` + +(Using `copilot` as an example) + +The `tap-hold-next-press` approach from above drops the `lmet` independently of +whatever key comes after. It might be that under heavy load / bad scheduling +the delay between key events cannot be differentiated from a simultaneous press of +the user (personal testing reached ~2ms of delay). Only dropping the `lmet` event +if the next event is indeed an `lsft` (or `f23` if `lsft` has been pressed before) +could further reduce incorrect behaviour. + +### Guessing presses of modifiers while keys are held + +It seems the key repeat events differ for the `lsft` pressed by +`copilot` and by the user. This might be the case for other keys +(like the Office key) too. + +In the particular case of [#931](https://github.com/kmonad/kmonad/issues/931), +the Copilot key does not emit any key repeat events. `lsft` and `lmet` +do emit them after 300ms. So if they start while `f23` is pressed we can +determine that `lsft` / `lmet` (depending on the repeat event) was +pressed 300ms prior. + +Logs of this can be found in a [reply in #931 by @AlejandroMinaya](https://github.com/kmonad/kmonad/issues/931#issuecomment-4128757705). diff --git a/doc/quick-reference.md b/doc/quick-reference.md --- a/doc/quick-reference.md +++ b/doc/quick-reference.md @@ -44,7 +44,7 @@ - GNU/Linux: ```clojure - input (device-file "/dev/input/by-id/usb-04d9_daskeyboard-event-kbd") + input (device-file "/dev/input/by-id/usb-04d9_daskeyboard-event-kbd" :ignore-missing true) output (uinput-sink "My KMonad output") ``` diff --git a/keymap/tutorial.kbd b/keymap/tutorial.kbd --- a/keymap/tutorial.kbd +++ b/keymap/tutorial.kbd @@ -11,6 +11,10 @@ `defcfg` block (see below) you should be able to try out all the examples interactively. + Be careful. This document may be for a different version of KMonad than you + are using. All newer features are annotated with '(since x.y.z)' or + '(unreleased)'. + -------------------------------------------------------------------------- |# @@ -86,7 +90,7 @@ is a thing. For more information on the `cmd-button' function, see the section on Command buttons below. - - implicit-around: `around` (default), `around-only`, `around-when-alone` or `disabled` + - implicit-around (since 0.4.3): `around` (default), `around-only`, `around-when-alone` or `disabled` An implicit around may be in `A` or `_` but also in modded buttons (`S-a`). This changes how implicit arounds are handled, for more details see `around` @@ -134,6 +138,13 @@ NOTE: Any valid path to a device-file will work, but it is recommended to use the 'by-id' directory, since these names will not change if you replug the device. + + Specifying `:ignore-missing true` relaxes the requirement for the device to exist. + KMonad will then wait for it to connect and on disconnect will wait for it again + to reconnect. Without this or with `:ignore-missing false` KMonad will not start + if the device is not connected and will close as soon as it is disconnected. + (since 0.4.5) + If the '/dev/input' directory does for any reason not exists (i.e. maybe in the initramfs) it could be due to the 'evdev' kernel module not being loaded. @@ -191,7 +202,7 @@ (defcfg ;; For Linux - input (device-file "/dev/input/by-id/usb-04d9_daskeyboard-event-kbd") + input (device-file "/dev/input/by-id/usb-04d9_daskeyboard-event-kbd" :ignore-missing true) output (uinput-sink "My KMonad output" ;; To understand the importance of the following line, see the section on ;; Compose-key sequences at the near-bottom of this file. @@ -242,7 +253,7 @@ `defcfg` block though. There is also support for named `defsrc` blocks. They contain `:name ` - as the first argument in their definition. + as the first argument in their definition. (since 0.4.3) The layouting in the `defsrc` block is completely free, whitespace simply gets ignored. We strive to provide a name for every keycode that is no longer than @@ -250,6 +261,19 @@ quite nicely (although wider columns will allow for more informative aliases, see below). + You can also insert a placeholder button using `XX`. This is almost the same + as extra white space but you still need to bind a button to it. Said button is + never used. This is occasionally useful if you have buttons which don't emit a + keycode or have the same keycode multiple times on the same keyboard. In such + cases large chunks of whitespace may be more confusing then a placeholder + button. If you further want to specify which button this placeholder refers + to, you can use an alias (see below). (since 0.4.5) + + Instead of keycodes directly you can also use an alias (see `defalias`). + The syntax for aliases is the same as described in `deflayer`. Keep in mind + that buttons, which won't work if you place them in `defsrc` directly, will + also not work if you use them via an alias. (since 0.4.5) + Most keycodes should be obvious. If you are unsure, check './src/KMonad/Keyboard/Keycode.hs'. Every Keycode has a name corresponding to its Keycode name, but all lower-case and with the 'Key' prefix removed. There @@ -279,7 +303,9 @@ kp0 kp. ) +(defsrc :name with-aliases @foo @power) + #| -------------------------------------------------------------------------- Optional : `defalias` statements @@ -289,9 +315,8 @@ these buttons, to keep the actual `deflayer` statements orderly. A `defalias` can contain any number of aliases, and it can refer backwards or - forwards to layers without issue. The only sequencing that needs to be kept in - mind is that a `defalias` cannot refer forward to another `defalias` that is - not yet defined. + forwards (since 0.4.5) to layers or other aliases without issue. Though you may not create + cyclic aliases. Here we define a few aliases, but we will define more later. Notice that we try to only use 3 letter names for aliases. If that is not enough to be clear, @@ -303,6 +328,9 @@ (defalias num (layer-toggle numbers) ;; Bind num to a button that switches to a layer kil C-A-del ;; Bind kil to a button that Ctrl-Alt-deletes + power XX ;; Placeholder for power button of keyboard + foo @bar ;; An alias with a forward reference to another alias + bar a ) @@ -322,7 +350,7 @@ exactly how many entries are defined in the `defsrc` statement. Optionally you can add a `:source ` parameter after the name to map - a layer using a named `defsrc` block. + a layer using a named `defsrc` block. (since 0.4.3) You can also overwrite the option `implicit-around` for a layer by adding `:implicit-around `. @@ -454,13 +482,14 @@ There also exists some variants like `around-only` or `around-when-alone`. `around-only` also releases the outer button just before another button is pressed. If no other button has been pressed prior to it's release it releases - the inner than the outer button similarly to `around`. + the inner than the outer button similarly to `around`. (since 0.4.3) `around-when-alone` is another variant which works like `around-only` but represses the outer button when all other which have been pressed after - itself have been released. + itself have been released. (since 0.4.3) `around-implicit` is one of the above variants and is specified `defcfg` block. + (since 0.4.3) We have already seen other examples of modded buttons, \(, \), *, and +. There are no keycodes for these buttons in KMonad, but they are buttons. They simply @@ -538,7 +567,7 @@ sr (sticky-key 300 rsft)) #| -------------------------------------------------------------------------- - Optional: stepped buttons + Optional: stepped buttons (since 0.4.3) Stepped buttons are a bit out there. They allow you to define a button which does something different depending on how often you have pressed it @@ -623,6 +652,7 @@ `:delay` is while handling the button) If you use really long `tap-macro`s (like storing your email), you may experiment with a delay of `0` to have a more "paste-like" experience. + (since 0.4.4; previous versions had `0` as default) The `tap-macro-release` is like `tap-macro`, except that it waits to press the last button when the `tap-macro-release` @@ -716,8 +746,8 @@ an unusable state until a restart has occurred). It is perfectly possible to switch into a layer that you can never get out of. Or worse, you could theoretically have a layer full of only `XX`s and switch into that, rendering - your keyboard unusable until you somehow manage to kill KMonad (without using - your keyboard). + the configured keyboard unusable until you somehow manage to kill KMonad + (without using said keyboard). However, when handled well, `layer-switch` is very useful, letting you switch between 'modes' for your keyboard. I have a tiny keyboard with a weird keymap, @@ -924,6 +954,7 @@ It works just like `tap-next-press` except that after the timeout it will jump into holding-mode. The holding button for the timeout case can be swapped out just like `tap-hold-next` via a `:timeout-button ...` as the last argument. + (since 0.4.4) These increasingly stranger buttons are, I think, coming from the stubborn drive of some of my more eccentric (and I mean that in the most positive way) diff --git a/kmonad.cabal b/kmonad.cabal --- a/kmonad.cabal +++ b/kmonad.cabal @@ -2,7 +2,7 @@ name: kmonad category: Application -version: 0.4.4 +version: 0.4.5 synopsis: Advanced keyboard remapping utility author: David Janssen maintainer: janssen.dhj@gmail.com @@ -18,6 +18,8 @@ extra-doc-files: changelog.md + doc/faq.md + doc/hardware-macro-keys.md doc/quick-reference.md keymap/tutorial.kbd @@ -41,6 +43,7 @@ build-depends: base >= 4.12 && < 5 , cereal + , hashable -- , hspec , lens , megaparsec @@ -58,6 +61,7 @@ DeriveGeneric DeriveDataTypeable DeriveTraversable + ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies @@ -71,6 +75,7 @@ RankNTypes TemplateHaskell TupleSections + TypeApplications TypeFamilies autogen-modules: @@ -91,6 +96,7 @@ KMonad.Model.BEnv KMonad.Model.Button KMonad.Model.Dispatch + KMonad.Model.EventSrc KMonad.Model.Hooks KMonad.Model.Keymap KMonad.Model.Sluice @@ -121,7 +127,8 @@ c-sources: c_src/keyio.c build-depends: - unix + , unix + , hinotify if os(windows) exposed-modules: diff --git a/src/KMonad/App/Main.hs b/src/KMonad/App/Main.hs --- a/src/KMonad/App/Main.hs +++ b/src/KMonad/App/Main.hs @@ -25,7 +25,7 @@ import KMonad.Model - +import KMonad.Model.EventSrc import qualified KMonad.Model.Dispatch as Dp import qualified KMonad.Model.Hooks as Hs import qualified KMonad.Model.Sluice as Sl @@ -85,7 +85,7 @@ src <- using $ cfg^.keySourceDev -- Initialize the pull-chain components - dsp <- Dp.mkDispatch $ awaitKey src + dsp <- Dp.mkDispatch =<< pullToESrc "receiver_proc" (awaitKey src) ihk <- Hs.mkHooks $ Dp.pull dsp slc <- Sl.mkSluice $ Hs.pull ihk @@ -94,10 +94,13 @@ -- Initialize output components otv <- lift newEmptyTMVarIO - ohk <- Hs.mkHooks . atomically . takeTMVar $ otv + ohk <- Hs.mkHooks $ toESrc otv -- Setup thread to read from outHooks and emit to keysink launch_ "emitter_proc" $ do + -- FIXME: should take output of outHooks + -- but since 'OutputHook's are never used this doesn't matter. + -- Furthermore calling 'pull' on outHooks to cause stepping is needed. e <- atomically . takeTMVar $ otv emitKey snk e -- If delay is specified, wait for it @@ -164,8 +167,13 @@ -- 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 +loop = forever $ view sluice >>= pullESrc . Sl.pull >>= \case e | e^.switch == Press -> pressKey $ e^.keycode + | e^.switch == Release -> do + view keymap >>= flip Km.lookupKey (e^.keycode) >>= \case + Nothing -> pure () -- happens frequently with `fallthrough false` + -- Not perfect, since a layer change might have happened but better than nothing + Just _ -> logWarn "Unhandled release of mapped key" _ -> pure () -- | Run KMonad using the provided configuration diff --git a/src/KMonad/App/Types.hs b/src/KMonad/App/Types.hs --- a/src/KMonad/App/Types.hs +++ b/src/KMonad/App/Types.hs @@ -104,7 +104,9 @@ instance (HasAppEnv e, HasAppCfg e, HasLogFunc e) => MonadKIO (RIO e) where -- Emitting with the keysink - emit e = view outVar >>= atomically . flip putTMVar e + emit e = do + logDebug $ "Scheduling emit: " <> display e + view outVar >>= atomically . flip putTMVar e -- emit e = view keySink >>= flip emitKey e -- Pausing is a simple IO action diff --git a/src/KMonad/Args/Cmd.hs b/src/KMonad/Args/Cmd.hs --- a/src/KMonad/Args/Cmd.hs +++ b/src/KMonad/Args/Cmd.hs @@ -17,12 +17,12 @@ where import KMonad.Prelude hiding (try) -import KMonad.Args.Parser (itokens, keywordButtons, noKeywordButtons, otokens, symbol, numP, implArndButtons) import KMonad.Args.TH (gitHash) import KMonad.Args.Types (DefSetting(..)) import KMonad.Util import Paths_kmonad (version) +import qualified KMonad.Args.Parser as P import qualified KMonad.Parsing as M -- [M]egaparsec functionality import Data.Version (showVersion) @@ -137,8 +137,7 @@ -- | Key to use for compose-key sequences cmpSeqP :: Parser (Maybe DefSetting) -cmpSeqP = optional $ SCmpSeq <$> option - (tokenParser keywordButtons <|> megaReadM (M.choice noKeywordButtons)) +cmpSeqP = optional $ SCmpSeq <$> option (megaReadM $ P.buttonP' True) ( long "cmp-seq" <> short 's' <> metavar "BUTTON" @@ -147,7 +146,7 @@ -- | Specify compose sequence key delays. cmpSeqDelayP :: Parser (Maybe DefSetting) -cmpSeqDelayP = optional $ SCmpSeqDelay <$> option (fromIntegral <$> megaReadM numP) +cmpSeqDelayP = optional $ SCmpSeqDelay <$> option (megaReadM P.numP) ( long "cmp-seq-delay" <> metavar "TIME" <> help "How many ms to wait between each key of a compose sequence" @@ -155,7 +154,7 @@ -- | Specify key event output delays. keySeqDelayP :: Parser (Maybe DefSetting) -keySeqDelayP = optional $ SKeySeqDelay <$> option (fromIntegral <$> megaReadM numP) +keySeqDelayP = optional $ SKeySeqDelay <$> option (megaReadM P.numP) ( long "key-seq-delay" <> metavar "TIME" <> help "How many ms to wait between each key event outputted" @@ -163,8 +162,7 @@ -- | How to handle implicit `around`s implArndP :: Parser (Maybe DefSetting) -implArndP = optional $ SImplArnd <$> option - (maybeReader $ \x -> implArndButtons ^? each . filtered ((x ==) . unpack . view _1) . _2) +implArndP = optional $ SImplArnd <$> option (megaReadM P.implArndP) ( long "implicit-around" <> long "ia" <> metavar "AROUND" @@ -173,7 +171,7 @@ -- | Where to emit the output oTokenP :: Parser (Maybe DefSetting) -oTokenP = optional $ SOToken <$> option (tokenParser otokens) +oTokenP = optional $ SOToken <$> option (mkTokenP P.otokens) ( long "output" <> short 'o' <> metavar "OTOKEN" @@ -182,7 +180,7 @@ -- | How to capture the keyboard input iTokenP :: Parser (Maybe DefSetting) -iTokenP = optional $ SIToken <$> option (tokenParser itokens) +iTokenP = optional $ SIToken <$> option (mkTokenP P.itokens) ( long "input" <> short 'i' <> metavar "ITOKEN" @@ -191,7 +189,7 @@ -- | Parse a flag that disables auto-releasing the release of enter startDelayP :: Parser Milliseconds -startDelayP = option (fromIntegral <$> megaReadM numP) +startDelayP = option (fromIntegral <$> megaReadM P.numP) ( long "start-delay" <> short 'w' <> value 300 @@ -201,8 +199,8 @@ -- | Transform a bunch of tokens of the form @(Keyword, Parser)@ into an -- optparse-applicative parser -tokenParser :: [(Text, M.Parser a)] -> ReadM a -tokenParser = megaReadM . M.choice . map (M.try . uncurry ((*>) . symbol)) +mkTokenP :: [(Text, M.Parser a)] -> ReadM a +mkTokenP = megaReadM . P.mkTokenP' True -- | Megaparsec <--> optparse-applicative interface megaReadM :: M.Parser a -> ReadM a diff --git a/src/KMonad/Args/Joiner.hs b/src/KMonad/Args/Joiner.hs --- a/src/KMonad/Args/Joiner.hs +++ b/src/KMonad/Args/Joiner.hs @@ -25,6 +25,7 @@ where import KMonad.Prelude hiding (uncons) +import KMonad.Util import KMonad.Args.Types @@ -50,9 +51,10 @@ import Control.Monad.Except -import RIO.List (headMaybe, intersperse, uncons, sort, group) +import RIO.List (headMaybe, intersperse, uncons, sort, group, find) import RIO.Partial (fromJust) import qualified KMonad.Util.LayerStack as L +import qualified RIO.NonEmpty as NE import qualified RIO.HashMap as M import qualified RIO.Text as T @@ -64,6 +66,7 @@ = DuplicateBlock Text | MissingBlock Text | DuplicateAlias Text + | CyclicAlias Text | DuplicateLayer Text | DuplicateSource (Maybe Text) | DuplicateKeyInSource (Maybe Text) [Keycode] @@ -78,12 +81,14 @@ | NestedTrans | InvalidComposeKey | LengthMismatch Text Int Int + | NotAKeycode DefButton instance Show JoinError where show e = case e of DuplicateBlock t -> "Encountered duplicate block of type: " <> T.unpack t MissingBlock t -> "Missing at least 1 block of type: " <> T.unpack t DuplicateAlias t -> "Multiple aliases of the same name: " <> T.unpack t + CyclicAlias t -> "Aliases references itself in a loop: " <> T.unpack t DuplicateLayer t -> "Multiple layers of the same name: " <> T.unpack t DuplicateSource t -> case t of Just t -> "Multiple sources of the same name: " <> T.unpack t @@ -101,12 +106,13 @@ DuplicateLayerSetting t s -> "Duplicate setting in 'deflayer '" <> T.unpack t <> "': " <> T.unpack s InvalidOS t -> "Not available under this OS: " <> T.unpack t ImplArndDisabled -> "Implicit around via `A` or `S-a` are disabled in your config" - NestedTrans -> "Encountered 'Transparent' ouside of top-level layer" + NestedTrans -> "Encountered 'Transparent' outside of top-level layer" InvalidComposeKey -> "Encountered invalid button as Compose key" LengthMismatch t l s -> mconcat [ "Mismatch between length of 'defsrc' and deflayer <", T.unpack t, ">\n" , "Source length: ", show s, "\n" , "Layer length: ", show l ] + NotAKeycode b -> "Encountered non keycode button in 'defsrc': " <> show b instance Exception JoinError @@ -239,8 +245,8 @@ cfg <- oneBlock "defcfg" _KDefCfg case onlyOne . extract _SOToken $ cfg of Right o -> pickOutput o - Left None -> throwError $ MissingSetting "input" - Left Duplicate -> throwError $ DuplicateSetting "input" + Left None -> throwError $ MissingSetting "output" + Left Duplicate -> throwError $ DuplicateSetting "output" -- | Extract the fallthrough setting getFT :: J Bool @@ -284,7 +290,7 @@ -- | The Linux correspondence between IToken and actual code pickInput :: IToken -> J (LogFunc -> IO (Acquire KeySource)) -pickInput (KDeviceSource f) = pure $ runLF (deviceSource64 f) +pickInput (KDeviceSource f im) = pure $ runLF (deviceSource64 f im) pickInput KLowLevelHookSource = throwError $ InvalidOS "LowLevelHookSource" pickInput (KIOKitSource _) = throwError $ InvalidOS "IOKitSource" @@ -303,7 +309,7 @@ -- | The Windows correspondence between IToken and actual code pickInput :: IToken -> J (LogFunc -> IO (Acquire KeySource)) pickInput KLowLevelHookSource = pure $ runLF llHook -pickInput (KDeviceSource _) = throwError $ InvalidOS "DeviceSource" +pickInput (KDeviceSource _ _) = throwError $ InvalidOS "DeviceSource" pickInput (KIOKitSource _) = throwError $ InvalidOS "IOKitSource" -- | The Windows correspondence between OToken and actual code @@ -319,7 +325,7 @@ -- | The Mac correspondence between IToken and actual code pickInput :: IToken -> J (LogFunc -> IO (Acquire KeySource)) pickInput (KIOKitSource name) = pure $ runLF (iokitSource (T.unpack <$> name)) -pickInput (KDeviceSource _) = throwError $ InvalidOS "DeviceSource" +pickInput (KDeviceSource _ _) = throwError $ InvalidOS "DeviceSource" pickInput KLowLevelHookSource = throwError $ InvalidOS "LowLevelHookSource" -- | The Mac correspondence between OToken and actual code @@ -333,18 +339,32 @@ -------------------------------------------------------------------------------- -- $als -type Aliases = M.HashMap Text Button +type Aliases = M.HashMap Text DefButton type LNames = [Text] -- | Build up a hashmap of text to button mappings -- --- Aliases can refer back to buttons that occured before. -joinAliases :: LNames -> [DefAlias] -> J Aliases -joinAliases ns als = foldM f M.empty $ concat als - where f mp (t, b) = if t `M.member` mp - then throwError $ DuplicateAlias t - else flip (M.insert t) mp <$> unnest (joinButton ns mp b) +-- Aliases can refer back to other aliases. +joinAliases :: [DefAlias] -> J Aliases +joinAliases als = do + let als' = concat als + case find (not . null . NE.tail) $ NE.groupAllWith fst als' of + Nothing -> pure () + Just ((t, _) :| _) -> throwError $ DuplicateAlias t + M.traverseWithKey =<< go $ M.fromList als' + where + go mp t b@(KRef t') + | t == t' = throwError $ CyclicAlias t + | otherwise = withDerefAlias mp (go mp t) b + go _ _ b = pure b + +withDerefAlias :: Aliases -> (DefButton -> J a) -> DefButton -> J a +withDerefAlias als f (KRef t) = case M.lookup t als of + Just b -> f b + Nothing -> throwError $ MissingAlias t +withDerefAlias _ f b = f b + -------------------------------------------------------------------------------- -- $but @@ -371,9 +391,7 @@ isps l = traverse go . maybe l ((`intersperse` l) . KPause . fi) in \case -- Variable dereference - KRef t -> case M.lookup t als of - Nothing -> throwError $ MissingAlias t - Just b -> ret b + b@(KRef _) -> withDerefAlias als (joinButton ns als) b -- Various simple buttons KEmit c -> ret $ emitB c @@ -439,20 +457,24 @@ -------------------------------------------------------------------------------- -- $src -type Sources = M.HashMap (Maybe Text) DefSrc +type Sources = M.HashMap (Maybe Text) [Maybe Keycode] -- | Build up a hashmap of text to source mappings. -joinSources :: [DefSrc] -> J Sources -joinSources = foldM joiner mempty +joinSources :: Aliases -> [DefSrc] -> J Sources +joinSources als = foldM joiner mempty where joiner :: Sources -> DefSrc -> J Sources - joiner sources src@DefSrc{ _srcName = n, _keycodes = ks } + joiner sources DefSrc{ _srcName = n, _keycodes = ks } | n `M.member` sources = throwError $ DuplicateSource n - | not (null dups) = throwError $ DuplicateKeyInSource n dups - | otherwise = pure $ M.insert n src sources + | otherwise = do + ks' <- for ks $ withDerefAlias als joinKeycode + let dups = NE.head <$> duplicatesWith id (toList =<< ks') + unless (null dups) $ throwError $ DuplicateKeyInSource n dups + pure $ M.insert n ks' sources where - dups :: [Keycode] - dups = concatMap (take 1) . filter ((> 1) . length) . group . sort $ ks + joinKeycode (KEmit k) = pure $ Just k + joinKeycode KBlock = pure Nothing + joinKeycode b = throwError $ NotAKeycode b -------------------------------------------------------------------------------- -- $kmap @@ -465,8 +487,8 @@ joinKeymap srcs als lys = do let f acc x = if x `elem` acc then throwError $ DuplicateLayer x else pure (x:acc) nms <- foldM f [] $ map _layerName lys -- Extract all names - als' <- joinAliases nms als -- Join aliases into 1 hashmap - srcs' <- joinSources srcs -- Join all sources into 1 hashmap + als' <- joinAliases als -- Join aliases into 1 hashmap + srcs' <- joinSources als' srcs -- Join all sources into 1 hashmap lys' <- mapM (joinLayer als' nms srcs') lys -- Join all layers -- Return the layerstack and the name of the first layer pure (L.mkLayerStack lys', _layerName . fromJust . headMaybe $ lys) @@ -484,16 +506,18 @@ implAround <- getImplAround l src <- case M.lookup assocSrc srcs of - Just src -> pure $ src^.keycodes + Just src -> pure src Nothing -> throwError $ MissingSource assocSrc -- Ensure length-match between src and buttons when (length bs /= length src) $ throwError $ LengthMismatch n (length bs) (length src) -- Join each button and add it (filtering out KTrans) - let f acc (kc, b) = joinButton ns als b >>= \case - Nothing -> pure acc - Just b' -> pure $ (kc, b') : acc + let + f acc (Nothing, b) = joinButton ns als b $> acc + f acc (Just kc, b) = joinButton ns als b >>= \case + Nothing -> pure acc + Just b' -> pure $ (kc, b') : acc maybe id (local . set implArnd) implAround $ (n,) <$> foldM f [] (zip src bs) diff --git a/src/KMonad/Args/Parser.hs b/src/KMonad/Args/Parser.hs --- a/src/KMonad/Args/Parser.hs +++ b/src/KMonad/Args/Parser.hs @@ -22,13 +22,18 @@ -- * Building Parsers , symbol + , keyword + , sexpr , numP + , mkTokenP' -- * Parsers for Tokens and Buttons , otokens , itokens , buttonP + , buttonP' , implArndButtons + , implArndP , keywordButtons , noKeywordButtons ) @@ -44,14 +49,13 @@ import Data.Char -import RIO.List (sortBy, find) +import RIO.List (find) import qualified KMonad.Util.MultiMap as Q import qualified RIO.Text as T import qualified Text.Megaparsec.Char.Lexer as L - -------------------------------------------------------------------------------- -- $run @@ -79,58 +83,61 @@ symbol :: Text -> Parser () symbol = void . L.symbol sc --- | List of all characters that /end/ a word or sequence -terminators :: String -terminators = ")\"" +-- | A predicate to check if a characters /ends/ a word or sequence +isDelimiter :: Char -> Bool +isDelimiter c = elem @[] c "()\"" || isSpace c -terminatorP :: Parser Char -terminatorP = satisfy (`elem` terminators) +terminatorP :: Parser () +terminatorP = void (satisfy isDelimiter) <|> eof "end of token / delimiter" --- | Consume all chars until a space is encounterd +-- | Consume all chars until a delimiter is encounterd word :: Parser Text -word = T.pack <$> some (satisfy wordChar) - where wordChar c = not (isSpace c || c `elem` terminators) +word = lexeme . takeWhile1P Nothing $ not . isDelimiter --- | Run the parser IFF it is followed by a space, eof, or reserved char +-- | Run the parser IFF it is terminated terminated :: Parser a -> Parser a -terminated p = try $ p <* lookAhead (void spaceChar <|> eof <|> void terminatorP) +terminated p = try . lexeme $ p <* lookAhead terminatorP --- | Run the parser IFF it is not followed by a space or eof. -prefix :: Parser a -> Parser a -prefix p = try $ p <* notFollowedBy (void spaceChar <|> eof) +-- | Keywords are terminated symbols +keyword :: Text -> Parser () +keyword = terminated . void . string -- `string` intead of `symbol`, since `terminated` already does `lexeme` +keyword' :: Text -> a -> Parser a +keyword' k x = keyword k $> x + +-- | Run a parser designed to parse an inner S-expression. +sexpr :: Text -> Parser a -> Parser a +sexpr s p = keyword s *> p + -- | Create a parser that matches symbols to values and only consumes on match. fromNamed :: [(Text, a)] -> Parser a -fromNamed = choice . map mkOne . srt - where - -- | Sort descending by length of key and then alphabetically - srt :: [(Text, b)] -> [(Text, b)] - srt = sortBy . flip on fst $ \a b -> - case compare (T.length b) (T.length a) of - EQ -> compare a b - x -> x - - -- | Make a parser that matches a terminated symbol or fails - mkOne (s, x) = terminated (string s) $> x +fromNamed = choice . map (uncurry keyword') -- | Run a parser between 2 sets of parentheses paren :: Parser a -> Parser a paren = between (symbol "(") (symbol ")") --- | Run a parser between 2 sets of parentheses starting with a symbol -statement :: Text -> Parser a -> Parser a -statement s = paren . (symbol s *>) - -- | Run a parser that parser a bool value -bool :: Parser Bool -bool = (symbol "true" $> True) - <|> (symbol "false" $> False) +boolP :: Parser Bool +boolP = keyword' "true" True <|> keyword' "false" False --- | Parse a LISP-like keyword of the form @:keyword value@ -keywordP :: Text -> Parser p -> Parser p -keywordP kw p = symbol (":" <> kw) *> lexeme p - "Keyword " <> ":" <> T.unpack kw +-- | Parse an option argument of the form @:keyword value@ +optargP :: Text -> Parser p -> Parser p +optargP a p = keyword (":" <> a) *> p + "Keyword " <> ":" <> unpack a +optarg'P :: Text -> Parser p -> Parser (Maybe p) +optarg'P a = optional . optargP a + +-- | Parse based on a liste of sexpressions +mkTokenP :: [(Text, Parser a)] -> Parser a +mkTokenP = mkTokenP' False + +mkTokenP' :: Bool -> [(Text, Parser a)] -> Parser a +mkTokenP' toplevel tkns = paren' . choice $ uncurry sexpr <$> tkns + where + paren' = if toplevel then id else paren + -------------------------------------------------------------------------------- -- $elem -- @@ -142,18 +149,15 @@ -- | Parse an integer numP :: Parser Int -numP = L.decimal +numP = terminated L.decimal -- | Parse text with escaped characters between double quotes. textP :: Parser Text -textP = do - _ <- char '\"' - s <- manyTill L.charLiteral (char '\"') - pure . T.pack $ s +textP = lexeme $ char '"' >> pack <$> manyTill L.charLiteral (char '"') -- | Parse a variable reference derefP :: Parser Text -derefP = prefix (char '@') *> word +derefP = char '@' *> word -------------------------------------------------------------------------------- -- $cmb @@ -166,15 +170,15 @@ -- | Parse 0 or more KExpr's exprsP :: Parser [KExpr] -exprsP = lexeme . many $ lexeme exprP +exprsP = many exprP -- | Parse 1 KExpr exprP :: Parser KExpr exprP = paren . choice $ - [ try (symbol "defcfg") *> (KDefCfg <$> defcfgP) - , try (symbol "defsrc") *> (KDefSrc <$> defsrcP) - , try (symbol "deflayer") *> (KDefLayer <$> deflayerP) - , try (symbol "defalias") *> (KDefAlias <$> defaliasP) + [ sexpr "defcfg" $ KDefCfg <$> defcfgP + , sexpr "defsrc" $ KDefSrc <$> defsrcP + , sexpr "deflayer" $ KDefLayer <$> deflayerP + , sexpr "defalias" $ KDefAlias <$> defaliasP ] -------------------------------------------------------------------------------- @@ -182,10 +186,12 @@ -- -- All the various ways to refer to buttons +shifted :: Keycode -> DefButton +shifted = KAroundImplicit (KEmit KeyLeftShift) . KEmit + -- | Different ways to refer to shifted versions of keycodes shiftedNames :: [(Text, DefButton)] -shiftedNames = let f = second $ \kc -> KAroundImplicit (KEmit KeyLeftShift) (KEmit kc) in - map f $ cps <> num <> oth <> lng +shiftedNames = second shifted <$> cps <> num <> oth <> lng where cps = zip (map T.singleton ['A'..'Z']) [ KeyA, KeyB, KeyC, KeyD, KeyE, KeyF, KeyG, KeyH, KeyI, KeyJ, KeyK, KeyL, KeyM, @@ -202,15 +208,12 @@ buttonNames :: [(Text, DefButton)] buttonNames = shiftedNames <> escp <> util where - emitS c = KAroundImplicit (KEmit KeyLeftShift) (KEmit c) -- Escaped versions for reserved characters - escp = [ ("\\(", emitS Key9), ("\\)", emitS Key0) - , ("\\_", emitS KeyMinus), ("\\\\", KEmit KeyBackslash)] + escp = [ ("\\(", shifted Key9), ("\\)", shifted Key0) + , ("\\_", shifted KeyMinus), ("\\\\", KEmit KeyBackslash)] -- Extra names for useful buttons util = [ ("_", KTrans), ("XX", KBlock) - , ("lprn", emitS Key9), ("rprn", emitS Key0)] - - + , ("lprn", shifted Key9), ("rprn", shifted Key0)] -- | Parse "X-b" style modded-sequences moddedP :: Parser DefButton @@ -219,7 +222,7 @@ , ("A-", KeyLeftAlt), ("M-", KeyLeftMeta) , ("RS-", KeyRightShift), ("RC-", KeyRightCtrl) , ("RA-", KeyRightAlt), ("RM-", KeyRightMeta)] - prfx = choice $ map (\(t, p) -> prefix (string t) $> KEmit p) mods + prfx = choice $ map (\(t, p) -> try $ string t $> KEmit p) mods -- | Parse Pxxx as pauses (useful in macros) pauseP :: Parser DefButton @@ -228,90 +231,86 @@ -- | #()-syntax tap-macro rmTapMacroP :: Parser DefButton rmTapMacroP = - char '#' *> paren (KTapMacro <$> some buttonP - <*> optional (keywordP "delay" numP)) + try (symbol "#(") + >> KTapMacro <$> some buttonP <*> optarg'P "delay" numP + <* symbol ")" -- | Compose-key sequence composeSeqP :: Parser [DefButton] composeSeqP = do -- Lookup 1 character in the compose-seq list - c <- anySingle "special character" - s <- case find (\(_, c', _) -> c' == c) ssComposed of - Nothing -> fail "Unrecognized compose-char" - Just b -> pure $ b^._1 + s <- terminated $ do + c <- anySingle "special character" + case find (\(_, c', _) -> c' == c) ssComposed of + Nothing -> fail "Unrecognized compose-char" + Just b -> pure $ b^._1 -- If matching, parse a button-sequence from the stored text - case runParser (some buttonP) "" s of - -- Parse error never reaches the user. They simply get a message about an unexpected character. - Left _ -> fail "Could not parse compose sequence" + case runParser (some buttonP <* eof) "" s of + Left _ -> fail $ "Internal error: Could not parse compose sequence `" <> unpack s <> "`" Right b -> pure b -- | Parse a dead-key sequence as a `+` followed by some symbol deadkeySeqP :: Parser [DefButton] deadkeySeqP = do - _ <- prefix (char '+') - c <- satisfy (`elem` ("~'^`\"," :: String)) + c <- terminated $ char '+' *> satisfy (`elem` ("~'^`\"," :: String)) + case runParser buttonP "" (T.singleton c) of - Left _ -> fail "Could not parse deadkey sequence" + Left _ -> fail $ "Internal error: Could not parse deadkey sequence `" <> [c] <> "`" Right b -> pure [b] -- | Parse any button buttonP :: Parser DefButton -buttonP = (lexeme . choice . map try $ - map (uncurry statement) keywordButtons ++ noKeywordButtons - ) "button" +buttonP = buttonP' False +buttonP' :: Bool -> Parser DefButton +buttonP' toplevel = mkTokenP' toplevel keywordButtons <|> choice noKeywordButtons "button" + -- | Parsers for buttons that have a keyword at the start; the format is -- @(keyword, how to parse the token)@ keywordButtons :: [(Text, Parser DefButton)] keywordButtons = - [ ("around-implicit", KAroundImplicit <$> buttonP <*> buttonP) - , ("press-only" , KPressOnly <$> keycodeP) - , ("release-only" , KReleaseOnly <$> keycodeP) - , ("multi-tap" , KMultiTap <$> timed <*> buttonP) - , ("stepped" , KStepped <$> some buttonP) - , ("tap-hold" , KTapHold <$> lexeme numP <*> buttonP <*> buttonP) - , ("tap-hold-next" - , KTapHoldNext <$> lexeme numP <*> buttonP <*> buttonP - <*> optional (keywordP "timeout-button" buttonP)) - , ("tap-next-release" - , KTapNextRelease <$> buttonP <*> buttonP) - , ("tap-hold-next-release" - , KTapHoldNextRelease <$> lexeme numP <*> buttonP <*> buttonP - <*> optional (keywordP "timeout-button" buttonP)) - , ("tap-next-press" - , KTapNextPress <$> buttonP <*> buttonP) - , ("tap-hold-next-press" - , KTapHoldNextPress <$> lexeme numP <*> buttonP <*> buttonP - <*> optional (keywordP "timeout-button" buttonP)) - , ("tap-next" , KTapNext <$> buttonP <*> buttonP) - , ("layer-toggle" , KLayerToggle <$> lexeme word) - , ("momentary-layer" , KLayerToggle <$> lexeme word) - , ("layer-switch" , KLayerSwitch <$> lexeme word) - , ("permanent-layer" , KLayerSwitch <$> lexeme word) - , ("layer-add" , KLayerAdd <$> lexeme word) - , ("layer-rem" , KLayerRem <$> lexeme word) - , ("layer-delay" , KLayerDelay <$> lexeme numP <*> lexeme word) - , ("layer-next" , KLayerNext <$> lexeme word) - , ("around-next" , KAroundNext <$> buttonP) - , ("around-next-single", KAroundNextSingle <$> buttonP) - , ("before-after-next", KBeforeAfterNext <$> buttonP <*> buttonP) - , ("around-next-timeout", KAroundNextTimeout <$> lexeme numP <*> buttonP <*> buttonP) - , ("tap-macro" - , KTapMacro <$> lexeme (some buttonP) <*> optional (keywordP "delay" numP)) - , ("tap-macro-release" - , KTapMacroRelease <$> lexeme (some buttonP) <*> optional (keywordP "delay" numP)) - , ("cmd-button" , KCommand <$> lexeme textP <*> optional (lexeme textP)) - , ("pause" , KPause . fromIntegral <$> lexeme numP) - , ("sticky-key" , KStickyKey <$> lexeme numP <*> buttonP) + [ (,) "around-implicit" $ KAroundImplicit <$> buttonP <*> buttonP + , (,) "press-only" $ KPressOnly <$> keycodeP + , (,) "release-only" $ KReleaseOnly <$> keycodeP + , (,) "multi-tap" $ KMultiTap <$> timed <*> buttonP + , (,) "stepped" $ KStepped <$> buttonsP + , (,) "tap-hold" $ KTapHold <$> numP <*> buttonP <*> buttonP + , (,) "tap-hold-next" $ KTapHoldNext <$> numP <*> buttonP <*> buttonP <*> timeoutP + , (,) "tap-next-release" $ KTapNextRelease <$> buttonP <*> buttonP + , (,) "tap-hold-next-release" $ KTapHoldNextRelease <$> numP <*> buttonP <*> buttonP <*> timeoutP + , (,) "tap-next-press" $ KTapNextPress <$> buttonP <*> buttonP + , (,) "tap-hold-next-press" $ KTapHoldNextPress <$> numP <*> buttonP <*> buttonP <*> timeoutP + , (,) "tap-next" $ KTapNext <$> buttonP <*> buttonP + , (,) "layer-toggle" $ KLayerToggle <$> word + , (,) "momentary-layer" $ KLayerToggle <$> word + , (,) "layer-switch" $ KLayerSwitch <$> word + , (,) "permanent-layer" $ KLayerSwitch <$> word + , (,) "layer-add" $ KLayerAdd <$> word + , (,) "layer-rem" $ KLayerRem <$> word + , (,) "layer-delay" $ KLayerDelay <$> numP <*> word + , (,) "layer-next" $ KLayerNext <$> word + , (,) "around-next" $ KAroundNext <$> buttonP + , (,) "around-next-single" $ KAroundNextSingle <$> buttonP + , (,) "before-after-next" $ KBeforeAfterNext <$> buttonP <*> buttonP + , (,) "around-next-timeout" $ KAroundNextTimeout <$> numP <*> buttonP <*> buttonP + , (,) "tap-macro" $ KTapMacro <$> buttonsP <*> delayP + , (,) "tap-macro-release" $ KTapMacroRelease <$> buttonsP <*> delayP + , (,) "cmd-button" $ KCommand <$> textP <*> optional textP + , (,) "pause" $ kPause <$> numP + , (,) "sticky-key" $ KStickyKey <$> numP <*> buttonP ] ++ map (\(nm,_,btn) -> (nm, btn <$> buttonP <*> buttonP)) implArndButtons where timed :: Parser [(Int, DefButton)] - timed = many ((,) <$> lexeme numP <*> lexeme buttonP) + timed = many ((,) <$> numP <*> buttonP) + kPause = KPause . fromIntegral + buttonsP = some buttonP + timeoutP = optarg'P "timeout-button" buttonP + delayP = optarg'P "delay" numP implArndButtons :: [(Text, ImplArnd, DefButton -> DefButton -> DefButton)] -implArndButtons = sortBy (flip compare `on` (T.length . view _1)) -- Prevents early return due to `around` +implArndButtons = [ ("around" , IAAround , KAround) , ("around-only" , IAAroundOnly , KAroundOnly) , ("around-when-alone", IAAroundWhenAlone, KAroundWhenAlone) @@ -321,11 +320,11 @@ noKeywordButtons :: [Parser DefButton] noKeywordButtons = [ KComposeSeq <$> deadkeySeqP + , rmTapMacroP + , fromNamed buttonNames , KRef <$> derefP - , lexeme $ fromNamed buttonNames - , try moddedP - , lexeme $ try rmTapMacroP - , lexeme $ try pauseP + , moddedP + , pauseP , KEmit <$> keycodeP , KComposeSeq <$> composeSeqP ] @@ -335,56 +334,60 @@ -- | Parse an input token itokenP :: Parser IToken -itokenP = choice $ map (try . uncurry statement) itokens +itokenP = mkTokenP itokens -- | Input tokens to parse; the format is @(keyword, how to parse the token)@ itokens :: [(Text, Parser IToken)] itokens = - [ ("device-file" , KDeviceSource <$> (T.unpack <$> lexeme textP)) + [ ("device-file" , KDeviceSource . unpack <$> textP <*> ignoreMissingP) , ("low-level-hook", pure KLowLevelHookSource) - , ("iokit-name" , KIOKitSource <$> optional (lexeme textP))] + , ("iokit-name" , KIOKitSource <$> optional textP) + ] + where + ignoreMissingP = option False $ optargP "ignore-missing" boolP -- | Parse an output token otokenP :: Parser OToken -otokenP = choice $ map (try . uncurry statement) otokens +otokenP = mkTokenP otokens -- | Output tokens to parse; the format is @(keyword, how to parse the token)@ otokens :: [(Text, Parser OToken)] otokens = - [ ("uinput-sink" , KUinputSink <$> lexeme textP <*> optional (lexeme textP)) - , ("send-event-sink", KSendEventSink <$> optional ((,) <$> lexeme numP <*> lexeme numP)) - , ("kext" , pure KKextSink)] + [ ("uinput-sink" , KUinputSink <$> textP <*> optional textP) + , ("send-event-sink", KSendEventSink <$> optional ((,) <$> numP <*> numP)) + , ("kext" , pure KKextSink) + ] -- | Parse an impl arnd token implArndP :: Parser ImplArnd -implArndP = lexeme . choice $ - try (IADisabled <$ symbol "disabled") - : map (\(s, v, _) -> try $ v <$ symbol s) implArndButtons +implArndP = choice $ + keyword' "disabled" IADisabled + : map (\(s, v, _) -> keyword' s v) implArndButtons -- | Parse the DefCfg token defcfgP :: Parser DefSettings -defcfgP = some (lexeme settingP) +defcfgP = some settingP -- | All possible configuration options that can be passed in the defcfg block settingP :: Parser DefSetting -settingP = let f s p = symbol s *> p in - (lexeme . choice . map try $ - [ SIToken <$> f "input" itokenP - , SOToken <$> f "output" otokenP - , SCmpSeq <$> f "cmp-seq" buttonP - , SFallThrough <$> f "fallthrough" bool - , SAllowCmd <$> f "allow-cmd" bool - , SCmpSeqDelay <$> f "cmp-seq-delay" numP - , SKeySeqDelay <$> f "key-seq-delay" numP - , SImplArnd <$> f "implicit-around" implArndP - ]) +settingP = + choice + [ SIToken <$> sexpr "input" itokenP + , SOToken <$> sexpr "output" otokenP + , SCmpSeq <$> sexpr "cmp-seq" buttonP + , SFallThrough <$> sexpr "fallthrough" boolP + , SAllowCmd <$> sexpr "allow-cmd" boolP + , SCmpSeqDelay <$> sexpr "cmp-seq-delay" numP + , SKeySeqDelay <$> sexpr "key-seq-delay" numP + , SImplArnd <$> sexpr "implicit-around" implArndP + ] -------------------------------------------------------------------------------- -- $defalias -- | Parse a collection of names and buttons defaliasP :: Parser DefAlias -defaliasP = many $ (,) <$> lexeme word <*> buttonP +defaliasP = many $ (,) <$> word <*> buttonP -------------------------------------------------------------------------------- -- $defsrc @@ -392,19 +395,19 @@ defsrcP :: Parser DefSrc defsrcP = DefSrc - <$> optional (keywordP "name" word) - <*> many (lexeme keycodeP) + <$> optarg'P "name" word + <*> many buttonP -------------------------------------------------------------------------------- -- $deflayer deflayerP :: Parser DefLayer -deflayerP = DefLayer <$> lexeme word <*> many (lexeme layerSettingP) +deflayerP = DefLayer <$> word <*> many layerSettingP layerSettingP :: Parser DefLayerSetting layerSettingP = - lexeme . choice . map try $ - [ LSrcName <$> keywordP "source" word - , LImplArnd <$> keywordP "implicit-around" implArndP - , LButton <$> buttonP + choice + [ LSrcName <$> optargP "source" word + , LImplArnd <$> optargP "implicit-around" implArndP + , LButton <$> buttonP ] diff --git a/src/KMonad/Args/Types.hs b/src/KMonad/Args/Types.hs --- a/src/KMonad/Args/Types.hs +++ b/src/KMonad/Args/Types.hs @@ -139,8 +139,8 @@ -- | A list of keycodes describing the ordering used by all other layers -- | which is associated with a name. data DefSrc = DefSrc - { _srcName :: Maybe Text -- ^ A unique name used to refer to this layer. - , _keycodes :: [Keycode] -- ^ Layer settings containing also the buttons. + { _srcName :: Maybe Text -- ^ A unique name used to refer to this layer. + , _keycodes :: [DefButton] -- ^ Layer settings containing also the buttons. } deriving (Show, Eq) makeClassy ''DefSrc @@ -170,7 +170,7 @@ -- | All different input-tokens KMonad can take data IToken - = KDeviceSource FilePath + = KDeviceSource FilePath Bool | KLowLevelHookSource | KIOKitSource (Maybe Text) deriving (Show) diff --git a/src/KMonad/Keyboard/IO.hs b/src/KMonad/Keyboard/IO.hs --- a/src/KMonad/Keyboard/IO.hs +++ b/src/KMonad/Keyboard/IO.hs @@ -40,7 +40,7 @@ mkKeySink :: HasLogFunc e => RIO e snk -- ^ Action to acquire the keysink -> (snk -> RIO e ()) -- ^ Action to close the keysink - -> (snk -> KeyEvent -> RIO e ()) -- ^ Action to write with the keysink + -> (snk -> KeyEvent -> RIO e ()) -- ^ Action to write to the keysink -> RIO e (Acquire KeySink) mkKeySink o c w = do u <- askUnliftIO @@ -67,7 +67,7 @@ mkKeySource :: HasLogFunc e => RIO e src -- ^ Action to acquire the keysource -> (src -> RIO e ()) -- ^ Action to close the keysource - -> (src -> RIO e KeyEvent) -- ^ Action to write with the keysource + -> (src -> RIO e KeyEvent) -- ^ Action to read from the keysource -> RIO e (Acquire KeySource) mkKeySource o c r = do u <- askUnliftIO diff --git a/src/KMonad/Keyboard/IO/Linux/DeviceSource.hs b/src/KMonad/Keyboard/IO/Linux/DeviceSource.hs --- a/src/KMonad/Keyboard/IO/Linux/DeviceSource.hs +++ b/src/KMonad/Keyboard/IO/Linux/DeviceSource.hs @@ -21,7 +21,9 @@ import KMonad.Prelude import Foreign.C.Types +import Foreign.C.Error import System.Posix +import System.IO.Error import KMonad.Keyboard.IO.Linux.Types import KMonad.Util @@ -29,18 +31,28 @@ import qualified Data.Serialize as B (decode) import qualified RIO.ByteString as B +import System.INotify +import RIO.Directory +import RIO.FilePath + +import GHC.IO.Exception (IOException(IOError, ioe_errno)) + -------------------------------------------------------------------------------- -- $err data DeviceSourceError - = IOCtlGrabError FilePath - | IOCtlReleaseError FilePath + = IOCtlGrabError IOError + | IOCtlReleaseError IOError + | PathTypeMismatch Bool FilePath + | RootDirDoesNotExist FilePath | KeyIODecodeError String deriving Exception instance Show DeviceSourceError where - show (IOCtlGrabError pth) = "Could not perform IOCTL grab on: " <> pth - show (IOCtlReleaseError pth) = "Could not perform IOCTL release on: " <> pth + show (IOCtlGrabError e) = show e + show (IOCtlReleaseError e) = show e + show (PathTypeMismatch d pt) = "Path exists but is not a " <> (if d then "directory" else "file") <> ": " <> pt + show (RootDirDoesNotExist dev) = "Root directory for device '" <> dev <> "' does not exist" show (KeyIODecodeError msg) = "KeyEvent decode failed with msg: " <> msg makeClassyPrisms ''DeviceSourceError @@ -48,15 +60,19 @@ -------------------------------------------------------------------------------- -- $ffi foreign import ccall "ioctl_keyboard" - c_ioctl_keyboard :: CInt -> CInt -> IO CInt + c_ioctl_keyboard :: Fd -> CInt -> IO CInt -- | Perform an IOCTL operation on an open keyboard handle ioctl_keyboard :: MonadIO m - => Fd -- ^ Descriptor to open keyboard file (like /dev/input/eventXX) - -> Bool -- ^ True to grab, False to ungrab - -> m Int -- ^ Return the exit code -ioctl_keyboard (Fd h) b = fromIntegral <$> - liftIO (c_ioctl_keyboard h (if b then 1 else 0)) + => Fd -- ^ Descriptor to open keyboard file (like /dev/input/eventXX) + -> FilePath -- ^ FilePath to keyboard for error reporting + -> Bool -- ^ True to grab, False to ungrab + -> m () -- ^ Return the exit code +ioctl_keyboard h pt g = liftIO $ do + throwErrnoPathIfMinus1_ + ("Could not perform IOCTL " ++ if g then "grab" else "release") + pt + (c_ioctl_keyboard h $ if g then 1 else 0) -------------------------------------------------------------------------------- @@ -93,14 +109,14 @@ data DeviceSourceCfg = DeviceSourceCfg { _pth :: !FilePath -- ^ Path to the event-file , _parser :: !KeyEventParser -- ^ The method used to decode events + , _ignmis :: !Bool -- ^ Whether to wait for keyboard to (re-)appear } makeClassy ''DeviceSourceCfg -- | Collection of data used to read from linux input.h event stream data DeviceFile = DeviceFile { _cfg :: !DeviceSourceCfg -- ^ Configuration settings - , _fd :: !Fd -- ^ Posix filedescriptor to the device file - , _hdl :: !Handle -- ^ Haskell handle to the device file + , _dev :: !(IORef (Fd, Handle)) -- ^ Posix and Haskell filedescriptor to the device file } makeClassy ''DeviceFile @@ -111,12 +127,14 @@ deviceSource :: HasLogFunc e => KeyEventParser -- ^ The method by which to read and decode events -> FilePath -- ^ The filepath to the device file + -> Bool -- ^ Whether to wait for keyboard to (re-)appear -> RIO e (Acquire KeySource) -deviceSource pr pt = mkKeySource (lsOpen pr pt) lsClose lsRead +deviceSource pr pt im = mkKeySource (lsOpen pr pt im) lsClose lsRead -- | Open a device file on a standard linux 64 bit architecture deviceSource64 :: HasLogFunc e => FilePath -- ^ The filepath to the device file + -> Bool -- ^ Whether to wait for keyboard to (re-)appear -> RIO e (Acquire KeySource) deviceSource64 = deviceSource defEventParser @@ -124,42 +142,118 @@ -------------------------------------------------------------------------------- -- $io --- | Open the keyboard, perform an ioctl grab and return a 'DeviceFile'. This +-- | Open the keyboard, perform an ioctl grab and return the device handles. This -- can throw an 'IOException' if the file cannot be opened for reading, or an -- 'IOCtlGrabError' if an ioctl grab could not be properly performed. -lsOpen :: (HasLogFunc e) - => KeyEventParser -- ^ The method by which to decode events - -> FilePath -- ^ The path to the device file - -> RIO e DeviceFile -lsOpen pr pt = do - h <- liftIO $ openFd pt +lsOpen' :: HasLogFunc e => FilePath -> Bool -> RIO e (Fd, Handle) +lsOpen' pt im = do + when im waitForDeviceToExists + + fd <- liftIO $ openFd pt ReadOnly #if !MIN_VERSION_unix(2,8,0) Nothing #endif defaultFileFlags - hd <- liftIO $ fdToHandle h + hd <- liftIO $ fdToHandle fd logInfo "Initiating ioctl grab" - ioctl_keyboard h True `onErr` IOCtlGrabError pt - return $ DeviceFile (DeviceSourceCfg pt pr) h hd + ioctl_keyboard fd pt True `catch` (throwIO . IOCtlGrabError) + return (fd, hd) + where + waitForDeviceToExists = do + lf <- view logFuncL + liftIO $ waitForPath lf False pt Nothing + -- Test for existence followed by a inotify_add_watch + waitForPath lf isDir pt' inot = do + ptExists <- doesPathExist pt' + unless ptExists $ case inot of + Just inot' -> waitForPath' lf isDir pt' inot' + Nothing -> withINotify $ \inot' -> do + runRIO lf $ logInfo "Listening for device" + waitForPath' lf isDir pt' inot' + runRIO lf $ logInfo "Found device" + let doesExistWithType = if isDir then doesDirectoryExist else doesFileExist + foundWithType <- doesExistWithType pt' + unless foundWithType . throwIO $ PathTypeMismatch isDir pt' + + -- Wait for parent path and add INotify watch + waitForPath' lf isDir pt' inot = do + let parent = takeDirectory pt' + when (parent == pt') . throwIO $ RootDirDoesNotExist pt + waitForPath lf True parent $ Just inot + fn <- B.fromFilePath $ takeFileName pt' + dir <- B.fromFilePath parent + block <- newEmptyMVar + runRIO lf $ logDebug $ "Waiting for path: " <> fromString pt' + + let onFound isDir' = do + runRIO lf . logDebug $ "Found path: " <> fromString pt' + unless (isDir == isDir') . throwIO $ PathTypeMismatch isDir pt' + putMVar block True + + watch <- addWatch inot [Create, MoveIn, DeleteSelf] dir $ \case + Created isDir' fn' | fn' == fn -> onFound isDir' + -- Some symlinks are created then renamed + MovedIn isDir' fn' _ | fn' == fn -> onFound isDir' + DeletedSelf -> do + runRIO lf . logDebug $ "Parent directory deleted: " <> fromString parent + putMVar block False + _ -> pure () + + -- When creating symlinks in `by-id` or `by-path` the folder and symlink are + -- created in quick succession + pathCreatedDuringWatchInit <- doesPathExist pt' + found <- if pathCreatedDuringWatchInit + then pure True + else takeMVar block + if found + then removeWatch watch + else waitForPath lf isDir pt' $ Just inot + + +-- | Like `lsOpen'` but wrap it in a full 'DeviceFile'. +lsOpen :: (HasLogFunc e) + => KeyEventParser -- ^ The method by which to decode events + -> FilePath -- ^ The path to the device file + -> Bool -- ^ Whether to wait for keyboard to (re-)appear + -> RIO e DeviceFile +lsOpen pr pt im = DeviceFile (DeviceSourceCfg pt pr im) <$> (newIORef =<< lsOpen' pt im) + -- | Release the ioctl grab and close the device file. This can throw an -- 'IOException' if the handle to the device cannot be properly closed, or an -- 'IOCtlReleaseError' if the ioctl release could not be properly performed. lsClose :: (HasLogFunc e) => DeviceFile -> RIO e () lsClose src = do + (fd, hdl) <- readIORef (src^.dev) logInfo "Releasing ioctl grab" - ioctl_keyboard (src^.fd) False `onErr` IOCtlReleaseError (src^.pth) - liftIO . closeFd $ src^.fd + ioctl_keyboard fd (src^.cfg.pth) False `catch` (throwIO . IOCtlReleaseError) + hClose hdl -- | Read a bytestring from an open filehandle and return a parsed event. This -- can throw a 'KeyIODecodeError' if reading from the 'DeviceFile' fails to -- yield a parseable sequence of bytes. lsRead :: (HasLogFunc e) => DeviceFile -> RIO e KeyEvent lsRead src = do - bts <- B.hGet (src^.hdl) (src^.nbytes) + bts <- lsRead' =<< readIORef (src^.dev) case src^.prs $ bts of Right p -> case fromLinuxKeyEvent p of Just e -> return e Nothing -> lsRead src Left s -> throwIO $ KeyIODecodeError s + where + lsRead' (_, hdl) = + tryJust isENODEV (B.hGet hdl (src^.nbytes)) >>= \case + Right bts -> pure bts + Left e -> do + devExists <- doesFileExist (src^.cfg.pth) + hClose hdl + when devExists $ logRethrow "Device still exists, but reading failed" (toException e) + logInfo "Device disconnected" + h <- lsOpen' (src^.cfg.pth) (src^.ignmis) + writeIORef (src^.dev) h + logInfo "Device reconnected" + lsRead' h + isENODEV e@IOError{ioe_errno = Just errno} + | src^.ignmis && Errno errno == eNODEV = Just e + isENODEV _ = Nothing diff --git a/src/KMonad/Keyboard/IO/Mac/IOKitSource.hs b/src/KMonad/Keyboard/IO/Mac/IOKitSource.hs --- a/src/KMonad/Keyboard/IO/Mac/IOKitSource.hs +++ b/src/KMonad/Keyboard/IO/Mac/IOKitSource.hs @@ -54,12 +54,9 @@ case m of Nothing -> void $ grab_kb nullPtr - Just s -> do - str <- newCString s - void $ grab_kb str - free str + Just s -> void $ withCString s grab_kb - buf <- mallocBytes $ sizeOf (undefined :: MacKeyEvent) + buf <- malloc @MacKeyEvent pure $ EvBuf buf -- | Ask Mac to close the queue diff --git a/src/KMonad/Keyboard/IO/Mac/KextSink.hs b/src/KMonad/Keyboard/IO/Mac/KextSink.hs --- a/src/KMonad/Keyboard/IO/Mac/KextSink.hs +++ b/src/KMonad/Keyboard/IO/Mac/KextSink.hs @@ -28,7 +28,7 @@ skOpen :: HasLogFunc e => RIO e EvBuf skOpen = do logInfo "Initializing Mac key sink" - liftIO $ EvBuf <$> mallocBytes (sizeOf (undefined :: MacKeyEvent)) + liftIO $ EvBuf <$> malloc @MacKeyEvent -- | Close the 'EvBuf' environment skClose :: HasLogFunc e => EvBuf -> RIO e () diff --git a/src/KMonad/Keyboard/IO/Windows/LowLevelHookSource.hs b/src/KMonad/Keyboard/IO/Windows/LowLevelHookSource.hs --- a/src/KMonad/Keyboard/IO/Windows/LowLevelHookSource.hs +++ b/src/KMonad/Keyboard/IO/Windows/LowLevelHookSource.hs @@ -25,6 +25,10 @@ -------------------------------------------------------------------------------- +-- | Initialize the pipe in the c code. Should be part of 'grab_kb' but needs to run syncronously +foreign import ccall "init_pipe" + c_init_pipe :: IO () + -- | Use the windows c-api to `grab` a keyboard foreign import ccall "grab_kb" grab_kb :: IO () @@ -36,9 +40,21 @@ -- | Pass a pointer to a buffer to wait_key, when it returns the buffer can be -- read for the next key event. foreign import ccall "wait_key" - wait_key :: Ptr WinKeyEvent -> IO () + c_wait_key :: Ptr WinKeyEvent -> Ptr Word32 -> IO Word32 +-- | A small wrapper around the C function 'c_wait_key'. Sometimes the read from +-- the internal pipe in the C code gets interrupted. Probably due to events we +-- want to ignore. Therefore we limit retries on empty reads. (See #1003) +wait_key :: HasLogFunc e => Ptr WinKeyEvent -> RIO e () +wait_key buffer = do + (err, read) <- liftIO $ alloca $ \read -> do + (,) <$> c_wait_key buffer read <*> peek read + if + | err /= 0 -> throwIO $ WinErrorWhileReadingPipe err + | fromEnum read == sizeOf (undefined :: WinKeyEvent) -> pure () + | otherwise -> throwIO $ UnexpetedNumberOfBytesRead read + -------------------------------------------------------------------------------- -- | Data used to track `connection` to windows process @@ -60,8 +76,9 @@ llOpen = do logInfo "Registering low-level Windows keyboard hook" liftIO $ do + c_init_pipe tid <- async grab_kb - buf <- mallocBytes $ sizeOf (undefined :: WinKeyEvent) + buf <- malloc @WinKeyEvent pure $ LLHook tid buf -- | Ask windows to unregister the hook and free the data-buffer @@ -78,7 +95,6 @@ -- NOTE: This can throw an error if the event fails to convert. llRead :: HasLogFunc e => LLHook -> RIO e KeyEvent llRead ll = do - we <- liftIO $ do - wait_key $ ll^.buffer - peek $ ll^.buffer + wait_key $ ll^.buffer + we <- liftIO $ peek (ll^.buffer) either throwIO pure $ fromWinKeyEvent we diff --git a/src/KMonad/Keyboard/IO/Windows/SendEventSink.hs b/src/KMonad/Keyboard/IO/Windows/SendEventSink.hs --- a/src/KMonad/Keyboard/IO/Windows/SendEventSink.hs +++ b/src/KMonad/Keyboard/IO/Windows/SendEventSink.hs @@ -37,7 +37,7 @@ -- | The SKSink environment data SKSink = SKSink { _buffer :: MVar (Ptr WinKeyEvent) -- ^ The pointer we write events to - , _keyrep :: MVar (Maybe (Keycode, Async ())) + , _keyrep :: MVar (Maybe (Keycode, Async ())) -- ^ Keyrepeat data if pressent , _delay :: Int -- ^ How long to wait before starting key repeat in ms , _rate :: Int -- ^ How long to wait between key repeats in ms } @@ -51,7 +51,7 @@ skOpen :: HasLogFunc e => (Int, Int) -> RIO e SKSink skOpen (d, i) = do logInfo "Initializing Windows key sink" - bv <- liftIO $ mallocBytes (sizeOf (undefined :: WinKeyEvent)) + bv <- liftIO $ malloc @WinKeyEvent bm <- newMVar bv r <- newMVar Nothing pure $ SKSink bm r d i @@ -60,9 +60,13 @@ skClose :: HasLogFunc e => SKSink -> RIO e () skClose s = do logInfo "Closing Windows key sink" - withMVar (s^.keyrep) $ \r -> maybe (pure ()) cancel (r^?_Just._2) + withMVar (s^.keyrep) stopRepeat withMVar (s^.buffer) (liftIO . free) +-- | Stop repeating the key by cancelling the keyrepeat thread +stopRepeat :: Maybe (Keycode, Async ()) -> RIO e () +stopRepeat = mapMOf_ (_Just._2) cancel + -- | Send 1 key event to Windows emit :: MonadUnliftIO m => SKSink -> WinKeyEvent -> m () emit s w = withMVar (s^.buffer) $ \b -> liftIO $ poke b w >> sendKey b @@ -81,7 +85,7 @@ -- When we're going to emit a press we are not already repeating let handleNewPress = do - maybe (pure ()) cancel (r^?_Just._2) + stopRepeat r emit s w a <- async $ do threadDelay (1000 * s^.delay) @@ -90,7 +94,7 @@ -- When the event is a release let handleRelease = do - when beingRepped $ maybe (pure ()) cancel (r^?_Just._2) + when beingRepped $ stopRepeat r emit s w pure $ if beingRepped then Nothing else r diff --git a/src/KMonad/Keyboard/IO/Windows/Types.hs b/src/KMonad/Keyboard/IO/Windows/Types.hs --- a/src/KMonad/Keyboard/IO/Windows/Types.hs +++ b/src/KMonad/Keyboard/IO/Windows/Types.hs @@ -27,6 +27,8 @@ import Foreign.Storable import KMonad.Keyboard +import Numeric (showHex) + import Data.Tuple (swap) import qualified RIO.HashMap as M import qualified RIO.NonEmpty as NE (groupAllWith) @@ -40,12 +42,19 @@ data WinError = NoWinKeycodeTo Keycode -- ^ Error translating to 'WinKeycode' | NoWinKeycodeFrom WinKeycode -- ^ Error translating from 'WinKeycode' + | UnexpetedNumberOfBytesRead Word32 -- ^ Bug in 'keyio_win.c'. We only write 'sizeof (undefined :: KeyEvent)' + | WinErrorWhileReadingPipe Word32 -- ^ 'ReadFile' in 'keyio_win.c' exited with failure instance Exception WinError instance Show WinError where show e = case e of NoWinKeycodeTo c -> "Cannot translate to windows keycode: " <> show c - NoWinKeycodeFrom i -> "Cannot translate from windows keycode: " <> show i + NoWinKeycodeFrom i -> "Cannot translate from windows keycode: " <> showHex i "" + UnexpetedNumberOfBytesRead read -> + "Unexpeted bytes read from low-level hook. Read " + <> show read <> " bytes should be exactly " + <> show (sizeOf (undefined :: WinKeyEvent)) <> " bytes." + WinErrorWhileReadingPipe e -> "Could not read from low-level hook. Read aborted with error: 0x" ++ showHex e "" -------------------------------------------------------------------------------- -- $typ @@ -144,15 +153,18 @@ -- and also may have the same KMonad KeyCode multiple times. -- -- It is essentially a merge of 'winCodeToKeyCode' and 'keyCodeToWinCode'. +-- +-- Also note that the OEM Specific keys without name are not accessible +-- since they fallthrough at the low level hook layer (c_src/keyio_win.c) winCodeKeyCodeMapping :: [(WinKeycode, Keycode)] winCodeKeyCodeMapping = [ (0x00, Missing254) -- Not documented, but happens often. Why?? - -- , (0x01, ???) -- Defined as VK_LBUTTON - -- , (0x02, ???) -- Defined as VK_RBUTTON + , (0x01, BtnLeft) -- Defined as VK_LBUTTON + , (0x02, BtnRight) -- Defined as VK_RBUTTON , (0x03, KeyCancel) - -- , (0x04, ???) -- Defined as VK_MBUTTON - -- , (0x05, ???) -- Defined as VK_XBUTTON1 - -- , (0x06, ???) -- Defined as VK_XBUTTON2 + , (0x04, BtnMiddle) -- Defined as VK_MBUTTON + , (0x05, VKXButton1) -- Defined as VK_XBUTTON1 + , (0x06, VKXButton2) -- Defined as VK_XBUTTON2 , (0x08, KeyBackspace) , (0x09, KeyTab) , (0x0C, KeyDelete) -- Defined as VK_CLEAR @@ -314,7 +326,7 @@ , (0xDC, KeyBackslash) -- Defined as VK_OEM_5 , (0xDD, KeyRightBrace) -- Defined as VK_OEM_6 , (0xDE, KeyApostrophe) -- Defined as VK_OEM_7 - -- , (0xDF, ???) -- Defined ask VK_OEM_8 + , (0xDF, VKOEM8) -- Defined ask VK_OEM_8 -- , (0xE1, ???) -- Defined as `OEM specific` , (0xE2, Key102nd) -- , (0xE3, ???) -- Defined as `OEM specific` diff --git a/src/KMonad/Keyboard/Keycode.hs b/src/KMonad/Keyboard/Keycode.hs --- a/src/KMonad/Keyboard/Keycode.hs +++ b/src/KMonad/Keyboard/Keycode.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveAnyClass #-} {-| Module : KMonad.Keyboard.Keycode Description : Description of all possible keycodes. @@ -30,6 +29,8 @@ import qualified RIO.Text as T import qualified RIO.Text.Partial as T (head) +import Data.Hashable (Hashable(..)) + -------------------------------------------------------------------------------- -- $typ -- @@ -817,8 +818,18 @@ | KeyMissionCtrl | KeySpotlight | KeyDictation - deriving (Eq, Show, Bounded, Enum, Ord, Generic, Hashable, Typeable, Data) + -- Low level hook (Windows) + -- (The VK prefix makes it obvious those are "broken" windows keycodes) + | VKXButton1 + | VKXButton2 + | VKOEM8 -- Does not exist on US keyboards + deriving (Eq, Show, Bounded, Enum, Ord, Typeable, Data) +-- We manually define the Hashable instance, since we would need a `Generic` +-- instance instead. Deriving `Generic` causes a significant increase in compile +-- time. See https://gitlab.haskell.org/ghc/ghc/-/issues/5642 +instance Hashable Keycode where + hashWithSalt s = hashWithSalt s . fromEnum instance Display Keycode where textDisplay c = (\t -> "<" <> t <> ">") . fromMaybe (tshow c) diff --git a/src/KMonad/Model/Button.hs b/src/KMonad/Model/Button.hs --- a/src/KMonad/Model/Button.hs +++ b/src/KMonad/Model/Button.hs @@ -209,9 +209,12 @@ Button -- ^ The outer 'Button' -> Button -- ^ The inner 'Button' -> Button -- ^ The resulting nested 'Button' -around outer inner = mkButton +around outer inner = mkButton' (runAction (outer^.pressAction) *> runAction (inner^.pressAction)) (runAction (inner^.releaseAction) *> runAction (outer^.releaseAction)) + $ runAction (outer^.pressAction) + *> runAction (inner^.tapAction) + *> runAction (outer^.releaseAction) -- | A variant of `around`, which releases its outer button when another key -- is pressed. @@ -594,7 +597,7 @@ -- pressed for the button after it if that button was pressed in the -- given timeframe. stickyKey :: Milliseconds -> Button -> Button -stickyKey ms b = onPress go +stickyKey ms b = mkButton' go (pure ()) doTap where go :: MonadK m => m () go = hookF InputHook $ \e -> do diff --git a/src/KMonad/Model/Dispatch.hs b/src/KMonad/Model/Dispatch.hs --- a/src/KMonad/Model/Dispatch.hs +++ b/src/KMonad/Model/Dispatch.hs @@ -43,6 +43,7 @@ import KMonad.Prelude import KMonad.Keyboard +import KMonad.Model.EventSrc import RIO.Seq (Seq(..), (><)) import qualified RIO.Seq as Seq @@ -56,21 +57,19 @@ -- | The 'Dispatch' environment data Dispatch = Dispatch - { _eventSrc :: IO KeyEvent -- ^ How to read 1 event - , _readProc :: TMVar (Async KeyEvent) -- ^ Store for reading process + { eventSrc :: EventSrc IO -- ^ How to read 1 event , _rerunBuf :: TVar (Seq KeyEvent) -- ^ Buffer for rerunning events } makeLenses ''Dispatch -- | Create a new 'Dispatch' environment -mkDispatch' :: MonadUnliftIO m => m KeyEvent -> m Dispatch +mkDispatch' :: MonadUnliftIO m => EventSrc m -> m Dispatch mkDispatch' s = withRunInIO $ \u -> do - rpc <- newEmptyTMVarIO rrb <- newTVarIO Seq.empty - pure $ Dispatch (u s) rpc rrb + pure $ Dispatch (unliftESrc u s) rrb -- | Create a new 'Dispatch' environment in a 'ContT' environment -mkDispatch :: MonadUnliftIO m => m KeyEvent -> ContT r m Dispatch +mkDispatch :: MonadUnliftIO m => EventSrc m -> ContT r m Dispatch mkDispatch = lift . mkDispatch' -------------------------------------------------------------------------------- @@ -82,25 +81,16 @@ -- 1. The next item to be rerun -- 2. A new item read from the OS -- 3. Pausing until either 1. or 2. triggers -pull :: (HasLogFunc e) => Dispatch -> RIO e KeyEvent -pull d = do - -- Check for an unfinished read attempt started previously. If it exists, - -- fetch it, otherwise, start a new read attempt. - a <- atomically (tryTakeTMVar $ d^.readProc) >>= \case - Nothing -> async . liftIO $ d^.eventSrc - Just a' -> pure a' - - -- 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 +pull :: (HasLogFunc e) => Dispatch -> EventSrc (RIO e) +pull d@Dispatch{eventSrc = EventSrc{tryESrc, postESrc}} = EventSrc + { tryESrc = (Left <$> popRerun) `orElse` (Right <$> tryESrc) + , postESrc = \case + Left e -> do logDebug $ "\n" <> display (T.replicate 80 "-") - <> "\nRerunning event: " <> display e' - atomically $ putTMVar (d^.readProc) a - pure e' - Right e' -> pure e' - + <> "\nRerunning event: " <> display e + pure $ Just e + Right e -> liftIO $ postESrc e + } where -- Pop the head off the rerun-buffer (or 'retrySTM' if empty) popRerun = readTVar (d^.rerunBuf) >>= \case diff --git a/src/KMonad/Model/EventSrc.hs b/src/KMonad/Model/EventSrc.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/Model/EventSrc.hs @@ -0,0 +1,43 @@ +module KMonad.Model.EventSrc + ( EventSrc(..) + , unliftESrc + , pullESrc + , pullToESrc + , toESrc + ) where + +import KMonad.Prelude +import KMonad.Util +import KMonad.Keyboard + +-- | Used when a component needs an event source. +-- The benefit of this over spawning a new thread and awaiting the async option are the following: +-- 1. No making sure the event doesn't get dropped +-- 2. No key events blocked inside the pipeline (see #1048 fixed by #1049) +-- Instead it needs to construct an STM action including those of the event source. +-- Due to the existentially qualified nature, we can only work with it via +-- pattern matching inside a function argument. +data EventSrc m = forall a. EventSrc + { tryESrc :: STM a + , postESrc :: a -> m (Maybe KeyEvent) + } + +unliftESrc :: (m (Maybe KeyEvent) -> IO (Maybe KeyEvent)) -> EventSrc m -> EventSrc IO +unliftESrc u EventSrc{tryESrc, postESrc} = EventSrc tryESrc (u . postESrc) + +pullESrc :: MonadIO m => EventSrc m -> m KeyEvent +pullESrc EventSrc{tryESrc, postESrc} = go + where go = atomically tryESrc >>= postESrc >>= maybe go pure + +-- | Spawns a new thread to continously pull +pullToESrc :: (HasLogFunc e, MonadIO m) => Text -> RIO e KeyEvent -> ContT r (RIO e) (EventSrc m) +pullToESrc tname pull = do + channel <- newEmptyTMVarIO + launch_ tname $ do + e <- pull + atomically $ putTMVar channel e + + pure $ toESrc channel + +toESrc :: MonadIO m => TMVar KeyEvent -> EventSrc m +toESrc channel = EventSrc (takeTMVar channel) (pure . Just) diff --git a/src/KMonad/Model/Hooks.hs b/src/KMonad/Model/Hooks.hs --- a/src/KMonad/Model/Hooks.hs +++ b/src/KMonad/Model/Hooks.hs @@ -29,6 +29,7 @@ import Data.Unique import KMonad.Model.Action hiding (register) +import KMonad.Model.EventSrc import KMonad.Keyboard import KMonad.Util @@ -65,21 +66,21 @@ -- | The 'Hooks' environment that is required for keeping track of all the -- different targets and callbacks. data Hooks = Hooks - { _eventSrc :: IO KeyEvent -- ^ Where we get our events from + { eventSrc :: EventSrc IO -- ^ Where we get our events from , _injectTmr :: TMVar Unique -- ^ Used to signal timeouts , _hooks :: TVar Store -- ^ Store of hooks } makeLenses ''Hooks -- | Create a new 'Hooks' environment which reads events from the provided action -mkHooks' :: MonadUnliftIO m => m KeyEvent -> m Hooks +mkHooks' :: MonadUnliftIO m => EventSrc m -> m Hooks mkHooks' s = withRunInIO $ \u -> do itr <- newEmptyTMVarIO hks <- newTVarIO M.empty - pure $ Hooks (u s) itr hks + pure $ Hooks (unliftESrc u s) itr hks -- | Create a new 'Hooks' environment, but as a 'ContT' monad to avoid nesting -mkHooks :: MonadUnliftIO m => m KeyEvent -> ContT r m Hooks +mkHooks :: MonadUnliftIO m => EventSrc m -> ContT r m Hooks mkHooks = lift . mkHooks' -- | Convert a hook in some UnliftIO monad into an IO version, to store it in Hooks @@ -112,18 +113,19 @@ -- If the hook has a timeout, start a thread that will signal timeout case h^.hTimeout of Nothing -> logDebug $ "Registering untimed hook: " <> display (hashUnique tag) - Just t' -> void . async $ do + Just t' -> do logDebug $ "Registering " <> display (t'^.delay) <> "ms hook: " <> display (hashUnique tag) - threadDelay $ 1000 * fromIntegral (t'^.delay) - atomically $ putTMVar (hs^.injectTmr) tag + void . async $ do + threadDelay $ 1000 * fromIntegral (t'^.delay) + atomically $ putTMVar (hs^.injectTmr) tag --- | Cancel a hook by removing it from the store -cancelHook :: (HasLogFunc e) +-- | Run timeout action of hook and remove it from the store +runTimeout :: (HasLogFunc e) => Hooks -> Unique -> RIO e () -cancelHook hs tag = do +runTimeout hs tag = do e <- atomically $ do m <- readTVar $ hs^.hooks let v = M.lookup tag m @@ -131,9 +133,9 @@ pure v case e of Nothing -> - logDebug $ "Tried cancelling expired hook: " <> display (hashUnique tag) + logDebug $ "Hook timeout ignored (already triggered): " <> display (hashUnique tag) Just e' -> do - logDebug $ "Cancelling hook: " <> display (hashUnique tag) + logDebug $ "Handling timeout of hook: " <> display (hashUnique tag) liftIO $ e' ^. hTimeout . to fromJust . action @@ -144,9 +146,10 @@ -- how this updates the 'Hooks' environment. -- | Run the function stored in a Hook on the event and the elapsed time -runEntry :: MonadIO m => SystemTime -> KeyEvent -> Entry -> m Catch -runEntry t e v = liftIO $ do - (v^.keyH) $ Trigger ((v^.time) `tDiff` t) e +runEntry :: HasLogFunc e => SystemTime -> KeyEvent -> (Unique, Entry) -> RIO e Catch +runEntry t e (k, v) = do + logDebug $ "Hook " <> display (hashUnique k) <> ":" + liftIO $ (v^.keyH) $ Trigger ((v^.time) `tDiff` t) e -- | Run all hooks on the current event and reset the store runHooks :: (HasLogFunc e) @@ -154,12 +157,13 @@ -> KeyEvent -> RIO e (Maybe KeyEvent) runHooks hs e = do - logDebug "Running hooks" + logDebug $ "Running hooks for event: " <> display e m <- atomically $ swapTVar (hs^.hooks) M.empty now <- liftIO getSystemTime - foldMapM (runEntry now e) (M.elems m) >>= \case + foldMapM (runEntry now e) (M.toList m) >>= \case Catch -> pure Nothing NoCatch -> pure $ Just e + <* logDebug "Done running Hooks" -------------------------------------------------------------------------------- @@ -174,26 +178,16 @@ -- callback, then return it (otherwise return Nothing). At the same time, keep -- reading the timer-cancellation inject point and handle any cancellation as it -- comes up. -step :: (HasLogFunc e) +pull :: (HasLogFunc e) => Hooks -- ^ The 'Hooks' environment - -> RIO e (Maybe KeyEvent) -- ^ An action that returns perhaps the next event -step h = do - - -- Asynchronously start reading the next event - a <- async . liftIO $ h^.eventSrc - - -- Handle any timer event first, and then try to read from the source - let next = (Left <$> takeTMVar (h^.injectTmr)) `orElse` (Right <$> waitSTM a) + -> EventSrc (RIO e) -- ^ An action that returns perhaps the next event +pull h@Hooks{eventSrc = EventSrc{tryESrc, postESrc}} = EventSrc + { -- Handle any timer event first, and then try to read from the source + tryESrc = (Left <$> takeTMVar (h^.injectTmr)) `orElse` (Right <$> tryESrc) -- Keep taking and cancelling timers until we encounter a key event, then run -- the hooks on that event. - let read = atomically next >>= \case - Left t -> cancelHook h t >> read -- We caught a cancellation - Right e -> runHooks h e -- We caught a real event - read - --- | Keep stepping until we succesfully get an unhandled 'KeyEvent' -pull :: HasLogFunc e - => Hooks - -> RIO e KeyEvent -pull h = step h >>= maybe (pull h) pure + , postESrc = \case + Left t -> runTimeout h t $> Nothing -- We caught a hook timeout + Right e -> liftIO (postESrc e) >>= maybe (pure Nothing) (runHooks h) -- We caught a real event + } diff --git a/src/KMonad/Model/Sluice.hs b/src/KMonad/Model/Sluice.hs --- a/src/KMonad/Model/Sluice.hs +++ b/src/KMonad/Model/Sluice.hs @@ -25,6 +25,8 @@ import KMonad.Keyboard +import KMonad.Model.EventSrc + -------------------------------------------------------------------------------- -- $env @@ -34,21 +36,21 @@ -- never be interrupted, therefore we can simply use 'IORef' and sidestep all -- the STM complications. data Sluice = Sluice - { _eventSrc :: IO KeyEvent -- ^ Where we get our 'KeyEvent's from + { eventSrc :: EventSrc IO -- ^ Where we get our 'KeyEvent's from , _blocked :: IORef Int -- ^ How many locks have been applied to the sluice , _blockBuf :: IORef [KeyEvent] -- ^ Internal buffer to store events while closed } makeLenses ''Sluice -- | Create a new 'Sluice' environment -mkSluice' :: MonadUnliftIO m => m KeyEvent -> m Sluice +mkSluice' :: MonadUnliftIO m => EventSrc m -> m Sluice mkSluice' s = withRunInIO $ \u -> do bld <- newIORef 0 buf <- newIORef [] - pure $ Sluice (u s) bld buf + pure $ Sluice (unliftESrc u s) bld buf -- | Create a new 'Sluice' environment, but do so in a ContT context -mkSluice :: MonadUnliftIO m => m KeyEvent -> ContT r m Sluice +mkSluice :: MonadUnliftIO m => EventSrc m -> ContT r m Sluice mkSluice = lift . mkSluice' @@ -102,18 +104,18 @@ -- | Try to read from the Sluice, if we are blocked, store the event internally -- and return Nothing. If we are unblocked, return Just the KeyEvent. -step :: HasLogFunc e => Sluice -> RIO e (Maybe KeyEvent) -step s = do - e <- liftIO $ s^.eventSrc - readIORef (s^.blocked) >>= \case - 0 -> pure $ Just e - _ -> do - modifyIORef' (s^.blockBuf) (e:) - readIORef (s^.blockBuf) >>= \es -> do - let xs = map ((" - " <>) . textDisplay) es - logDebug . display . unlines $ "Storing event, current store: ":xs - pure Nothing - --- | Keep trying to read from the Sluice until an event passes through -pull :: HasLogFunc e => Sluice -> RIO e KeyEvent -pull s = step s >>= maybe (pull s) pure +pull :: HasLogFunc e => Sluice -> EventSrc (RIO e) +pull s@Sluice{eventSrc = EventSrc{tryESrc, postESrc}} = EventSrc + { tryESrc = tryESrc + , postESrc = liftIO . postESrc >=> maybe (pure Nothing) step + } + where + step e = do + readIORef (s^.blocked) >>= \case + 0 -> pure $ Just e + _ -> do + modifyIORef' (s^.blockBuf) (e:) + readIORef (s^.blockBuf) >>= \es -> do + let xs = map ((" - " <>) . textDisplay) es + logDebug . display . unlines $ "Storing event, current store: ":xs + pure Nothing diff --git a/src/KMonad/Util.hs b/src/KMonad/Util.hs --- a/src/KMonad/Util.hs +++ b/src/KMonad/Util.hs @@ -21,6 +21,7 @@ -- * Random utility helpers that have no better home , onErr , using + , duplicatesWith , logRethrow -- * Some helpers to launch background process @@ -37,6 +38,8 @@ import Data.Time.Clock import Data.Time.Clock.System +import qualified RIO.NonEmpty as NE + -------------------------------------------------------------------------------- -- $time -- @@ -74,6 +77,10 @@ -- | Embed the action of using an 'Acquire' in a continuation monad using :: Acquire a -> ContT r (RIO e) a using dat = ContT (\next -> with dat $ \a -> next a) + +-- | Get a list duplicates with the selected field identical +duplicatesWith :: Ord b => (a -> b) -> [a] -> [NonEmpty a] +duplicatesWith f = filter (not . null . NE.tail) . NE.groupAllWith f -- | Log an error message and then rethrow the error diff --git a/test/KMonad/ComposeSeqSpec.hs b/test/KMonad/ComposeSeqSpec.hs --- a/test/KMonad/ComposeSeqSpec.hs +++ b/test/KMonad/ComposeSeqSpec.hs @@ -6,32 +6,44 @@ import KMonad.Keyboard.Keycode import KMonad.Parsing import KMonad.Prelude +import KMonad.Util import Test.Hspec -import qualified RIO.NonEmpty as N +import RIO.List (repeat) import qualified RIO.Text as T spec :: Spec spec = describe "compose-sequences" $ do - traverse_ checkComposeSeq ssComposed + validSeqs noDuplicates where noDuplicates = describe "No duplicate compose sequence definitions" $ do noDuplicates' _1 "Compose sequences" noDuplicates' _2 "Characters" noDuplicates' _3 "Character names" - noDuplicates' field desc = it desc $ duplicates (view field) ssComposed `shouldBe` [] - duplicates field = filter (not . null . N.tail) . N.groupAllWith field - checkComposeSeq (expected, c, name) = describe ("Compose sequence for " <> unpack name) $ do - let c' = T.singleton c - let actualSeq = runParser buttonP "" c' - let expectedSeq = runParser (KComposeSeq <$> some buttonP) "" expected - let actualE2E = parseTokens $ "(deflayer " <> c' <> " )" - let expectedE2E = first ParseError expectedSeq <&> \x -> [KDefLayer (DefLayer "" [LButton x])] - it "Is compose sequence" $ actualSeq `shouldSatisfy` parsesAsValidComposeSeq - it "Matches expected" $ actualSeq `shouldBe` expectedSeq - it "Could parse in E2E" $ actualE2E `shouldBe` expectedE2E + noDuplicates' field desc = it desc $ duplicatesWith (view field) ssComposed `shouldBe` [] + validSeqs = describe "Compose sequences are valid" $ + case foldr (zipWith (++)) (repeat []) $ checkComposeSeq <$> ssComposed of + [notCmpSeqs, notAsExpected, notAsExpectedE2E] -> do + it "All are compose sequences" $ notCmpSeqs `shouldBe` [] + it "All match as expected" $ notAsExpected `shouldBe` [] + it "All parse in E2E" $ notAsExpectedE2E `shouldBe` [] + _ -> error "Invalid number of conditions in compose sequence checks" + + checkComposeSeq :: (Text, Char, Text) -> [[Text]] + checkComposeSeq (expected, c, name) = + [ parsesAsValidComposeSeq actualSeq + , actualSeq == expectedSeq + , actualE2E == expectedE2E + ] <&> bool [name] [] + where + actualSeq = runParser buttonP "" c' + expectedSeq = runParser (KComposeSeq <$> some buttonP <* eof) "" expected + actualE2E = parseTokens $ "(deflayer " <> c' <> " )" + expectedE2E = first ParseError expectedSeq <&> \x -> [KDefLayer (DefLayer "" [LButton x])] + c' = T.singleton c + parsesAsValidComposeSeq (Right (KComposeSeq seq')) = all isSimple seq' parsesAsValidComposeSeq _ = False isSimple (KEmit _) = True diff --git a/test/KMonad/KeycodeSpec.hs b/test/KMonad/KeycodeSpec.hs --- a/test/KMonad/KeycodeSpec.hs +++ b/test/KMonad/KeycodeSpec.hs @@ -3,20 +3,19 @@ import KMonad.Keyboard.Keycode import KMonad.Util.MultiMap as Q import KMonad.Prelude +import KMonad.Util import RIO.List (sort) import qualified KMonad.Keyboard.IO.Mac.Types as Mac (kcMapRaw) import qualified KMonad.Keyboard.IO.Windows.Types as Win (winCodeKeyCodeMapping) -import qualified RIO.NonEmpty as N - import Test.Hspec spec :: Spec spec = do it "No duplicate keycode names" $ - dupsWith snd (keyNames ^.. Q.itemed) `shouldBe` [] + duplicatesWith snd (keyNames ^.. Q.itemed) `shouldBe` [] describe "MacOS keycodes" $ checkOsMapping Mac.kcMapRaw describe "Windows keycodes" $ checkOsMapping Win.winCodeKeyCodeMapping @@ -29,6 +28,3 @@ let sortedM' = snd <$> difference it "Raw list is sorted" $ m' `shouldBe` sortedM' -- Only shows unsorted indexes when failing - -dupsWith :: Ord b => (a -> b) -> [a] -> [NonEmpty a] -dupsWith f = filter (not . null . N.tail) . N.groupAllWith f