kmonad 0.4.4 → 0.4.5

raw patch · 30 files changed

+1176/−377 lines, 30 filesdep +hashabledep +hinotifyPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: hashable, hinotify

API changes (from Hackage documentation)

Files

• c_src/keyio_win.c +28/−10
• c_src/mac/dext.cpp +4/−1
• changelog.md +37/−0
• doc/faq.md +336/−0
• doc/hardware-macro-keys.md +151/−0
• doc/quick-reference.md +1/−1
• keymap/tutorial.kbd +43/−12
• kmonad.cabal +9/−2
• src/KMonad/App/Main.hs +12/−4
• src/KMonad/App/Types.hs +3/−1
• src/KMonad/Args/Cmd.hs +10/−12
• src/KMonad/Args/Joiner.hs +55/−31
• src/KMonad/Args/Parser.hs +150/−147
• src/KMonad/Args/Types.hs +3/−3
• src/KMonad/Keyboard/IO.hs +2/−2
• src/KMonad/Keyboard/IO/Linux/DeviceSource.hs +120/−26
• src/KMonad/Keyboard/IO/Mac/IOKitSource.hs +2/−5
• src/KMonad/Keyboard/IO/Mac/KextSink.hs +1/−1
• src/KMonad/Keyboard/IO/Windows/LowLevelHookSource.hs +21/−5
• src/KMonad/Keyboard/IO/Windows/SendEventSink.hs +9/−5
• src/KMonad/Keyboard/IO/Windows/Types.hs +19/−7
• src/KMonad/Keyboard/Keycode.hs +13/−2
• src/KMonad/Model/Button.hs +5/−2
• src/KMonad/Model/Dispatch.hs +14/−24
• src/KMonad/Model/EventSrc.hs +43/−0
• src/KMonad/Model/Hooks.hs +30/−36
• src/KMonad/Model/Sluice.hs +21/−19
• src/KMonad/Util.hs +7/−0
• test/KMonad/ComposeSeqSpec.hs +25/−13
• test/KMonad/KeycodeSpec.hs +2/−6

@@ -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;

@@ -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;

@@ -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 

@@ -0,0 +1,336 @@+<!-- markdown-toc start - Don't edit this section. Run M-x markdown-toc-refresh-toc -->+**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)++<!-- markdown-toc end -->++## 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 <kbd>fn</kbd>. Technically, when+<kbd>F1</kbd> (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 <kbd>fn</kbd> 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+```

@@ -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).

@@ -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")     ``` 

@@ -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 <my-source>`-  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 <my-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 <setting>`.@@ -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)

@@ -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:

@@ -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

@@ -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

@@ -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

@@ -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) 

@@ -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     ]

@@ -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)

@@ -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

@@ -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

@@ -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

@@ -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 ()

@@ -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

@@ -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 

@@ -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`

@@ -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)

@@ -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

@@ -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

@@ -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)

@@ -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+  }

@@ -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

@@ -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

@@ -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 <test> " <> c' <> " )"-    let expectedE2E = first ParseError expectedSeq <&> \x -> [KDefLayer (DefLayer "<test>" [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 <test> " <> c' <> " )"+    expectedE2E = first ParseError expectedSeq <&> \x -> [KDefLayer (DefLayer "<test>" [LButton x])]+    c' = T.singleton c+   parsesAsValidComposeSeq (Right (KComposeSeq seq')) = all isSimple seq'   parsesAsValidComposeSeq _ = False   isSimple (KEmit _) = True

@@ -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