kmonad (empty) → 0.4.1
raw patch · 37 files changed
+6495/−0 lines, 37 filesdep +Win32dep +basedep +cereal
Dependencies added: Win32, base, cereal, kmonad, lens, megaparsec, mtl, optparse-applicative, resourcet, rio, time, unix, unliftio
Files
- LICENSE +20/−0
- app/Main.hs +21/−0
- c_src/keyio.c +76/−0
- c_src/keyio_win.c +266/−0
- c_src/mac/keyio_mac.cpp +354/−0
- changelog.md +9/−0
- kmonad.cabal +103/−0
- src/Data/LayerStack.hs +155/−0
- src/Data/MultiMap.hs +85/−0
- src/KMonad/Action.hs +243/−0
- src/KMonad/App.hs +247/−0
- src/KMonad/App/BEnv.hs +63/−0
- src/KMonad/App/Dispatch.hs +114/−0
- src/KMonad/App/Hooks.hs +199/−0
- src/KMonad/App/Keymap.hs +121/−0
- src/KMonad/App/Sluice.hs +119/−0
- src/KMonad/Args.hs +62/−0
- src/KMonad/Args/Cmd.hs +81/−0
- src/KMonad/Args/Joiner.hs +414/−0
- src/KMonad/Args/Parser.hs +326/−0
- src/KMonad/Args/Types.hs +191/−0
- src/KMonad/Button.hs +355/−0
- src/KMonad/Keyboard.hs +132/−0
- src/KMonad/Keyboard/ComposeSeq.hs +732/−0
- src/KMonad/Keyboard/IO.hs +87/−0
- src/KMonad/Keyboard/IO/Linux/DeviceSource.hs +160/−0
- src/KMonad/Keyboard/IO/Linux/Types.hs +122/−0
- src/KMonad/Keyboard/IO/Linux/UinputSink.hs +169/−0
- src/KMonad/Keyboard/IO/Mac/IOKitSource.hs +81/−0
- src/KMonad/Keyboard/IO/Mac/KextSink.hs +46/−0
- src/KMonad/Keyboard/IO/Mac/Types.hs +306/−0
- src/KMonad/Keyboard/IO/Windows/LowLevelHookSource.hs +84/−0
- src/KMonad/Keyboard/IO/Windows/SendEventSink.hs +64/−0
- src/KMonad/Keyboard/IO/Windows/Types.hs +312/−0
- src/KMonad/Keyboard/Keycode.hs +412/−0
- src/KMonad/Prelude.hs +37/−0
- src/KMonad/Util.hs +127/−0
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2019 David Janssen++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ app/Main.hs view
@@ -0,0 +1,21 @@+{-|+Module : Main+Description : The entry-point to KMonad+Copyright : (c) David Janssen, 2019+License : MIT++Maintainer : janssen.dhj@gmail.com+Stability : experimental+Portability : non-portable (MPTC with FD, FFI to Linux-only c-code)++-}+module Main+ ( -- * The entry-point to KMonad+ main+ )+where++import KMonad.Args (run)++main :: IO ()+main = run
+ c_src/keyio.c view
@@ -0,0 +1,76 @@+#include <stdio.h>+#include <stdlib.h>+#include <signal.h>+#include <string.h>+#include <unistd.h>+#include <linux/input.h>+#include <linux/uinput.h>+#include <fcntl.h>++// Perform an IOCTL grab or release on an open keyboard handle+int ioctl_keyboard(int fd, int grab) {+ return ioctl(fd, EVIOCGRAB, grab);+}++// Acquire a filedescriptor as a uinput keyboard+int acquire_uinput_keysink(int fd, char *name, int vendor, int product, int version) {++ // Designate fd as a keyboard of all keys+ ioctl(fd, UI_SET_EVBIT, EV_KEY);+ int i;+ for (i=0; i < 256; i++) {+ ioctl(fd, UI_SET_KEYBIT, i);+ }++ // Set the vendor details+ struct uinput_setup usetup;+ memset(&usetup, 0, sizeof(usetup));+ usetup.id.bustype = BUS_USB;+ usetup.id.vendor = vendor;+ usetup.id.product = product;+ usetup.id.version = version;++ strcpy(usetup.name, name);+ ioctl(fd, UI_DEV_SETUP, &usetup);++ // Create the device+ ioctl(fd, UI_DEV_CREATE);++ return 0;+}++// Release a uinput keyboard+int release_uinput_keysink(int fd) {+ return ioctl(fd, UI_DEV_DESTROY);+}++// Send a keyboard event through a file-descriptor+int send_event(int fd, int type, int code, int val, int s, int us) {+ struct input_event ie;+ ie.type = type;+ ie.code = code;+ ie.value = val;+ ie.time.tv_sec = s;+ ie.time.tv_usec = us;+ return write(fd, &ie, sizeof(ie));+}++// Print information about memory layout of input_event+void input_event_info() {+ struct input_event event;+ printf("sizeof event is: %d\n", (int) sizeof(event));+ printf("alignof event is: %d\n", (int) __alignof__(event));+ printf("sizeof event.time is: %d\n", (int) sizeof(event.time));+ printf("alignof event.time is: %d\n", (int) __alignof__(event.time));+ printf("sizeof event.time.tv_sec is: %d\n", (int) sizeof(event.time.tv_sec));+ printf("alignof event.time.tv_sec is: %d\n", (int) __alignof__(event.time.tv_sec));+ printf("sizeof event.time.tv_usec is: %d\n", (int) sizeof(event.time.tv_usec));+ printf("alignof event.time.tv_usec is: %d\n", (int) __alignof__(event.time.tv_usec));+ printf("sizeof event.type is: %d\n", (int) sizeof(event.type));+ printf("alignof event.type is: %d\n", (int) __alignof__(event.type));+ printf("sizeof event.code is: %d\n", (int) sizeof(event.code));+ printf("alignof event.code is: %d\n", (int) __alignof__(event.code));+ printf("sizeof event.value is: %d\n", (int) sizeof(event.value));+ printf("alignof event.value is: %d\n", (int) __alignof__(event.value));+}+
+ c_src/keyio_win.c view
@@ -0,0 +1,266 @@+// Necessary to get mingw to compile for some reason+/* #define WINVER 0x0601 */+/* #define _WIN32_WINNT 0x0601 */++#include <windows.h>+#include <stdbool.h>+#include <stdio.h>+++// Type of the key event: 0 Press, 1 Release, 2 Repeat+typedef unsigned char ACTION;+ACTION KEY_PRESS = 0;+ACTION KEY_RELEASE = 1;++// All the information KMonad needs about a key-event+struct KeyEvent {+ ACTION type;+ DWORD keycode;+} KeyEvent;++// Variables we need to access globally+HANDLE readPipe = NULL;+HANDLE writePipe = NULL;+HHOOK hookHandle;++// Print last error and exit program+void last_error()+{ LPVOID lpMsgBuf;+ DWORD dw = GetLastError();++ FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER |+ FORMAT_MESSAGE_FROM_SYSTEM |+ FORMAT_MESSAGE_IGNORE_INSERTS,+ NULL,+ dw,+ MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),+ (LPTSTR) &lpMsgBuf,+ 0, NULL);++ //printf("C: Error: %s", lpMsgBuf);+ exit(dw);+}++// Callback we insert into windows that writes events to pipe+LRESULT CALLBACK keyHandler(int nCode, WPARAM wParam, LPARAM lParam)+{+ // Cast the lParam to a keyboard-event struct+ KBDLLHOOKSTRUCT* e = (KBDLLHOOKSTRUCT*)(lParam);++ // Skip processing if nCode is 0 or this is an injected event+ if (nCode < 0 || e->flags & LLKHF_INJECTED) {+ return CallNextHookEx(hookHandle, nCode, wParam, lParam);+ };++ // Create the KEY_EVENT matching the current event+ ACTION type;+ switch (wParam) {+ case WM_KEYDOWN:+ type = KEY_PRESS;+ break;++ case WM_SYSKEYDOWN:+ type = KEY_PRESS;+ break;++ case WM_KEYUP:+ type = KEY_RELEASE;+ break;++ case WM_SYSKEYUP:+ type = KEY_RELEASE;+ break;+ };++ // Construct the KeyEvent to write to the pipe+ struct KeyEvent ev;+ ev.type = type;+ ev.keycode = e->vkCode;++ // Write the event to the pipe+ DWORD dwWritten;+ WriteFile(writePipe, &ev, sizeof(ev), &dwWritten, NULL);+}++// Read an event from the pipe and write it to the provided pointer+void wait_key(struct KeyEvent* e)+{+ DWORD dwRead;+ ReadFile(readPipe, e, sizeof(e), &dwRead, NULL);+ //printf("receiving: %d\n", e->keycode);+ return;+}++// Insert the keyboard hook and start the monitoring process+int 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;+ while (GetMessage(&msg, NULL, 0, 0))+ { TranslateMessage(&msg);+ DispatchMessage(&msg); }+}++// Uninstall the keyboard hook and kill the process+int release_kb()+{+ UnhookWindowsHookEx(hookHandle);+ PostQuitMessage(0);+ return(0);+}++// Send key to the OS+void sendKey(struct KeyEvent* e)+{+ INPUT ip;++ // Standard stuff we don't use+ ip.type = INPUT_KEYBOARD;+ ip.ki.wScan = 0;+ ip.ki.time = 0;+ ip.ki.dwExtraInfo = 0;+ ip.ki.wVk = e->keycode;+ switch (e->type) {+ case 0:+ ip.ki.dwFlags = 0;+ break;++ case 1:+ ip.ki.dwFlags = KEYEVENTF_KEYUP;+ break;+ }+ //printf("emitting kc: %d\n", ip.ki.wVk);+ // Emit the event to the OS+ SendInput(1, &ip, sizeof(INPUT));+}+++++// OLD STUFF FOR FUTURE REFERENCE++// Tell windows to start sending all keyboard events to hTarget+/* bool HID_RegisterDevice(HWND hTarget, USHORT usage)+{+ RAWINPUTDEVICE hid[1];++ hid[0].usUsagePage = 0x01;+ hid[0].usUsage = usage;+ hid[0].dwFlags = RIDEV_INPUTSINK; // RIDEV_DEVNOTIFY RIDEV_NOLEGACY+ hid[0].hwndTarget = hTarget;++ return RegisterRawInputDevices(&hid, 1, sizeof(RAWINPUTDEVICE));+}+ */+ /* void grab_keyboard(HWND hTarget)+{+ RAWINPUTDEVICE ri[1];++ ri[0].usUsagePage = 0x01;+ ri[0].usUsage = 0x06;+ ri[0].dwFlags = RIDEV_NOLEGACY | RIDEV_INPUTSINK;+ ri[0].hwndTarget = hTarget;++ if (RegisterRawInputDevices(ri, 1, sizeof(ri[0])) == FALSE) {+ last_error();+ }+}+ */++ +/* +// Tell windows to stop sending all keyboard events to hTarget+void HID_UnregisterDevice(USHORT usage)+{+ RAWINPUTDEVICE hid;++ hid.usUsagePage = 1;+ hid.usUsage = usage;+ hid.dwFlags = RIDEV_REMOVE;+ hid.hwndTarget = NULL;++ RegisterRawInputDevices(&hid, 1, sizeof(RAWINPUTDEVICE));+} */+ + + /* Make windows class and window+ //const wchar_t CLASS_NAME[] = L"Sample Window Class";+ static const char* CLASS_NAME = "MESSAGE_ONLY";++ WNDCLASSEX wc;+ wc.cbSize = sizeof(WNDCLASSEX);+ wc.style = 0x0;+ wc.lpszClassName = CLASS_NAME;+ wc.lpfnWndProc = callback;+ wc.hInstance = hInstance;++ wc.hIcon = LoadIcon(NULL, IDI_APPLICATION);+ wc.hIconSm = LoadIcon(NULL, IDI_APPLICATION);+ wc.hCursor = LoadCursor(NULL, IDC_ARROW);+ wc.lpszMenuName = 0;+ wc.cbClsExtra = 0;+ wc.cbWndExtra = 0;+ wc.hbrBackground = NULL;++ fprintf(stdout, "trying to make window class\n");+ if ( !RegisterClassEx(&wc) ) { last_error(); }+ fprintf(stdout, "succeeded");++ fprintf(stdout, "hello\n");+ HWND hwnd = CreateWindowEx(+ 0,+ CLASS_NAME, // Window class+ "kmonad", // Window text+ WS_OVERLAPPEDWINDOW, // Window style++ // Size and position+ 0,0,0,0,+ HWND_MESSAGE, // Parent: message only window+ NULL, // Menu+ hInstance, // Instance+ NULL // Additional data+ );+ ShowWindow(hwnd, cmd_show);+ + +// Windows event callback+LRESULT CALLBACK callback(HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lParam)+{+ switch (uMsg) {++ case WM_DESTROY: {+ PostQuitMessage(0);+ return 0;+ }++ case WM_CLOSE: {+ DestroyWindow(hwnd);+ return 0;+ }++ case WM_INPUT: {+ fprintf(stdout, "hello");+ UINT dwSize;++ GetRawInputData((HRAWINPUT)lParam, RID_INPUT, NULL, &dwSize, sizeof(RAWINPUTHEADER));+ //LPBYTE lpb = new BYTE[dwSize];+ //inf (lpb == NULL) {+ // return 0; }+ return 0;++ }+ }+ return DefWindowProc(hwnd, uMsg, wParam, lParam);+}++int WINAPI WinMain(HINSTANCE hInstance, HINSTANCE hPrev, LPSTR cmd_line, int cmd_show)+{++ */
+ c_src/mac/keyio_mac.cpp view
@@ -0,0 +1,354 @@+#include <IOKit/hid/IOHIDLib.h>+#include <IOKit/hidsystem/IOHIDShared.h>+#include <unistd.h>+#include <errno.h>+#include <thread>+#include <map>+#include <iostream>++#include "karabiner_virtual_hid_device_methods.hpp"++/*+ * Key event information that's shared between C++ and Haskell.+ *+ * type: represents key up or key down+ *+ * keycode: 16 uppermost bits represent IOKit usage page+ * 16 lowermost bits represent IOKit usage+ */+struct KeyEvent {+ uint8_t type;+ uint32_t keycode;+};++/*+ * Resources needed to post altered key events back to the OS. They+ * are global so that they can be kept track of in the C++ code rather+ * than in the Haskell.+ */+static mach_port_t connect;+static io_service_t service;+static pqrs::karabiner_virtual_hid_device::hid_report::keyboard_input keyboard;+static pqrs::karabiner_virtual_hid_device::hid_report::apple_vendor_top_case_input top_case;+static pqrs::karabiner_virtual_hid_device::hid_report::apple_vendor_keyboard_input apple_keyboard;+static pqrs::karabiner_virtual_hid_device::hid_report::consumer_input consumer;++/*+ * These are needed to receive unaltered key events from the OS.+ */+static std::thread thread;+static CFRunLoopRef listener_loop;+static std::map<io_service_t,IOHIDDeviceRef> source_device;+static int fd[2];+static char *prod = nullptr;++/*+ * We'll register this callback to run whenever an IOHIDDevice+ * (representing a keyboard) sends input from the user.+ *+ * It passes the relevant information into a pipe that will be read+ * from with wait_key.+ */+void input_callback(void *context, IOReturn result, void *sender, IOHIDValueRef value) {+ struct KeyEvent e;+ CFIndex integer_value = IOHIDValueGetIntegerValue(value);+ IOHIDElementRef element = IOHIDValueGetElement(value);+ uint16_t usage_page = IOHIDElementGetUsagePage(element);+ uint16_t usage = IOHIDElementGetUsage(element);+ e.type = !integer_value;+ e.keycode = (usage_page << 16) | usage;+ write(fd[1], &e, sizeof(struct KeyEvent));+}++void open_matching_devices(char *product, io_iterator_t iter) {+ io_name_t name;+ kern_return_t kr;+ CFStringRef cfproduct = NULL;+ if(product) {+ cfproduct = CFStringCreateWithCString(kCFAllocatorDefault, product, CFStringGetSystemEncoding());+ if(cfproduct == NULL) {+ std::cerr << "CFStringCreateWithCString error" << std::endl;+ return;+ }+ }+ CFStringRef cfkarabiner = CFStringCreateWithCString(kCFAllocatorDefault, "Karabiner VirtualHIDKeyboard", CFStringGetSystemEncoding());+ if(cfkarabiner == NULL) {+ std::cerr << "CFStringCreateWithCString error" << std::endl;+ if(product) {+ CFRelease(cfproduct);+ }+ return;+ }+ for(mach_port_t curr = IOIteratorNext(iter); curr; curr = IOIteratorNext(iter)) {+ CFStringRef cfcurr = (CFStringRef)IORegistryEntryCreateCFProperty(curr, CFSTR(kIOHIDProductKey), kCFAllocatorDefault, kIOHIDOptionsTypeNone);+ if(cfcurr == NULL) {+ std::cerr << "IORegistryEntryCreateCFProperty error" << std::endl;+ CFRelease(cfcurr);+ continue;+ }+ bool match = (CFStringCompare(cfcurr, cfkarabiner, 0) != kCFCompareEqualTo);+ if(product) {+ match = match && (CFStringCompare(cfcurr, cfproduct, 0) == kCFCompareEqualTo);+ }+ CFRelease(cfcurr);+ if(!match) continue;+ IOHIDDeviceRef dev = IOHIDDeviceCreate(kCFAllocatorDefault, curr);+ source_device[curr] = dev;+ IOHIDDeviceRegisterInputValueCallback(dev, input_callback, NULL);+ kr = IOHIDDeviceOpen(dev, kIOHIDOptionsTypeSeizeDevice);+ if(kr != kIOReturnSuccess) {+ std::cerr << "IOHIDDeviceOpen error: " << std::hex << kr << std::endl;+ if(kr == kIOReturnNotPrivileged) {+ std::cerr << "IOHIDDeviceOpen requires root privileges when called with kIOHIDOptionsTypeSeizeDevice" << std::endl;+ }+ }+ IOHIDDeviceScheduleWithRunLoop(dev, listener_loop, kCFRunLoopDefaultMode);+ }+ if(product) {+ CFRelease(cfproduct);+ }+ CFRelease(cfkarabiner);+}++/*+ * We'll register this callback to run whenever an IOHIDDevice+ * (representing a keyboard) is connected to the OS+ *+ */+void matched_callback(void *context, io_iterator_t iter) {+ char *product = (char *)context;+ open_matching_devices(product, iter);+}++/*+ * We'll register this callback to run whenever an IOHIDDevice+ * (representing a keyboard) is disconnected from the OS+ *+ */+void terminated_callback(void *context, io_iterator_t iter) {+ for(mach_port_t curr = IOIteratorNext(iter); curr; curr = IOIteratorNext(iter)) {+ source_device.erase(curr);+ }+}++/*+ * This gets us some code reuse (see the send_key overload below)+ */+template<typename T>+int send_key(T &keyboard, struct KeyEvent *e) {+ if(e->type == 0) keyboard.keys.insert((uint16_t)e->keycode);+ else if (e->type == 1) keyboard.keys.erase((uint16_t)e->keycode);+ return pqrs::karabiner_virtual_hid_device_methods::post_keyboard_input_report(connect, keyboard);+}++/*+ * Haskell calls this with a new key event to send back to the OS. It+ * posts the information to the karabiner kernel extension (which+ * represents a virtual keyboard).+ */+extern "C" int send_key(struct KeyEvent *e) {+ pqrs::karabiner_virtual_hid_device::usage_page usage_page = pqrs::karabiner_virtual_hid_device::usage_page(e->keycode >> 16);+ if(usage_page == pqrs::karabiner_virtual_hid_device::usage_page::keyboard_or_keypad)+ return send_key(keyboard, e);+ else if(usage_page == pqrs::karabiner_virtual_hid_device::usage_page::apple_vendor_top_case)+ return send_key(top_case, e);+ else if(usage_page == pqrs::karabiner_virtual_hid_device::usage_page::apple_vendor_keyboard)+ return send_key(apple_keyboard, e);+ else if(usage_page == pqrs::karabiner_virtual_hid_device::usage_page::consumer)+ return send_key(consumer, e);+ else+ return 1;+}++/*+ * Reads a new key event from the pipe, blocking until a new event is+ * ready.+ */+extern "C" int wait_key(struct KeyEvent *e) {+ return read(fd[0], e, sizeof(struct KeyEvent)) == sizeof(struct KeyEvent);+}++/*+ * For each keyboard, registers an asynchronous callback to run when+ * new input from the user is available from that keyboard. Then+ * sleeps indefinitely, ready to received asynchronous callbacks.+ */+void monitor_kb(char *product) {+ kern_return_t kr;+ CFMutableDictionaryRef matching_dictionary = IOServiceMatching(kIOHIDDeviceKey);+ if(!matching_dictionary) {+ std::cerr << "IOServiceMatching error" << std::endl;+ return;+ }+ UInt32 value;+ CFNumberRef cfValue;+ value = kHIDPage_GenericDesktop;+ cfValue = CFNumberCreate( kCFAllocatorDefault, kCFNumberSInt32Type, &value );+ CFDictionarySetValue(matching_dictionary, CFSTR(kIOHIDDeviceUsagePageKey), cfValue);+ CFRelease(cfValue);+ value = kHIDUsage_GD_Keyboard;+ cfValue = CFNumberCreate( kCFAllocatorDefault, kCFNumberSInt32Type, &value );+ CFDictionarySetValue(matching_dictionary,CFSTR(kIOHIDDeviceUsageKey),cfValue);+ CFRelease(cfValue);+ io_iterator_t iter = IO_OBJECT_NULL;+ CFRetain(matching_dictionary);+ kr = IOServiceGetMatchingServices(kIOMasterPortDefault,+ matching_dictionary,+ &iter);+ if(kr != KERN_SUCCESS) {+ std::cerr << "IOServiceGetMatchingServices error: " << std::hex << kr << std::endl;+ return;+ }+ listener_loop = CFRunLoopGetCurrent();+ open_matching_devices(product, iter);+ IONotificationPortRef notification_port = IONotificationPortCreate(kIOMasterPortDefault);+ CFRunLoopSourceRef notification_source = IONotificationPortGetRunLoopSource(notification_port);+ CFRunLoopAddSource(listener_loop, notification_source, kCFRunLoopDefaultMode);+ CFRetain(matching_dictionary);+ kr = IOServiceAddMatchingNotification(notification_port,+ kIOMatchedNotification,+ matching_dictionary,+ matched_callback,+ product,+ &iter);+ if(kr != KERN_SUCCESS) {+ std::cerr << "IOServiceAddMatchingNotification error: " << std::hex << kr << std::endl;+ return;+ }+ for(mach_port_t curr = IOIteratorNext(iter); curr; curr = IOIteratorNext(iter)) {}+ kr = IOServiceAddMatchingNotification(notification_port,+ kIOTerminatedNotification,+ matching_dictionary,+ terminated_callback,+ NULL,+ &iter);+ if(kr != KERN_SUCCESS) {+ std::cerr << "IOServiceAddMatchingNotification error: " << std::hex << kr << std::endl;+ return;+ }+ for(mach_port_t curr = IOIteratorNext(iter); curr; curr = IOIteratorNext(iter)) {}+ CFRunLoopRun();+ for(std::pair<const io_service_t,IOHIDDeviceRef> p: source_device) {+ kr = IOHIDDeviceClose(p.second,kIOHIDOptionsTypeSeizeDevice);+ if(kr != KERN_SUCCESS) {+ std::cerr << "IOHIDDeviceClose error: " << std::hex << kr << std::endl;+ }+ }+}++/*+ * Opens and seizes input from each keyboard device whose product name+ * matches the parameter (if NULL is received, then it opens all+ * keyboard devices). Spawns a thread to receive asynchronous input+ * and opens a pipe for this thread to send key event data to the main+ * thread.+ *+ * Loads a the karabiner kernel extension that will send key events+ * back to the OS.+ */+extern "C" int grab_kb(char *product) {+ // Source+ if (pipe(fd) == -1) {+ std::cerr << "pipe error: " << errno << std::endl;+ return errno;+ }+ if(product) {+ prod = (char *)malloc(strlen(product) + 1);+ strcpy(prod, product);+ }+ thread = std::thread{monitor_kb, prod};+ // Sink+ kern_return_t kr;+ connect = IO_OBJECT_NULL;+ service = IOServiceGetMatchingService(kIOMasterPortDefault, IOServiceNameMatching(pqrs::karabiner_virtual_hid_device::get_virtual_hid_root_name()));+ if (!service) {+ std::cerr << "IOServiceGetMatchingService error" << std::endl;+ return 1;+ }+ kr = IOServiceOpen(service, mach_task_self(), kIOHIDServerConnectType, &connect);+ if (kr != KERN_SUCCESS) {+ std::cerr << "IOServiceOpen error: " << std::hex << kr << std::endl;+ return kr;+ }+ //std::this_thread::sleep_for(std::chrono::milliseconds(10000));+ //setuid(501);+ {+ pqrs::karabiner_virtual_hid_device::properties::keyboard_initialization properties;+ kr = pqrs::karabiner_virtual_hid_device_methods::initialize_virtual_hid_keyboard(connect, properties);+ if (kr != KERN_SUCCESS) {+ std::cerr << "initialize_virtual_hid_keyboard error: " << std::hex << kr << std::endl;+ return 1;+ }+ while (true) {+ bool ready;+ kr = pqrs::karabiner_virtual_hid_device_methods::is_virtual_hid_keyboard_ready(connect, ready);+ if (kr != KERN_SUCCESS) {+ std::cerr << "is_virtual_hid_keyboard_ready error: " << std::hex << kr << std::endl;+ return kr;+ } else {+ if (ready) {+ break;+ }+ }+ std::this_thread::sleep_for(std::chrono::milliseconds(100));+ }+ }+ {+ pqrs::karabiner_virtual_hid_device::properties::keyboard_initialization properties;+ properties.country_code = 33;+ kr = pqrs::karabiner_virtual_hid_device_methods::initialize_virtual_hid_keyboard(connect, properties);+ if (kr != KERN_SUCCESS) {+ std::cerr << "initialize_virtual_hid_keyboard error: " << std::hex << kr << std::endl;+ return kr;+ }+ }+ return 0;+}++/*+ * Releases the resources needed to receive key events from and send+ * key events to the OS.+ */+extern "C" int release_kb() {+ int retval = 0;+ kern_return_t kr;+ // Source+ if(thread.joinable()) {+ CFRunLoopStop(listener_loop);+ thread.join();+ } else {+ std::cerr << "no thread was running!" << std::endl;+ }+ if(prod) {+ free(prod);+ }+ if (close(fd[0]) == -1) {+ std::cerr << "close error: " << errno << std::endl;+ retval = 1;+ }+ if (close(fd[1]) == -1) {+ std::cerr << "close error: " << errno << std::endl;+ retval = 1;+ }+ // Sink+ kr = pqrs::karabiner_virtual_hid_device_methods::reset_virtual_hid_keyboard(connect);+ if (kr != KERN_SUCCESS) {+ std::cerr << "reset_virtual_hid_keyboard error: " << std::hex << kr << std::endl;+ retval = 1;+ }+ if (connect) {+ kr = IOServiceClose(connect);+ if(kr != KERN_SUCCESS) {+ std::cerr << "IOServiceClose error: " << std::hex << kr << std::endl;+ retval = 1;+ }+ }+ if (service) {+ kr = IOObjectRelease(service);+ if(kr != KERN_SUCCESS) {+ std::cerr << "IOObjectRelease error: " << std::hex << kr << std::endl;+ retval = 1;+ }+ }+ return retval;+}
+ changelog.md view
@@ -0,0 +1,9 @@+# Changelog+A log of all notable changes to KMonad.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0)++## [Unreleased]++## [0.4.1] - 2020-09-12+- First release where we start tracking changes.
+ kmonad.cabal view
@@ -0,0 +1,103 @@+cabal-version: 2.2+name: kmonad+version: 0.4.1+license: MIT+license-file: LICENSE+maintainer: janssen.dhj@gmail.com+author: David Janssen+synopsis: Advanced keyboard remapping utility+description:+ KMonad is a cross-platform command-line utility that runs as a daemon. It+ captures keyboard input (exactly how depends on the OS) and remaps it. The+ mapping is highly configurable, and provides options like (transparent) layer+ overlays, tap-mod buttons, multi-tap buttons, leader-key style buttons, and+ keyboard macros. Functionality heavily inspired by the QMK-firmware.++category: Application+build-type: Simple+extra-source-files: changelog.md++library+ exposed-modules:+ Data.LayerStack+ Data.MultiMap+ KMonad.Action+ KMonad.App+ KMonad.App.BEnv+ KMonad.App.Dispatch+ KMonad.App.Hooks+ KMonad.App.Keymap+ KMonad.App.Sluice+ KMonad.Args+ KMonad.Args.Cmd+ KMonad.Args.Parser+ KMonad.Args.Joiner+ KMonad.Args.Types+ KMonad.Button+ KMonad.Keyboard+ KMonad.Keyboard.Keycode+ KMonad.Keyboard.ComposeSeq+ KMonad.Keyboard.IO+ KMonad.Prelude+ KMonad.Util++ hs-source-dirs: src+ default-language: Haskell2010+ default-extensions:+ ConstraintKinds DeriveFunctor DeriveGeneric DeriveTraversable+ FlexibleContexts FlexibleInstances FunctionalDependencies+ GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses+ MultiWayIf NoImplicitPrelude OverloadedStrings RankNTypes+ TemplateHaskell TupleSections TypeFamilies++ ghc-options: -Wall -Wno-name-shadowing -Wno-unused-imports+ build-depends:+ base >=4.12.0.0 && <4.13,+ cereal >=0.5.8.1 && <0.6,+ lens >=4.17.1 && <4.18,+ megaparsec >=7.0.5 && <7.1,+ mtl >=2.2.2 && <2.3,+ optparse-applicative >=0.14.3.0 && <0.15,+ resourcet >=1.2.2 && <1.3,+ rio >=0.1.14.0 && <0.2,+ time >=1.8.0.2 && <1.9,+ unliftio >=0.2.12 && <0.3++ if os(linux)+ exposed-modules:+ KMonad.Keyboard.IO.Linux.DeviceSource+ KMonad.Keyboard.IO.Linux.Types+ KMonad.Keyboard.IO.Linux.UinputSink++ c-sources: c_src/keyio.c+ build-depends: unix >=2.7.2.2 && <2.8++ if os(windows)+ exposed-modules:+ KMonad.Keyboard.IO.Windows.LowLevelHookSource+ KMonad.Keyboard.IO.Windows.SendEventSink+ KMonad.Keyboard.IO.Windows.Types++ c-sources: c_src/keyio_win.c+ build-depends: Win32 >=2.6.1.0 && <2.7++ if os(osx)+ exposed-modules:+ KMonad.Keyboard.IO.Mac.IOKitSource+ KMonad.Keyboard.IO.Mac.KextSink+ KMonad.Keyboard.IO.Mac.Types++ cxx-options: -std=c++14+ frameworks: CoreFoundation IOKit+ cxx-sources: c_src/mac/keyio_mac.cpp+ extra-libraries: c+++ build-depends: unix >=2.7.2.2 && <2.8++executable kmonad+ main-is: Main.hs+ hs-source-dirs: app+ default-language: Haskell2010+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.12.0.0 && <4.13,+ kmonad -any
+ src/Data/LayerStack.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-|+Module : Data.LayerStack+Description : A container of overlapping mappings+Copyright : (c) David Janssen, 2019+License : MIT+Maintainer : janssen.dhj@gmail.com+Stability : experimental+Portability : portable++A 'LayerStack' is a set of different mappings between keys and values, and+provides functionality for keeping track of a `stack` of these mappings. Lookup+in a 'LayerStack' happens by checking the front-most mapping on the stack, and+if that fails, descending deeper.++A 'LayerStack' has 3 type parameters, in the documentation we will refer to+those as:+ - l: The layer key, which is the identifier for the different layers+ - k: The item key, which is the per-layer identifier for different items+ - a: The item (value), which is the value stored for k in a particular layer++'LayerStack' is used to implement the basic keymap logic in KMonad, where the+configuration for a keyboard is essentially a set of layers. Each layer maps+keycodes to buttons, and the entire layers can be overlayed on top of eachother.++-}+module Data.LayerStack+ ( -- * Basic types+ -- $types+ Layer+ , mkLayer+ , LayerStack+ , mkLayerStack+ , items+ , maps+ , stack++ -- * Basic operations on LayerStacks+ -- $ops+ , atKey+ , inLayer+ , pushLayer+ , popLayer++ -- * Things that can go wrong with LayerStacks+ -- $err+ , LayerStackError(..)+ , AsLayerStackError(..)+ )++where++import KMonad.Prelude++import RIO.List (delete)++import qualified RIO.HashMap as M+import qualified RIO.HashSet as S++--------------------------------------------------------------------------------+-- $err++-- | The things that can go wrong with a 'LayerStack'+data LayerStackError l+ = LayerDoesNotExist l -- ^ Requested use of a non-existing layer+ | LayerNotOnStack l -- ^ Requested use of a non-stack layer+ deriving Show+makeClassyPrisms ''LayerStackError++instance (Typeable l, Show l) => Exception (LayerStackError l)++--------------------------------------------------------------------------------+-- $constraints++-- | The type of things that can function as either layer or item keys in a+-- LayerStack.+type CanKey k = (Eq k, Hashable k)++--------------------------------------------------------------------------------+-- $types++-- | A 'Layer' is one of the maps contained inside a 'LayerStack'+newtype Layer k a = Layer { unLayer :: M.HashMap k a}+ deriving (Show, Eq, Ord, Functor, Foldable, Traversable)++-- | Create a new 'Layer' from a 'Foldable' of key-value pairs+mkLayer :: (Foldable t, CanKey k) => t (k, a) -> Layer k a+mkLayer = Layer . M.fromList . toList++-- | A 'LayerStack' is a named collection of maps and a sequence of maps to use+-- for lookup.+data LayerStack l k a = LayerStack+ { _stack :: ![l] -- ^ The current stack of layers+ , _maps :: !(S.HashSet l) -- ^ A set of all 'Layer' names+ , _items :: !(M.HashMap (l, k) a) -- ^ The map of all the bindings+ } deriving (Show, Eq, Functor)+makeLenses ''LayerStack+++-- | Create a new 'LayerStack' from a foldable of foldables.+mkLayerStack :: (Foldable t1, Foldable t2, CanKey k, CanKey l)+ => t1 (l, t2 (k, a)) -- ^ The /alist/ of /alists/ describing the mapping+ -> LayerStack l k a+mkLayerStack nestMaps = let+ -- Create a HashMap l (Layer k a) from the listlikes+ hms = M.fromList . map (over _2 mkLayer) $ toList nestMaps+-- -- Create a HashMap (l, k) a from `hms`+ its = M.fromList $ hms ^@.. ifolded <.> (to unLayer . ifolded)+-- -- Create a HashSet of keys from `its`+ kys = S.fromList . M.keys $ hms+ in LayerStack [] kys its++--------------------------------------------------------------------------------+-- $ops++-- | Return a fold of all the items currently mapped to the item-key+--+-- This can be used with 'toListOf' to get an overview of all the items+-- currently mapped to an item-key, or more usefully, with 'firstOf' to simply+-- try a lookup like this: `stack^? atKey KeyA`+atKey :: (CanKey l, CanKey k) => k -> Fold (LayerStack l k a) a+atKey c = folding $ \m -> m ^.. stack . folded . to (getK m) . folded+ where getK m n = fromMaybe [] (pure <$> M.lookup (n, c) (m^.items))++-- | Try to look up a key in a specific layer, regardless of the stack+inLayer :: (CanKey l, CanKey k) => l -> k -> Fold (LayerStack l k a) a+inLayer l c = folding $ \m -> m ^? items . ix (l, c)++-- | Add a layer to the front of the stack and return the new 'LayerStack'.+--+-- If the 'Layer' does not exist, return a 'LayerStackError'. If the 'Layer' is+-- already on the stack, bring it to the front.+--+pushLayer :: (CanKey l, CanKey k)+ => l+ -> LayerStack l k a+ -> Either (LayerStackError l) (LayerStack l k a)+pushLayer n keymap = if n `elem` keymap^.maps+ then Right $ keymap & stack %~ (addFront n)+ else Left $ LayerDoesNotExist n+ where addFront a as = case break (a ==) as of+ (frnt, a':rest) -> a':(frnt <> rest)+ (frnt, []) -> a:frnt++-- | Remove a layer from the stack. If the layer index does not exist on the+-- stack, return a 'LayerNotOnStack', if the layer index does not exist at all+-- in the 'LayerStack', return a 'LayerDoesNotExist'.+popLayer :: (CanKey l, CanKey k)+ => l+ -> LayerStack l k a+ -> Either (LayerStackError l) (LayerStack l k a)+popLayer n keymap = if+ | n `elem` keymap^.stack -> Right $ keymap & stack %~ delete n+ | n `elem` keymap^.maps -> Left $ LayerNotOnStack n+ | otherwise -> Left $ LayerDoesNotExist n
+ src/Data/MultiMap.hs view
@@ -0,0 +1,85 @@+{-|+Module : Data.MultiMap+Description : A `k -> Set v` mapping, with reversing utilities+Copyright : (c) David Janssen, 2019+License : MIT+Maintainer : janssen.dhj@gmail.com+Stability : experimental+Portability : portable++This datastructure represents a `k -> Set v` mapping: that is to say, each key+can have multiple values (but no duplicates). Additionally, we provide some+operations to reverse this mapping.++In KMonad we use this exclusively to easily define multiple names for the same+'KMonad.Keyboard.Keycode' in a reversible manner.++-}+module Data.MultiMap+ ( -- * Types+ -- $typ+ MultiMap+ , mkMultiMap+ , fromSingletons++ -- * Operations on MultiMaps+ -- $ops+ , itemed+ , reverse+ )+where++import KMonad.Prelude hiding (reverse)++import qualified RIO.HashMap as M+import qualified RIO.HashSet as S++--------------------------------------------------------------------------------+-- $typ++-- | All the type constraints required for something to function as a MultiMap+type CanMM k v = (Eq k, Ord v, Hashable k, Hashable v)++-- | The 'MultiMap', which describes a one to many (unique) mapping+newtype MultiMap k v = MultiMap { _unMM :: M.HashMap k (S.HashSet v) }+ deriving Show+makeLenses ''MultiMap++instance (CanMM k v) => Semigroup (MultiMap k v) where+ (MultiMap a) <> (MultiMap b) = MultiMap $ M.unionWith (<>) a b+instance (CanMM k v) => Monoid (MultiMap k v) where+ mempty = MultiMap $ M.empty++type instance Index (MultiMap k v) = k+type instance IxValue (MultiMap k v) = S.HashSet v++instance CanMM k v => Ixed (MultiMap k v)+instance CanMM k v => At (MultiMap k v) where+ at k = unMM . at k++-- | Create a new multimap from a foldable of (k, foldable v) pairs.+mkMultiMap :: (Foldable t1, Foldable t2, CanMM k v)+ => t1 (k, t2 v) -> MultiMap k v+mkMultiMap = foldMap+ ( MultiMap+ . uncurry M.singleton+ . over _2 (S.fromList . toList)+ )++-- | Create a new multimap from a foldable of (k, v) pairs+fromSingletons :: (Foldable t, CanMM k v)+ => t (k, v) -> MultiMap k v+fromSingletons = mkMultiMap . map (over _2 (:[])) . toList++++--------------------------------------------------------------------------------+-- $ops++-- | A fold over all the (k, v) pairs in a 'MultiMap'+itemed :: (CanMM k v) => Fold (MultiMap k v) (k, v)+itemed = folding $ \m -> m ^@.. unMM . ifolded <. folded++-- | Reverse a MultiMap. Note: this is not necessarily a lossless conversion.+reverse :: (CanMM k v, CanMM v k) => MultiMap k v -> MultiMap v k+reverse m = mkMultiMap $ m ^.. itemed . swapped . to (over _2 (:[]))
+ src/KMonad/Action.hs view
@@ -0,0 +1,243 @@+{-|+Module : KMonad.Action+Description : Collection of basic operations+Copyright : (c) David Janssen, 2019+License : MIT+Maintainer : janssen.dhj@gmail.com+Stability : experimental+Portability : portable++KMonad is implemented as an engine that is capable of running 'MonadK' actions.+The logic of various different buttons and keyboard operations are expressed in+this 'MonadK'. This module defines the basic types and operations that make up+'MonadK'. The implementation of how KMonad implements 'MonadK' can be found in+the "KMonad.App" module.++NOTE: All of this is a bit muddled, and redoing the way hooks are handled, and+the basic structuring of MonadK and MonadKIO are liable to change soon.++-}+module KMonad.Action+ (+ KeyPred+ , Catch(..)+ , Trigger(..)+ , Timeout(..)+ , HookLocation(..)+ , Hook(..)++ -- * Lenses+ , HasHook(..)+ , HasTimeout(..)+ , HasTrigger(..)++ -- * Layer operations+ -- $lop+ , LayerOp(..)++ -- * MonadK+ -- $monadk+ , MonadKIO(..)+ , MonadK(..)+ , AnyK+ , Action(..)++ -- * Constituted actions+ -- $combs+ , my+ , matchMy+ , after+ , whenDone+ , await+ , awaitMy+ , tHookF+ , hookF+ , within+ , withinHeld+ )++where++import KMonad.Prelude hiding (timeout)++import KMonad.Keyboard+import KMonad.Util++--------------------------------------------------------------------------------+-- $keyfun++-- | Boolean isomorph signalling wether an event should be caught or not+data Catch = Catch | NoCatch deriving (Show, Eq)++instance Semigroup Catch where+ NoCatch <> NoCatch = NoCatch+ _ <> _ = Catch++instance Monoid Catch where+ mempty = NoCatch++-- | The packet used to trigger a KeyFun, containing info about the event and+-- how long since the Hook was registered.+data Trigger = Trigger+ { _elapsed :: Milliseconds -- ^ Time elapsed since hook was registered+ , _event :: KeyEvent -- ^ The key event triggering this call+ }+makeClassy ''Trigger+++--------------------------------------------------------------------------------+-- $hook+--+-- The general structure of the 'Hook' record, that defines the most general way+-- of registering a 'KeyEvent' function.++-- | ADT signalling where to install a hook+data HookLocation+ = InputHook -- ^ Install the hook immediately after receiving a 'KeyEvent'+ | OutputHook -- ^ Install the hook just before emitting a 'KeyEvent'+ deriving (Eq, Show)++-- | A 'Timeout' value describes how long to wait and what to do upon timeout+data Timeout m = Timeout+ { _delay :: Milliseconds -- ^ Delay before timeout action is triggered+ , _action :: m () -- ^ Action to perform upon timeout+ }+makeClassy ''Timeout++-- | The content for 1 key hook+data Hook m = Hook+ { _hTimeout :: Maybe (Timeout m) -- ^ Optional timeout machinery+ , _keyH :: Trigger -> m Catch -- ^ The function to call on the next 'KeyEvent'+ }+makeClassy ''Hook+++--------------------------------------------------------------------------------+-- $lop+--+-- Operations that manipulate the layer-stack++-- | 'LayerOp' describes all the different layer-manipulations that KMonad+-- supports.+data LayerOp+ = PushLayer LayerTag -- ^ Add a layer to the top of the stack+ | PopLayer LayerTag -- ^ Remove the first occurence of a layer+ | SetBaseLayer LayerTag -- ^ Change the base-layer+++--------------------------------------------------------------------------------+-- $monadk+--+-- The fundamental components that make up any 'KMonad.Button.Button' operation.++-- | 'MonadK' contains all the operations used to constitute button actions. It+-- encapsulates all the side-effects required to get everything running.+class Monad m => MonadKIO m where+ -- | Emit a KeyEvent to the OS+ emit :: KeyEvent -> m ()+ -- | Pause the current thread for n milliseconds+ pause :: Milliseconds -> m ()+ -- | Pause or unpause event processing+ hold :: Bool -> m ()+ -- | Register a callback hook+ register :: HookLocation -> Hook m -> m ()+ -- | Run a layer-stack manipulation+ layerOp :: LayerOp -> m ()+ -- | Insert an event in the input queue+ inject :: KeyEvent -> m ()+ -- | Run a shell-command+ shellCmd :: Text -> m ()++-- | 'MonadKIO' contains the additional bindings that get added when we are+-- currently processing a button.+class MonadKIO m => MonadK m where+ -- | Access the keycode to which the current button is bound+ myBinding :: m Keycode++-- | Type alias for `any monad that can perform MonadK actions`+type AnyK a = forall m. MonadK m => m a++-- | A newtype wrapper used to construct 'MonadK' actions+newtype Action = Action { runAction :: AnyK ()}++--------------------------------------------------------------------------------+-- $util++-- | Create a KeyEvent matching pressing or releasing of the current button.+my :: MonadK m => Switch -> m KeyEvent+my s = mkKeyEvent s <$> myBinding++-- | Register a simple hook without a timeout+hookF :: MonadKIO m => HookLocation -> (KeyEvent -> m Catch) -> m ()+hookF l f = register l . Hook Nothing $ \t -> f (t^.event)++-- | Register a hook with a timeout+tHookF :: MonadK m+ => HookLocation -- ^ Where to install the hook+ -> Milliseconds -- ^ The timeout delay for the hook+ -> m () -- ^ The action to perform on timeout+ -> (Trigger -> m Catch) -- ^ The action to perform on trigger+ -> m () -- ^ The resulting action+tHookF l d a f = register l $ Hook (Just $ Timeout d a) f++-- | Perform an action after a period of time has elapsed+--+-- This is essentially just a way to perform async actions using the KMonad hook+-- system.+after :: MonadK m+ => Milliseconds+ -> m ()+ -> m ()+after d a = do+ let rehook t = after (d - t^.elapsed) a *> pure NoCatch+ tHookF InputHook d a rehook++-- | Perform an action immediately after the current action is finished. NOTE:+-- there is no guarantee that another event doesn't outrace this, only that it+-- will happen as soon as the CPU gets to it.+whenDone :: MonadK m+ => m ()+ -> m ()+whenDone = after 0+++-- | Create a KeyPred that matches the Press or Release of the current button.+matchMy :: MonadK m => Switch -> m KeyPred+matchMy s = (==) <$> my s++-- | Wait for an event to match a predicate and then execute an action+await :: MonadKIO m => KeyPred -> (KeyEvent -> m Catch) -> m ()+await p a = hookF InputHook $ \e -> if p e+ then a e+ else await p a *> pure NoCatch++-- | Execute an action on the detection of the Switch of the active button.+awaitMy :: MonadK m => Switch -> m Catch -> m ()+awaitMy s a = matchMy s >>= flip await (const a)++-- | Try to call a function on a succesful match of a predicate within a certain+-- time period. On a timeout, perform an action.+within :: MonadK m+ => Milliseconds -- ^ The time within which this filter is active+ -> m KeyPred -- ^ The predicate used to find a match+ -> m () -- ^ The action to call on timeout+ -> (Trigger -> m Catch) -- ^ The action to call on a succesful match+ -> m () -- ^ The resulting action+within d p a f = do+ p' <- p+ -- define f' to run action on predicate match, or rehook on predicate mismatch+ let f' t = if p' (t^.event)+ then f t+ else within (d - t^.elapsed) p a f *> pure NoCatch+ tHookF InputHook d a f'++-- | Like `within`, but acquires a hold when starting, and releases when done+withinHeld :: MonadK m+ => Milliseconds -- ^ The time within which this filter is active+ -> m KeyPred -- ^ The predicate used to find a match+ -> m () -- ^ The action to call on timeout+ -> (Trigger -> m Catch) -- ^ The action to call on a succesful match+ -> m () -- ^ The resulting action+withinHeld d p a f = do+ hold True+ within d p (a <* hold False) (\x -> f x <* hold False)
+ src/KMonad/App.hs view
@@ -0,0 +1,247 @@+{-# OPTIONS_GHC -Wno-orphans #-}+{-|+Module : KMonad.App+Description : The central app-loop of KMonad+Copyright : (c) David Janssen, 2019+License : MIT+Maintainer : janssen.dhj@gmail.com+Stability : experimental+Portability : portable++-}+module KMonad.App+ ( AppCfg(..)+ , HasAppCfg(..)+ , startApp+ )+where++import KMonad.Prelude++import UnliftIO.Process (spawnCommand)+import RIO.Text (unpack)++import KMonad.Action+import KMonad.Button+import KMonad.Keyboard+import KMonad.Keyboard.IO+import KMonad.Util+import KMonad.App.BEnv++import qualified KMonad.App.Dispatch as Dp+import qualified KMonad.App.Hooks as Hs+import qualified KMonad.App.Sluice as Sl+import qualified KMonad.App.Keymap as Km++--------------------------------------------------------------------------------+-- $appcfg+--+-- The 'AppCfg' and 'AppEnv' records store the configuration and runtime+-- environment of KMonad's app-loop respectively. This contains nearly all of+-- the components required to run KMonad.+--+-- Note that the 'AppEnv' is still not sufficient to satisfy 'MonadK', since+-- there are times where we are not processing a button push. I.e. 'MonadK' is a+-- series of operations that allow us to specify how to deal with the current+-- button-push, but it required us to have actually registered a push (or+-- release) of some button. 'AppEnv' exists before any buttons have been pushed,+-- and therefore contains no information about 'the current button push' (nor+-- could it). Later in this module we specify KEnv as a combination of AppEnv+-- and a BEnv. It is that environment that we use to satisfy 'MonadK'.++-- | Record of all the configuration options required to run KMonad's core App+-- loop.+data AppCfg = AppCfg+ { _keySinkDev :: Acquire KeySink -- ^ How to open a 'KeySink'+ , _keySourceDev :: Acquire KeySource -- ^ How to open a 'KeySource'+ , _keymapCfg :: LMap Button -- ^ The map defining the 'Button' layout+ , _firstLayer :: LayerTag -- ^ Active layer when KMonad starts+ , _fallThrough :: Bool -- ^ Whether uncaught events should be emitted or not+ , _allowCmd :: Bool -- ^ Whether shell-commands are allowed+ }+makeClassy ''AppCfg+++-- | Environment of a running KMonad app-loop+data AppEnv = AppEnv+ { -- Stored copy of cfg+ _keAppCfg :: AppCfg+ + -- General IO+ , _keLogFunc :: LogFunc+ , _keySink :: KeySink+ , _keySource :: KeySource++ -- Pull chain+ , _dispatch :: Dp.Dispatch+ , _inHooks :: Hs.Hooks+ , _sluice :: Sl.Sluice++ -- Other components+ , _keymap :: Km.Keymap+ , _outHooks :: Hs.Hooks+ , _outVar :: TMVar KeyEvent+ }+makeClassy ''AppEnv++instance HasLogFunc AppEnv where logFuncL = keLogFunc+instance HasAppCfg AppEnv where appCfg = keAppCfg+++--------------------------------------------------------------------------------+-- $init++-- | Initialize all the components of the KMonad app-loop+--+-- NOTE: This is written in 'ContT' over our normal RIO monad. This is just to+-- to simplify a bunch of nesting of calls. At no point do we make use of+-- 'callCC' or other 'ContT' functionality.+--+initAppEnv :: HasLogFunc e => AppCfg -> ContT r (RIO e) AppEnv+initAppEnv cfg = do+ -- Get a reference to the logging function+ lgf <- view logFuncL++ -- Acquire the keysource and keysink+ snk <- using $ cfg^.keySinkDev+ src <- using $ cfg^.keySourceDev++ -- Initialize the pull-chain components+ dsp <- Dp.mkDispatch $ awaitKey src+ ihk <- Hs.mkHooks $ Dp.pull dsp+ slc <- Sl.mkSluice $ Hs.pull ihk++ -- Initialize the button environments in the keymap+ phl <- Km.mkKeymap (cfg^.firstLayer) (cfg^.keymapCfg)++ -- Initialize output components+ otv <- lift . atomically $ newEmptyTMVar+ ohk <- Hs.mkHooks . atomically . takeTMVar $ otv++ -- Setup thread to read from outHooks and emit to keysink+ launch_ "emitter_proc" $ do+ e <- atomically . takeTMVar $ otv+ emitKey snk e+ -- emit e = view keySink >>= flip emitKey e+ pure $ AppEnv+ { _keAppCfg = cfg+ , _keLogFunc = lgf+ , _keySink = snk+ , _keySource = src++ , _dispatch = dsp+ , _inHooks = ihk+ , _sluice = slc++ , _keymap = phl+ , _outHooks = ohk+ , _outVar = otv+ }+++--------------------------------------------------------------------------------+-- $loop+--+-- The central app-loop of KMonad.++-- | Trigger the button-action press currently registered to 'Keycode'+pressKey :: (HasAppEnv e, HasLogFunc e, HasAppCfg e) => Keycode -> RIO e ()+pressKey c =+ view keymap >>= flip Km.lookupKey c >>= \case++ -- If the keycode does not occur in our keymap+ Nothing -> do+ ft <- view fallThrough+ if ft+ then do+ emit $ mkPress c+ await (isReleaseOf c) $ \_ -> do+ emit $ mkRelease c+ pure Catch+ else pure ()++ -- If the keycode does occur in our keymap+ Just b -> runBEnv b Press >>= \case+ Nothing -> pure () -- If the previous action on this key was *not* a release+ Just a -> do+ -- Execute the press and register the release+ app <- view appEnv+ runRIO (KEnv app b) $ do+ runAction a+ awaitMy Release $ do+ runBEnv b Release >>= maybe (pure ()) runAction+ pure Catch++-- | Perform 1 step of KMonad's app loop+--+-- We forever:+-- 1. Pull from the pull-chain until an unhandled event reaches us.+-- 2. If that event is a 'Press' we use our keymap to trigger an action.+loop :: RIO AppEnv ()+loop = forever $ view sluice >>= Sl.pull >>= \case+ e | e^.switch == Press -> pressKey $ e^.keycode+ _ -> pure ()++-- | Run KMonad using the provided configuration+startApp :: HasLogFunc e => AppCfg -> RIO e ()+startApp c = runContT (initAppEnv c) (flip runRIO loop)++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 = view keySink >>= flip emitKey e++ -- Pausing is a simple IO action+ pause = threadDelay . (*1000) . fromIntegral++ -- Holding and rerunning through the sluice and dispatch+ hold b = do+ sl <- view sluice+ di <- view dispatch+ if b then Sl.block sl else Sl.unblock sl >>= Dp.rerun di++ -- Hooking is performed with the hooks component+ register l h = do+ hs <- case l of+ InputHook -> view inHooks+ OutputHook -> view outHooks+ Hs.register hs h++ -- Layer-ops are sent to the 'Keymap'+ layerOp o = view keymap >>= \hl -> Km.layerOp hl o++ -- Injecting by adding to Dispatch's rerun buffer+ inject e = do+ di <- view dispatch+ logDebug $ "Injecting event: " <> display e+ Dp.rerun di [e]++ -- Shell-command through spawnCommand+ shellCmd t = do+ f <- view allowCmd+ if f then do+ logInfo $ "Running command: " <> display t+ void . spawnCommand . unpack $ t+ else+ logInfo $ "Received but not running: " <> display t++--------------------------------------------------------------------------------+-- $kenv+--++-- | The complete environment capable of satisfying 'MonadK'+data KEnv = KEnv+ { _kAppEnv :: AppEnv -- ^ The app environment containing all the components+ , _kBEnv :: BEnv -- ^ The environment describing the currently active button+ }+makeClassy ''KEnv++instance HasAppCfg KEnv where appCfg = kAppEnv.appCfg+instance HasAppEnv KEnv where appEnv = kAppEnv+instance HasBEnv KEnv where bEnv = kBEnv+instance HasLogFunc KEnv where logFuncL = kAppEnv.logFuncL++-- | Hook up all the components to the different 'MonadK' functionalities+instance MonadK (RIO KEnv) where+ -- Binding is found in the stored 'BEnv'+ myBinding = view (bEnv.binding)
+ src/KMonad/App/BEnv.hs view
@@ -0,0 +1,63 @@+{-|+Module : KMonad.App.BEnv+Description : Implementation details behind 'Button'+Copyright : (c) David Janssen, 2019+License : MIT+Maintainer : janssen.dhj@gmail.com+Stability : experimental+Portability : portable++When running KMonad, we need to keep track the last switchstate of a 'Button',+because we only allowing switching, (we have to filter out repeated 'Press' or+'Release' events). Additionally, we keep track of what 'Keycode' a button is+bound to, to provide the 'myBinding' functionality from 'MonadK'.++-}++module KMonad.App.BEnv+ ( BEnv(..)+ , HasBEnv(..)+ , initBEnv+ , runBEnv+ )+where++import KMonad.Prelude++import KMonad.Action+import KMonad.Button+import KMonad.Keyboard++--------------------------------------------------------------------------------+-- $benv+--+-- When running KMonad, a button also keeps track of what keycode it's bound to,+-- and what its last switch was. This is used to provide the 'myBinding' feature+-- of MonadK, and the invariant that switches always alternate (there is no+-- press-press or release-release).++-- | The configuration of a 'Button' with some additional state to keep track of+-- the last 'Switch'+data BEnv = BEnv+ { _beButton :: !Button -- ^ The configuration for this button+ , _binding :: !Keycode -- ^ The 'Keycode' to which this button is bound+ , _lastSwitch :: !(MVar Switch) -- ^ State to keep track of last manipulation+ }+makeClassy ''BEnv++instance HasButton BEnv where button = beButton++-- | Initialize a 'BEnv', note that a key is always initialized in an unpressed+-- state.+initBEnv :: MonadIO m => Button -> Keycode -> m BEnv+initBEnv b c = BEnv b c <$> newMVar Release++-- | Try to switch a 'BEnv'. This only does something if the 'Switch' is+-- different from the 'lastSwitch' field. I.e. pressing a pressed button or+-- releasing a released button does nothing.+runBEnv :: MonadUnliftIO m => BEnv -> Switch -> m (Maybe Action)+runBEnv b a =+ modifyMVar (b^.lastSwitch) $ \l -> pure $ case (a, l) of+ (Press, Release) -> (Press, Just $ b^.pressAction)+ (Release, Press) -> (Release, Just $ b^.releaseAction)+ _ -> (a, Nothing)
+ src/KMonad/App/Dispatch.hs view
@@ -0,0 +1,114 @@+{-|+Module : KMonad.App.Dispatch+Description : Component for async reading.+Copyright : (c) David Janssen, 2019+License : MIT+Maintainer : janssen.dhj@gmail.com+Stability : experimental+Portability : portable++The 'Dispatch' component of the app-loop solves the following problem: we might+at some point during execution be in the following situation:+- We have set our processing to held+- There is a timer running that might unhold at any point+- We are awaiting a key from the OS++This means we need to be able to:+1. Await events from some kind of rerun buffer+2. Await events from the OS+3. Do both of these things without ever entering a race-condition where we lose+ an event because both 1. and 2. happen at exactly the same time.++The Dispatch component provides the ability to read events from some IO action+while at the same time providing a method to write events into the Dispatch,+sending them to the head of the read-queue, while guaranteeing that no events+ever get lost.++In the sequencing of components, the 'Dispatch' occurs first, which means that+it reads directly from the KeySource. Any component after the 'Dispatch' need+not worry about wether an event is being rerun or not, it simply treats all+events as equal.++-}+module KMonad.App.Dispatch+ ( -- $env+ Dispatch+ , mkDispatch++ -- $op+ , pull+ , rerun+ )+where++import KMonad.Prelude+import KMonad.Keyboard++import RIO.Seq (Seq(..), (><))+import qualified RIO.Seq as Seq+import qualified RIO.Text as T++--------------------------------------------------------------------------------+-- $env+--+-- The 'Dispatch' environment, describing what values are required to perform+-- the Dispatch operations, and constructors for creating such an environment.++-- | The 'Dispatch' environment+data Dispatch = Dispatch+ { _eventSrc :: IO KeyEvent -- ^ How to read 1 event+ , _readProc :: TMVar (Async KeyEvent) -- ^ Store for reading process+ , _rerunBuf :: TVar (Seq KeyEvent) -- ^ Buffer for rerunning events+ }+makeLenses ''Dispatch++-- | Create a new 'Dispatch' environment+mkDispatch' :: MonadUnliftIO m => m KeyEvent -> m Dispatch+mkDispatch' s = withRunInIO $ \u -> do+ rpc <- atomically $ newEmptyTMVar+ rrb <- atomically $ newTVar Seq.empty+ pure $ Dispatch (u s) rpc rrb++-- | Create a new 'Dispatch' environment in a 'ContT' environment+mkDispatch :: MonadUnliftIO m => m KeyEvent -> ContT r m Dispatch+mkDispatch = lift . mkDispatch'++--------------------------------------------------------------------------------+-- $op+--+-- The supported 'Dispatch' operations.++-- | Return the next event, this will return either (in order of precedence):+-- 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+ logDebug $ "\n" <> display (T.replicate 80 "-")+ <> "\nRerunning event: " <> display e'+ atomically $ putTMVar (d^.readProc) a+ pure e'+ Right e' -> pure e'++ where+ -- Pop the head off the rerun-buffer (or 'retrySTM' if empty)+ popRerun = readTVar (d^.rerunBuf) >>= \case+ Seq.Empty -> retrySTM+ (e :<| b) -> do+ writeTVar (d^.rerunBuf) b+ pure e++-- | Add a list of elements to be rerun.+rerun :: (HasLogFunc e) => Dispatch -> [KeyEvent] -> RIO e ()+rerun d es = atomically $ modifyTVar (d^.rerunBuf) (>< Seq.fromList es)
+ src/KMonad/App/Hooks.hs view
@@ -0,0 +1,199 @@+{-|+Module : KMonad.App.Hooks+Description : Component for handling hooks+Copyright : (c) David Janssen, 2019+License : MIT+Maintainer : janssen.dhj@gmail.com+Stability : experimental+Portability : portable++Part of the KMonad deferred-decision mechanics are implemented using hooks,+which will call predicates and actions on future keypresses and/or timer events.+The 'Hooks' component is the concrete implementation of this functionality.++In the sequencing of components, this happens second, right after the+'KMonad.App.Dispatch.Dispatch' component.++-}+module KMonad.App.Hooks+ ( Hooks+ , mkHooks+ , pull+ , register+ )+where++import KMonad.Prelude++import Data.Time.Clock.System+import Data.Unique++import KMonad.Action hiding (register)+import KMonad.Keyboard+import KMonad.Util++import RIO.Partial (fromJust)++import qualified RIO.HashMap as M++--------------------------------------------------------------------------------+-- $hooks++++-- -- | A 'Hook' contains the 'KeyPred' and 'Callback'+-- newtype Hook = Hook (KeyPred, Callback IO)+-- makeWrapped ''Hook++-- -- | Create a new 'Hook' value+-- mkHook :: MonadUnliftIO m => KeyPred -> Callback m -> m Hook+-- mkHook p c = withRunInIO $ \u -> pure $ Hook (p, (u . c))++--------------------------------------------------------------------------------+-- $env++data Entry = Entry+ { _time :: SystemTime+ , _eHook :: Hook IO+ }+makeLenses ''Entry++instance HasHook Entry IO where hook = eHook++type Store = M.HashMap Unique Entry++-- | 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+ , _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' s = withRunInIO $ \u -> do+ itr <- atomically $ newEmptyTMVar+ hks <- atomically $ newTVar M.empty+ pure $ Hooks (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 = lift . mkHooks'++-- | Convert a hook in some UnliftIO monad into an IO version, to store it in Hooks+ioHook :: MonadUnliftIO m => Hook m -> m (Hook IO)+ioHook h = withRunInIO $ \u -> do++ t <- case _hTimeout h of+ Nothing -> pure Nothing+ Just t' -> pure . Just $ Timeout (t'^.delay) (u (_action t'))+ let f = \e -> u $ (_keyH h) e+ pure $ Hook t f+++--------------------------------------------------------------------------------+-- $op+--+-- The following code deals with simple operations on the environment, like+-- inserting and removing hooks.++-- | Insert a hook, along with the current time, into the store+register :: (HasLogFunc e)+ => Hooks+ -> Hook (RIO e)+ -> RIO e ()+register hs h = do+ -- Insert an entry into the store+ tag <- liftIO newUnique+ e <- Entry <$> liftIO getSystemTime <*> ioHook h+ atomically $ modifyTVar (hs^.hooks) (M.insert tag e)+ -- 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+ logDebug $ "Registering " <> display (t'^.delay)+ <> "ms hook: " <> display (hashUnique tag)+ threadDelay $ 1000 * (fromIntegral $ t'^.delay)+ atomically $ putTMVar (hs^.injectTmr) tag++-- | Cancel a hook by removing it from the store+cancelHook :: (HasLogFunc e)+ => Hooks+ -> Unique+ -> RIO e ()+cancelHook hs tag = do+ e <- atomically $ do+ m <- readTVar $ hs^.hooks+ let v = M.lookup tag m+ when (isJust v) $ modifyTVar (hs^.hooks) (M.delete tag)+ pure v+ case e of+ Nothing ->+ logDebug $ "Tried cancelling expired hook: " <> display (hashUnique tag)+ Just e' -> do+ logDebug $ "Cancelling hook: " <> display (hashUnique tag)+ liftIO $ e' ^. hTimeout . to fromJust . action+++--------------------------------------------------------------------------------+-- $run+--+-- The following code deals with how we check hooks against incoming events, and+-- 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++-- | Run all hooks on the current event and reset the store+runHooks :: (HasLogFunc e)+ => Hooks+ -> KeyEvent+ -> RIO e (Maybe KeyEvent)+runHooks hs e = do+ logDebug "Running hooks"+ m <- atomically $ swapTVar (hs^.hooks) M.empty+ now <- liftIO getSystemTime+ foldMapM (runEntry now e) (M.elems m) >>= \case+ Catch -> pure $ Nothing+ NoCatch -> pure $ Just e+++--------------------------------------------------------------------------------+-- $loop+--+-- The following code deals with how to use the 'Hooks' component as part of a+-- pull-chain. It contains logic for how to try to pull events from upstream and+-- check them against the hooks, and for how to keep stepping until an unhandled+-- event comes through.++-- | Pull 1 event from the '_eventSrc'. If that action is not caught by any+-- 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)+ => 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)++ -- 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
+ src/KMonad/App/Keymap.hs view
@@ -0,0 +1,121 @@+{-|+Module : KMonad.App.Keymap+Description : Implementation of mapping key-presses to button actions+Copyright : (c) David Janssen, 2019+License : MIT+Maintainer : janssen.dhj@gmail.com+Stability : experimental+Portability : portable++In KMonad we handle all releases (and some other actions) via callback+mechanisms. It is the button-presses that get handled through a keymap. It is+the 'Keymap' component that manages the keymap state and ensures that+incoming events are mapped to++-}+module KMonad.App.Keymap+ ( Keymap+ , mkKeymap+ , layerOp+ , lookupKey+ )+where+++import KMonad.Prelude++import KMonad.Action hiding (layerOp)+import KMonad.Button+import KMonad.Keyboard+import KMonad.App.BEnv++import qualified Data.LayerStack as Ls++--------------------------------------------------------------------------------+-- $env+--+++-- | The 'Keymap' environment containing the current keymap+--+-- NOTE: Since the 'Keymap' will never have to deal with anything+-- asynchronously we can simply use 'IORef's here.+data Keymap = Keymap+ { _stack :: IORef (LMap BEnv)+ , _baseL :: IORef LayerTag+ }+makeClassy ''Keymap++-- | Create a 'Keymap' from a 'Keymap' of uninitialized 'Button's and a+-- tag indicating which layer should start as the base.+mkKeymap' :: MonadUnliftIO m+ => LayerTag -- ^ The initial base layer+ -> LMap Button -- ^ The keymap of 'Button's+ -> m Keymap+mkKeymap' n m = do+ envs <- m & Ls.items . itraversed %%@~ \(_, c) b -> initBEnv b c+ Keymap <$> newIORef envs <*> newIORef n++-- | Create a 'Keymap' but do so in the context of a 'ContT' monad to ease nesting.+mkKeymap :: MonadUnliftIO m => LayerTag -> LMap Button -> ContT r m Keymap+mkKeymap n = lift . mkKeymap' n+++--------------------------------------------------------------------------------+-- $op+--+-- The following code describes how we add and remove layers from the+-- 'Keymap'.++-- | Print a header message followed by an enumeration of the layer-stack+debugReport :: HasLogFunc e => Keymap -> Utf8Builder -> RIO e ()+debugReport h hdr = do+ st <- view Ls.stack <$> (readIORef $ h^.stack)+ let ub = foldMap (\(i, n) -> " " <> display i+ <> ". " <> display n <> "\n")+ (zip ([1..] :: [Int]) st)+ ls <- readIORef (h^.baseL)+ logDebug $ hdr <> "\n" <> ub <> "Base-layer: " <> display ls <> "\n"++-- | Perform operations on the layer-stack+layerOp :: (HasLogFunc e)+ => Keymap -- ^ The 'Keymap' environment+ -> LayerOp -- ^ The 'LayerOp' to perform+ -> RIO e () -- ^ The resulting action+layerOp h o = let km = h^.stack in case o of+ (PushLayer n) -> do+ Ls.pushLayer n <$> readIORef km >>= \case+ Left e -> throwIO e+ Right m' -> writeIORef km m'+ debugReport h $ "Pushed layer to stack: " <> display n++ (PopLayer n) -> do+ Ls.popLayer n <$> readIORef km >>= \case+ Left e -> throwIO e+ Right m' -> writeIORef km m'+ debugReport h $ "Popped layer from stack: " <> display n++ (SetBaseLayer n) -> do+ (n `elem`) . view Ls.maps <$> (readIORef km) >>= \case+ True -> writeIORef (h^.baseL) n+ False -> throwIO $ Ls.LayerDoesNotExist n+ debugReport h $ "Set base layer to: " <> display n+++--------------------------------------------------------------------------------+-- $run+--+-- How we use the 'Keymap' to handle events.++-- | Lookup the 'BEnv' currently mapped to the key press.+lookupKey :: MonadIO m+ => Keymap -- ^ The 'Keymap' to lookup in+ -> Keycode -- ^ The 'Keycode' to lookup+ -> m (Maybe BEnv) -- ^ The resulting action+lookupKey h c = do+ m <- readIORef $ h^.stack+ f <- readIORef $ h^.baseL++ pure $ case m ^? Ls.atKey c of+ Nothing -> m ^? Ls.inLayer f c+ benv -> benv
+ src/KMonad/App/Sluice.hs view
@@ -0,0 +1,119 @@+{-|+Module : KMonad.App.Sluice+Description : The component that provides pausing functionality+Copyright : (c) David Janssen, 2019+License : MIT+Maintainer : janssen.dhj@gmail.com+Stability : experimental+Portability : portable++For certain KMonad operations we need to be able to pause and resume processing+of events. This component provides the ability to temporarily pause processing,+and then resume processing and return all events that were caught while paused.++-}+module KMonad.App.Sluice+ ( Sluice+ , mkSluice+ , block+ , unblock+ , pull+ )+where++import KMonad.Prelude++import KMonad.Keyboard++--------------------------------------------------------------------------------+-- $env++-- | The 'Sluice' environment.+--+-- NOTE: 'Sluice' has no internal multithreading, i.e. its 'pull' action will+-- 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+ , _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' s = withRunInIO $ \u -> do+ bld <- newIORef 0+ buf <- newIORef []+ pure $ Sluice (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 = lift . mkSluice'+++--------------------------------------------------------------------------------+-- $op+--+-- The following code deals with simple operations on the environment, like+-- blocking and unblocking the sluice.++-- | Increase the block-count by 1+block :: HasLogFunc e => Sluice -> RIO e ()+block s = do+ modifyIORef (s^.blocked) (+1)+ readIORef (s^.blocked) >>= \n ->+ logDebug $ "Block level set to: " <> display n++-- | Set the Sluice to unblocked mode, return a list of all the stored events+-- that should be rerun, in the correct order (head was first-in, etc).+--+-- NOTE: After successfully unblocking the 'Sluice' will be empty, it is the+-- caller's responsibility to insert the returned events at an appropriate+-- location in the 'KMonad.App.App'.+--+-- We do this in KMonad by writing the events into the+-- 'KMonad.App.Dispatch.Dispatch's rerun buffer. (this happens in the+-- "KMonad.App" module.)+unblock :: HasLogFunc e => Sluice -> RIO e [KeyEvent]+unblock s = do+ modifyIORef' (s^.blocked) (\n -> n - 1)+ readIORef (s^.blocked) >>= \case+ 0 -> do+ es <- readIORef (s^.blockBuf)+ writeIORef (s^.blockBuf) []+ logDebug $ "Unblocking input stream, " <>+ if null es+ then "no stored events"+ else "rerunning:\n" <> (display . unlines . map textDisplay $ reverse es)+ pure $ reverse es+ n -> do+ logDebug $ "Block level set to: " <> display n+ pure []+++--------------------------------------------------------------------------------+-- $loop+--+-- The following code deals with how a 'Sluice' fits into the KMonad pull-chain.+-- As long as we are blocked, we do not return any events, but keep storing them+-- internally. When we are unblocked, events simply pass through.+++-- | 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
+ src/KMonad/Args.hs view
@@ -0,0 +1,62 @@+{-|+Module : KMonad.Args+Description : How to parse arguments and config files into an AppCfg+Copyright : (c) David Janssen, 2019+License : MIT++Maintainer : janssen.dhj@gmail.com+Stability : experimental+Portability : non-portable (MPTC with FD, FFI to Linux-only c-code)++-}+module KMonad.Args+ ( run )+where++import KMonad.Prelude+import KMonad.App+import KMonad.Args.Cmd+import KMonad.Args.Joiner+import KMonad.Args.Parser+import KMonad.Args.Types++--------------------------------------------------------------------------------+--++-- | Run KMonad+run :: IO ()+run = getCmd >>= runCmd++-- | Execute the provided 'Cmd'+--+-- 1. Construct the log-func+-- 2. Parse the config-file+-- 3. Maybe start KMonad+runCmd :: Cmd -> IO ()+runCmd c = do+ o <- logOptionsHandle stdout False <&> setLogMinLevel (c^.logLvl)+ withLogFunc o $ \f -> runRIO f $ do+ cfg <- loadConfig $ c^.cfgFile+ unless (c^.dryRun) $ startApp cfg++-- | Parse a configuration file into a 'AppCfg' record+loadConfig :: HasLogFunc e => FilePath -> RIO e AppCfg+loadConfig pth = do++ tks <- loadTokens pth -- This can throw a PErrors+ cgt <- joinConfigIO tks -- This can throw a JoinError++ -- Try loading the sink and src+ lf <- view logFuncL+ snk <- liftIO . _snk cgt $ lf+ src <- liftIO . _src cgt $ lf++ -- Assemble the AppCfg record+ pure $ AppCfg+ { _keySinkDev = snk+ , _keySourceDev = src+ , _keymapCfg = _km cgt+ , _firstLayer = _fstL cgt+ , _fallThrough = _flt cgt+ , _allowCmd = _allow cgt+ }
+ src/KMonad/Args/Cmd.hs view
@@ -0,0 +1,81 @@+{-|+Module : KMonad.Args.Cmd+Description : Parse command-line options into a 'Cmd' for KMonad to execute+Copyright : (c) David Janssen, 2019+License : MIT++Maintainer : janssen.dhj@gmail.com+Stability : experimental+Portability : non-portable (MPTC with FD, FFI to Linux-only c-code)++-}+module KMonad.Args.Cmd+ ( Cmd(..)+ , HasCmd(..)+ , getCmd+ )+where++import KMonad.Prelude++import Options.Applicative+++--------------------------------------------------------------------------------+-- $cmd+--+-- The different things KMonad can be instructed to do.++-- | Record describing the instruction to KMonad+data Cmd = Cmd+ { _cfgFile :: FilePath -- ^ Which file to read the config from+ , _dryRun :: Bool -- ^ Flag to indicate we are only test-parsing+ , _logLvl :: LogLevel -- ^ Level of logging to use+ }+ deriving Show+makeClassy ''Cmd++-- | Parse 'Cmd' from the evocation of this program+getCmd :: IO Cmd+getCmd = customExecParser (prefs showHelpOnEmpty) $ info (cmdP <**> helper)+ ( fullDesc+ <> progDesc "Start KMonad"+ <> header "kmonad - an onion of buttons."+ )+++--------------------------------------------------------------------------------+-- $prs+--+-- The different command-line parsers++-- | Parse the full command+cmdP :: Parser Cmd+cmdP = Cmd <$> fileP <*> dryrunP <*> levelP++-- | Parse a filename that points us at the config-file+fileP :: Parser FilePath+fileP = strArgument+ ( metavar "FILE"+ <> help "The configuration file")++-- | Parse a flag that allows us to switch to parse-only mode+dryrunP :: Parser Bool+dryrunP = switch+ ( long "dry-run"+ <> short 'd'+ <> help "If used, do not start KMonad, only try parsing the config file"+ )++-- | Parse the log-level as either a level option or a verbose flag+levelP :: Parser LogLevel+levelP = option f+ ( long "log-level"+ <> short 'l'+ <> metavar "Log level"+ <> value LevelWarn+ <> help "How much info to print out (debug, info, warn, error)" )+ where+ f = maybeReader $ flip lookup [ ("debug", LevelDebug), ("warn", LevelWarn)+ , ("info", LevelInfo), ("error", LevelError) ]+
+ src/KMonad/Args/Joiner.hs view
@@ -0,0 +1,414 @@+{-# LANGUAGE CPP #-}+{-|+Module : KMonad.Args.Joiner+Description : The code that turns tokens into a DaemonCfg+Copyright : (c) David Janssen, 2019+License : MIT++Maintainer : janssen.dhj@gmail.com+Stability : experimental+Portability : non-portable (MPTC with FD, FFI to Linux-only c-code)++We perform configuration parsing in 2 steps:+- 1. We turn the text-file into a token representation+- 2. We check the tokens and turn them into an AppCfg++This module covers step 2.++NOTE: This is where we make a distinction between operating systems.++-}+module KMonad.Args.Joiner+ ( joinConfigIO+ , joinConfig+ )+where++import KMonad.Prelude hiding (uncons)++import KMonad.Args.Types++import KMonad.Action+import KMonad.Button+import KMonad.Keyboard+import KMonad.Keyboard.IO++#ifdef linux_HOST_OS+import KMonad.Keyboard.IO.Linux.DeviceSource+import KMonad.Keyboard.IO.Linux.UinputSink+#endif++#ifdef mingw32_HOST_OS+import KMonad.Keyboard.IO.Windows.LowLevelHookSource+import KMonad.Keyboard.IO.Windows.SendEventSink+#endif++#ifdef darwin_HOST_OS+import KMonad.Keyboard.IO.Mac.IOKitSource+import KMonad.Keyboard.IO.Mac.KextSink+#endif++import Control.Monad.Except++import RIO.List (uncons, headMaybe)+import RIO.Partial (fromJust)+import qualified Data.LayerStack as L+import qualified RIO.HashMap as M+import qualified RIO.Text as T++--------------------------------------------------------------------------------+-- $err++-- | All the things that can go wrong with a joining attempt+data JoinError+ = DuplicateBlock Text+ | MissingBlock Text+ | DuplicateAlias Text+ | DuplicateLayer Text+ | MissingAlias Text+ | MissingLayer Text+ | MissingSetting Text+ | DuplicateSetting Text+ | InvalidOS Text+ | NestedTrans+ | InvalidComposeKey+ | LengthMismatch Text Int Int++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+ DuplicateLayer t -> "Multiple layers of the same name: " <> T.unpack t+ MissingAlias t -> "Reference to non-existent alias: " <> T.unpack t+ MissingLayer t -> "Reference to non-existent layer: " <> T.unpack t+ MissingSetting t -> "Missing setting in 'defcfg': " <> T.unpack t+ DuplicateSetting t -> "Duplicate setting in 'defcfg': " <> T.unpack t+ InvalidOS t -> "Not available under this OS: " <> T.unpack t+ NestedTrans -> "Encountered 'Transparent' ouside 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 ]+++instance Exception JoinError++-- | Joining Config+data JCfg = JCfg+ { _cmpKey :: Button -- ^ How to prefix compose-sequences+ , _kes :: [KExpr] -- ^ The source expresions we operate on+ }+makeLenses ''JCfg++defJCfg :: [KExpr] ->JCfg+defJCfg = JCfg+ (emitB KeyRightAlt)++-- | Monad in which we join, just Except over Reader+newtype J a = J { unJ :: ExceptT JoinError (Reader JCfg) a }+ deriving ( Functor, Applicative, Monad+ , MonadError JoinError , MonadReader JCfg)++-- | Perform a joining computation+runJ :: J a -> JCfg -> Either JoinError a+runJ j = runReader (runExceptT $ unJ j)++--------------------------------------------------------------------------------+-- $full++-- | Turn a list of KExpr into a CfgToken, throwing errors when encountered.+--+-- NOTE: We start joinConfig with the default JCfg, but joinConfig might locally+-- override settings by things it reads from the config itself.+joinConfigIO :: HasLogFunc e => [KExpr] -> RIO e CfgToken+joinConfigIO es = case runJ joinConfig $ defJCfg es of+ Left e -> throwM e+ Right c -> pure c++-- | Extract anything matching a particular prism from a list+extract :: Prism' a b -> [a] -> [b]+extract p = catMaybes . map (preview p)++data SingletonError+ = None+ | Duplicate++-- | Take the head of a list, or else throw the appropriate error+onlyOne :: [a] -> Either SingletonError a+onlyOne xs = case uncons xs of+ Just (x, []) -> Right x+ Just _ -> Left Duplicate+ Nothing -> Left None++-- | Take the one and only block matching the prism from the expressions+oneBlock :: Text -> Prism' KExpr a -> J a+oneBlock t l = onlyOne . extract l <$> view kes >>= \case+ Right x -> pure x+ Left None -> throwError $ MissingBlock t+ Left Duplicate -> throwError $ DuplicateBlock t++-- | Update the JCfg and then run the entire joining process+joinConfig :: J CfgToken+joinConfig = getOverride >>= \cfg -> (local (const cfg) joinConfig')++-- | Join an entire 'CfgToken' from the current list of 'KExpr'.+joinConfig' :: J CfgToken+joinConfig' = do++ es <- view kes++ -- Extract the IO settings+ i <- getI+ o <- getO+ ft <- getFT+ al <- getAllow++ -- Extract the other blocks and join them into a keymap+ let als = extract _KDefAlias $ es+ let lys = extract _KDefLayer $ es+ src <- oneBlock "defsrc" _KDefSrc+ (km, fl) <- joinKeymap src als lys++ pure $ CfgToken+ { _snk = o+ , _src = i+ , _km = km+ , _fstL = fl+ , _flt = ft+ , _allow = al+ }++--------------------------------------------------------------------------------+-- $settings+--+-- TODO: This needs to be seriously refactored: all this code duplication is a+-- sign that something is amiss.++-- | Return a JCfg with all settings from defcfg applied to the env's JCfg+getOverride :: J JCfg+getOverride = do+ env <- ask+ cfg <- oneBlock "defcfg" _KDefCfg+ let getB = joinButton [] M.empty+ let go e v = case v of+ SCmpSeq b -> getB b >>= maybe (throwError InvalidComposeKey)+ (\b' -> pure $ set cmpKey b' e)+ _ -> pure e+ foldM go env cfg++-- | Turn a 'HasLogFunc'-only RIO into a function from LogFunc to IO+runLF :: (forall e. HasLogFunc e => RIO e a) -> LogFunc -> IO a+runLF = flip runRIO+++-- | Extract the KeySource-loader from the 'KExpr's+getI :: J (LogFunc -> IO (Acquire KeySource))+getI = do+ cfg <- oneBlock "defcfg" _KDefCfg+ case onlyOne . extract _SIToken $ cfg of+ Right i -> pickInput i+ Left None -> throwError $ MissingSetting "input"+ Left Duplicate -> throwError $ DuplicateSetting "input"++-- | Extract the KeySource-loader from a 'KExpr's+getO :: J (LogFunc -> IO (Acquire KeySink))+getO = do+ cfg <- oneBlock "defcfg" _KDefCfg+ case onlyOne . extract _SOToken $ cfg of+ Right o -> pickOutput o+ Left None -> throwError $ MissingSetting "input"+ Left Duplicate -> throwError $ DuplicateSetting "input"++-- | Extract the fallthrough setting+getFT :: J Bool+getFT = do+ cfg <- oneBlock "defcfg" _KDefCfg+ case onlyOne . extract _SFallThrough $ cfg of+ Right b -> pure b+ Left None -> pure False+ Left Duplicate -> throwError $ DuplicateSetting "fallthrough"++-- | Extract the fallthrough setting+getAllow :: J Bool+getAllow = do+ cfg <- oneBlock "defcfg" _KDefCfg+ case onlyOne . extract _SAllowCmd $ cfg of+ Right b -> pure b+ Left None -> pure False+ Left Duplicate -> throwError $ DuplicateSetting "allow-cmd"++#ifdef linux_HOST_OS++-- | The Linux correspondence between IToken and actual code+pickInput :: IToken -> J (LogFunc -> IO (Acquire KeySource))+pickInput (KDeviceSource f) = pure $ runLF (deviceSource64 f)+pickInput KLowLevelHookSource = throwError $ InvalidOS "LowLevelHookSource"+pickInput (KIOKitSource _) = throwError $ InvalidOS "IOKitSource"++-- | The Linux correspondence between OToken and actual code+pickOutput :: OToken -> J (LogFunc -> IO (Acquire KeySink))+pickOutput (KUinputSink t init) = pure $ runLF (uinputSink cfg)+ where cfg = defUinputCfg { _keyboardName = T.unpack t+ , _postInit = T.unpack <$> init }+pickOutput KSendEventSink = throwError $ InvalidOS "SendEventSink"+pickOutput KKextSink = throwError $ InvalidOS "KextSink"++#endif++#ifdef mingw32_HOST_OS++-- | 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 (KIOKitSource _) = throwError $ InvalidOS "IOKitSource"++-- | The Windows correspondence between OToken and actual code+pickOutput :: OToken -> J (LogFunc -> IO (Acquire KeySink))+pickOutput KSendEventSink = pure $ runLF sendEventKeySink+pickOutput (KUinputSink _ _) = throwError $ InvalidOS "UinputSink"+pickOutput KKextSink = throwError $ InvalidOS "KextSink"++#endif++#ifdef darwin_HOST_OS++-- | 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 KLowLevelHookSource = throwError $ InvalidOS "LowLevelHookSource"++-- | The Mac correspondence between OToken and actual code+pickOutput :: OToken -> J (LogFunc -> IO (Acquire KeySink))+pickOutput KKextSink = pure $ runLF kextSink+pickOutput (KUinputSink _ _) = throwError $ InvalidOS "UinputSink"+pickOutput KSendEventSink = throwError $ InvalidOS "SendEventSink"++#endif++--------------------------------------------------------------------------------+-- $als++type Aliases = M.HashMap Text Button+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)++--------------------------------------------------------------------------------+-- $but++-- | Turn 'Nothing's (caused by joining a KTrans) into the appropriate error.+-- KTrans buttons may only occur in 'DefLayer' definitions.+unnest :: J (Maybe Button) -> J Button+unnest = join . fmap (maybe (throwError NestedTrans) (pure . id))++-- | Turn a button token into an actual KMonad `Button` value+joinButton :: LNames -> Aliases -> DefButton -> J (Maybe Button)+joinButton ns als =++ -- Define some utility functions+ let ret = pure . Just+ go = unnest . joinButton ns als+ jst = fmap Just+ fi = fromIntegral+ in \case+ -- Variable dereference+ KRef t -> case M.lookup t als of+ Nothing -> throwError $ MissingAlias t+ Just b -> ret b++ -- Various simple buttons+ KEmit c -> ret $ emitB c+ KCommand t -> ret $ cmdButton t+ KLayerToggle t -> if t `elem` ns+ then ret $ layerToggle t+ else throwError $ MissingLayer t+ KLayerSwitch t -> if t `elem` ns+ then ret $ layerSwitch t+ else throwError $ MissingLayer t+ KLayerAdd t -> if t `elem` ns+ then ret $ layerAdd t+ else throwError $ MissingLayer t+ KLayerRem t -> if t `elem` ns+ then ret $ layerRem t+ else throwError $ MissingLayer t+ KLayerDelay s t -> if t `elem` ns+ then ret $ layerDelay (fi s) t+ else throwError $ MissingLayer t+ KLayerNext t -> if t `elem` ns+ then ret $ layerNext t+ else throwError $ MissingLayer t++ -- Various compound buttons+ KComposeSeq bs -> view cmpKey >>= \c -> jst $ tapMacro . (c:) <$> mapM go bs+ KTapMacro bs -> jst $ tapMacro <$> mapM go bs+ KAround o i -> jst $ around <$> go o <*> go i+ KTapNext t h -> jst $ tapNext <$> go t <*> go h+ KTapHold s t h -> jst $ tapHold (fi s) <$> go t <*> go h+ KTapHoldNext s t h -> jst $ tapHoldNext (fi s) <$> go t <*> go h+ KTapNextRelease t h -> jst $ tapNextRelease <$> go t <*> go h+ KTapHoldNextRelease ms t h+ -> jst $ tapHoldNextRelease (fi ms) <$> go t <*> go h+ KAroundNext b -> jst $ aroundNext <$> go b+ KPause ms -> jst . pure $ onPress (pause ms)+ KMultiTap bs d -> jst $ multiTap <$> go d <*> mapM f bs+ where f (ms, b) = (fi ms,) <$> go b++ -- Non-action buttons+ KTrans -> pure Nothing+ KBlock -> ret pass+++--------------------------------------------------------------------------------+-- $kmap++-- | Join the defsrc, defalias, and deflayer layers into a Keymap of buttons and+-- the name signifying the initial layer to load.+joinKeymap :: DefSrc -> [DefAlias] -> [DefLayer] -> J (LMap Button, LayerTag)+joinKeymap _ _ [] = throwError $ MissingBlock "deflayer"+joinKeymap src 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+ lys' <- mapM (joinLayer als' nms src) lys -- Join all layers+ -- Return the layerstack and the name of the first layer+ pure $ (L.mkLayerStack lys', _layerName . fromJust . headMaybe $ lys)++-- | Check and join 1 deflayer.+joinLayer ::+ Aliases -- ^ Mapping of names to buttons+ -> LNames -- ^ List of valid layer names+ -> DefSrc -- ^ Layout of the source layer+ -> DefLayer -- ^ The layer token to join+ -> J (Text, [(Keycode, Button)]) -- ^ The resulting tuple+joinLayer als ns src DefLayer{_layerName=n, _buttons=bs} = do++ -- 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+ (n,) <$> foldM f [] (zip src bs)+++--------------------------------------------------------------------------------+-- $test++-- fname :: String+-- fname = "/home/david/prj/hask/kmonad/doc/example.kbd"++-- test :: IO (J DefCfg)+-- test = runRIO () . fmap joinConfig $ loadTokens fname
+ src/KMonad/Args/Parser.hs view
@@ -0,0 +1,326 @@+{-|+Module : KMonad.Args.Parser+Description : How to turn a text-file into config-tokens+Copyright : (c) David Janssen, 2019+License : MIT++Maintainer : janssen.dhj@gmail.com+Stability : experimental+Portability : non-portable (MPTC with FD, FFI to Linux-only c-code)++We perform configuration parsing in 2 steps:+- 1. We turn the text-file into a token representation+- 2. We check the tokens and turn them into an AppCfg++This module covers step 1.++-}+module KMonad.Args.Parser+ ( parseTokens+ , loadTokens+ )+where++import KMonad.Prelude hiding (try, bool)++import KMonad.Args.Types+import KMonad.Keyboard+import KMonad.Keyboard.ComposeSeq++import Data.Char+import RIO.List (sortBy, find)+++import qualified Data.MultiMap as Q+import qualified RIO.Text as T+import qualified Text.Megaparsec.Char.Lexer as L+++--------------------------------------------------------------------------------+-- $run++-- | Try to parse a list of 'KExpr' from 'Text'+parseTokens :: Text -> Either PErrors [KExpr]+parseTokens t = case runParser configP "" t of+ Left e -> Left $ PErrors e+ Right x -> Right x++-- | Load a set of tokens from file, throw an error on parse-fail+loadTokens :: FilePath -> RIO e [KExpr]+loadTokens pth = parseTokens <$> readFileUtf8 pth >>= \case+ Left e -> throwM e+ Right xs -> pure xs+++--------------------------------------------------------------------------------+-- $basic++-- | Consume whitespace+sc :: Parser ()+sc = L.space+ space1+ (L.skipLineComment ";;")+ (L.skipBlockComment "#|" "|#")++-- | Consume whitespace after the provided parser+lexeme :: Parser a -> Parser a+lexeme = L.lexeme sc++-- | Consume 1 symbol+symbol :: Text -> Parser ()+symbol = void . L.symbol sc++-- | List of all characters that /end/ a word or sequence+terminators :: String+terminators = ")\""++terminatorP :: Parser Char+terminatorP = satisfy (`elem` terminators)++-- | Consume all chars until a space is encounterd+word :: Parser Text+word = T.pack <$> some (satisfy wordChar)+ where wordChar c = not (isSpace c || c `elem` terminators)++-- | Run the parser IFF it is followed by a space, eof, or reserved char+terminated :: Parser a -> Parser a+terminated p = try $ p <* lookAhead (void spaceChar <|> eof <|> void 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)++-- | 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) *> pure x++-- | 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" *> pure True+ <|> symbol "false" *> pure False++--------------------------------------------------------------------------------+-- $elem+--+-- Parsers for elements that are not stand-alone KExpr's++-- | Parse a keycode+keycodeP :: Parser Keycode+keycodeP = fromNamed (Q.reverse keyNames ^.. Q.itemed) <?> "keycode"++-- | Parse an integer+numP :: Parser Int+numP = L.decimal++-- | Parse text with escaped characters between "s+textP :: Parser Text+textP = do+ _ <- char '\"'+ s <- manyTill L.charLiteral (char '\"')+ pure . T.pack $ s++-- | Parse a variable reference+derefP :: Parser Text+derefP = prefix (char '@') *> word++--------------------------------------------------------------------------------+-- $cmb+--+-- Parsers built up from the basic KExpr's++-- | Consume an entire file of expressions and comments+configP :: Parser [KExpr]+configP = sc *> exprsP <* eof++-- | Parse 0 or more KExpr's+exprsP :: Parser [KExpr]+exprsP = lexeme . many $ lexeme 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)+ ]++--------------------------------------------------------------------------------+-- $but+--+-- All the various ways to refer to buttons++-- | Different ways to refer to shifted versions of keycodes+shiftedNames :: [(Text, DefButton)]+shiftedNames = let f = second $ \kc -> KAround (KEmit KeyLeftShift) (KEmit kc) in+ map f $ cps <> num <> oth+ where+ cps = zip (map T.singleton ['A'..'Z'])+ [ KeyA, KeyB, KeyC, KeyD, KeyE, KeyF, KeyG, KeyH, KeyI, KeyJ, KeyK, KeyL, KeyM,+ KeyN, KeyO, KeyP, KeyQ, KeyR, KeyS, KeyT, KeyU, KeyV, KeyW, KeyX, KeyY, KeyZ ]+ num = zip (map T.singleton "!@#$%^&*")+ [ Key1, Key2, Key3, Key4, Key5, Key6, Key7, Key8 ]+ oth = zip (map T.singleton "<>:~\"|{}+?")+ [ KeyComma, KeyDot, KeySemicolon, KeyGrave, KeyApostrophe, KeyBackslash+ , KeyLeftBrace, KeyRightBrace, KeyEqual, KeySlash]++-- | Names for various buttons+buttonNames :: [(Text, DefButton)]+buttonNames = shiftedNames <> escp <> util+ where+ emitS c = KAround (KEmit KeyLeftShift) (KEmit c)+ -- Escaped versions for reserved characters+ escp = [ ("\\(", emitS Key9), ("\\)", emitS Key0)+ , ("\\_", emitS KeyMinus), ("\\\\", KEmit KeyBackslash)]+ -- Extra names for useful buttons+ util = [ ("_", KTrans), ("XX", KBlock)+ , ("lprn", emitS Key9), ("rprn", emitS Key0)]++++-- | Parse "X-b" style modded-sequences+moddedP :: Parser DefButton+moddedP = KAround <$> prfx <*> buttonP+ where mods = [ ("S-", KeyLeftShift), ("C-", KeyLeftCtrl)+ , ("A-", KeyLeftAlt), ("M-", KeyLeftMeta)+ , ("RS-", KeyRightShift), ("RC-", KeyRightCtrl)+ , ("RA-", KeyRightAlt), ("RM-", KeyRightMeta)]+ prfx = choice $ map (\(t, p) -> prefix (string t) *> pure (KEmit p)) mods++-- | Parse Pxxx as pauses (useful in macros)+pauseP :: Parser DefButton+pauseP = KPause . fromIntegral <$> (char 'P' *> numP)++-- | #()-syntax tap-macro+rmTapMacroP :: Parser DefButton+rmTapMacroP = KTapMacro <$> (char '#' *> paren (some buttonP))++-- | 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++ -- If matching, parse a button-sequence from the stored text+ case runParser (some buttonP) "" s of+ Left _ -> fail "Could not parse compose sequence"+ 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))+ case runParser buttonP "" (T.singleton c) of+ Left _ -> fail "Could not parse deadkey sequence"+ Right b -> pure [b]++-- | Parse any button+buttonP :: Parser DefButton+buttonP = (lexeme . choice . map try $+ [ statement "around" $ KAround <$> buttonP <*> buttonP+ , statement "multi-tap" $ KMultiTap <$> timed <*> buttonP+ , statement "tap-hold" $ KTapHold <$> lexeme numP <*> buttonP <*> buttonP+ , statement "tap-hold-next" $ KTapHoldNext <$> lexeme numP <*> buttonP <*> buttonP+ , statement "tap-next-release"+ $ KTapNextRelease <$> buttonP <*> buttonP+ , statement "tap-hold-next-release"+ $ KTapHoldNextRelease <$> lexeme numP <*> buttonP <*> buttonP+ , statement "tap-next" $ KTapNext <$> buttonP <*> buttonP+ , statement "layer-toggle" $ KLayerToggle <$> word+ , statement "layer-switch" $ KLayerSwitch <$> word+ , statement "layer-add" $ KLayerAdd <$> word+ , statement "layer-rem" $ KLayerRem <$> word+ , statement "layer-delay" $ KLayerDelay <$> lexeme numP <*> word+ , statement "layer-next" $ KLayerNext <$> word+ , statement "around-next" $ KAroundNext <$> buttonP+ , statement "tap-macro" $ KTapMacro <$> some buttonP+ , statement "cmd-button" $ KCommand <$> textP+ , statement "pause" $ KPause . fromIntegral <$> numP+ , KComposeSeq <$> deadkeySeqP+ , KRef <$> derefP+ , lexeme $ fromNamed buttonNames+ , try moddedP+ , lexeme $ try rmTapMacroP+ , lexeme $ try pauseP+ , KEmit <$> keycodeP+ , KComposeSeq <$> composeSeqP+ ]) <?> "button"++ where+ timed = many ((,) <$> lexeme numP <*> lexeme buttonP)+++--------------------------------------------------------------------------------+-- $defcfg++-- | Parse an input token+itokenP :: Parser IToken+itokenP = choice . map try $+ [ statement "device-file" $ KDeviceSource <$> (T.unpack <$> textP)+ , statement "low-level-hook" $ pure KLowLevelHookSource+ , statement "iokit-name" $ KIOKitSource <$> optional textP]++-- | Parse an output token+otokenP :: Parser OToken+otokenP = choice . map try $+ [ statement "uinput-sink" $ KUinputSink <$> lexeme textP <*> optional textP+ , statement "send-event-sink" $ pure KSendEventSink+ , statement "kext" $ pure KKextSink]++-- | Parse the DefCfg token+defcfgP :: Parser DefSettings+defcfgP = some (lexeme 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+ , SInitStr <$> f "init" textP+ , SFallThrough <$> f "fallthrough" bool+ , SAllowCmd <$> f "allow-cmd" bool+ ])++--------------------------------------------------------------------------------+-- $defalias++-- | Parse a collection of names and buttons+defaliasP :: Parser DefAlias+defaliasP = many $ (,) <$> lexeme word <*> buttonP++--------------------------------------------------------------------------------+-- $defsrc++defsrcP :: Parser DefSrc+defsrcP = many $ lexeme keycodeP+++--------------------------------------------------------------------------------+-- $deflayer+deflayerP :: Parser DefLayer+deflayerP = DefLayer <$> lexeme word <*> many (lexeme buttonP)+
+ src/KMonad/Args/Types.hs view
@@ -0,0 +1,191 @@+{-|+Module : KMonad.Args.Types+Description : The basic types of configuration parsing.+Copyright : (c) David Janssen, 2019+License : MIT++Maintainer : janssen.dhj@gmail.com+Stability : experimental+Portability : non-portable (MPTC with FD, FFI to Linux-only c-code)++-}+module KMonad.Args.Types+ ( -- * $bsc+ Parser+ , PErrors(..)++ -- * $cfg+ , CfgToken(..)++ -- * $but+ , DefButton(..)++ -- * $tls+ , DefSetting(..)+ , DefSettings+ , DefAlias+ , DefLayer(..)+ , DefSrc+ , KExpr(..)++ -- * $defio+ , IToken(..)+ , OToken(..)++ -- * $lenses+ , AsKExpr(..)+ , AsDefSetting(..)++ -- * Reexports+ , module Text.Megaparsec+ , module Text.Megaparsec.Char+) where+++import KMonad.Prelude++import KMonad.Button+import KMonad.Keyboard+import KMonad.Keyboard.IO+import KMonad.Util++import Text.Megaparsec+import Text.Megaparsec.Char++--------------------------------------------------------------------------------+-- $bsc+--+-- The basic types of parsing++-- | Parser's operate on Text and carry no state+type Parser = Parsec Void Text++-- | The type of errors returned by the Megaparsec parsers+newtype PErrors = PErrors (ParseErrorBundle Text Void)++instance Show PErrors where+ show (PErrors e) = "Parse error at " <> errorBundlePretty e++instance Exception PErrors++--------------------------------------------------------------------------------+-- $but+--+-- Tokens representing different types of buttons++-- | Button ADT+data DefButton+ = KRef Text -- ^ Reference a named button+ | KEmit Keycode -- ^ Emit a keycode+ | KLayerToggle Text -- ^ Toggle to a layer when held+ | KLayerSwitch Text -- ^ Switch base-layer when pressed+ | KLayerAdd Text -- ^ Add a layer when pressed+ | KLayerRem Text -- ^ Remove top instance of a layer when pressed+ | KTapNext DefButton DefButton -- ^ Do 2 things based on behavior+ | KTapHold Int DefButton DefButton -- ^ Do 2 things based on behavior and delay+ | KTapHoldNext Int DefButton DefButton -- ^ Mixture between KTapNext and KTapHold+ | KTapNextRelease DefButton DefButton -- ^ Do 2 things based on behavior+ | KTapHoldNextRelease Int DefButton DefButton+ -- ^ Like KTapNextRelease but with a timeout+ | KAroundNext DefButton -- ^ Surround a future button+ | KMultiTap [(Int, DefButton)] DefButton -- ^ Do things depending on tap-count+ | KAround DefButton DefButton -- ^ Wrap 1 button around another+ | KTapMacro [DefButton] -- ^ Sequence of buttons to tap+ | KComposeSeq [DefButton] -- ^ Compose-key sequence+ | KPause Milliseconds -- ^ Pause for a period of time+ | KLayerDelay Int LayerTag -- ^ Switch to a layer for a period of time+ | KLayerNext LayerTag -- ^ Perform next button in different layer+ | KCommand Text -- ^ Execute a shell command+ | KTrans -- ^ Transparent button that does nothing+ | KBlock -- ^ Button that catches event+ deriving Show+++--------------------------------------------------------------------------------+-- $cfg+--+-- The Cfg token that can be extracted from a config-text without ever enterring+-- IO. This will then directly be translated to a DaemonCfg+--++-- | The 'CfgToken' contains all the data needed to construct an+-- 'KMonad.App.AppCfg'.+data CfgToken = CfgToken+ { _src :: LogFunc -> IO (Acquire KeySource) -- ^ How to grab the source keyboard+ , _snk :: LogFunc -> IO (Acquire KeySink) -- ^ How to construct the out keybboard+ , _km :: LMap Button -- ^ An 'LMap' of 'Button' actions+ , _fstL :: LayerTag -- ^ Name of initial layer+ , _flt :: Bool -- ^ How to deal with unhandled events+ , _allow :: Bool -- ^ Whether to allow shell commands+ }+makeClassy ''CfgToken+++--------------------------------------------------------------------------------+-- $tls+--+-- A collection of all the different top-level statements possible in a config+-- file.++-- | A list of keycodes describing the ordering of all the other layers+type DefSrc = [Keycode]++-- | A mapping from names to button tokens+type DefAlias = [(Text, DefButton)]++-- | A layer of buttons+data DefLayer = DefLayer+ { _layerName :: Text -- ^ A unique name used to refer to this layer+ , _buttons :: [DefButton] -- ^ A list of button tokens+ }+ deriving Show+++--------------------------------------------------------------------------------+-- $defcfg+--+-- Different settings++-- | All different input-tokens KMonad can take+data IToken+ = KDeviceSource FilePath+ | KLowLevelHookSource+ | KIOKitSource (Maybe Text)+ deriving Show++-- | All different output-tokens KMonad can take+data OToken+ = KUinputSink Text (Maybe Text)+ | KSendEventSink+ | KKextSink+ deriving Show++-- | All possible single settings+data DefSetting+ = SIToken IToken+ | SOToken OToken+ | SCmpSeq DefButton+ | SInitStr Text+ | SFallThrough Bool+ | SAllowCmd Bool+ deriving Show+makeClassyPrisms ''DefSetting++-- | A list of different 'DefSetting' values+type DefSettings = [DefSetting]++--------------------------------------------------------------------------------+-- $tkn++-- | Any statement in a config-file must parse to a 'KExpr'+data KExpr+ = KDefCfg DefSettings+ | KDefSrc DefSrc+ | KDefLayer DefLayer+ | KDefAlias DefAlias+ deriving Show+makeClassyPrisms ''KExpr+++--------------------------------------------------------------------------------+-- $act
+ src/KMonad/Button.hs view
@@ -0,0 +1,355 @@+{-|+Module : KMonad.Button+Description : How buttons work+Copyright : (c) David Janssen, 2019+License : MIT+Maintainer : janssen.dhj@gmail.com+Stability : experimental+Portability : portable++A button contains 2 actions, one to perform on press, and another to perform on+release. This module contains that definition, and some helper code that helps+combine buttons. It is here that most of the complicated` buttons are+implemented (like TapHold).++-}+module KMonad.Button+ ( -- * Button basics+ -- $but+ Button+ , HasButton(..)+ , onPress+ , mkButton+ , around+ , tapOn++ -- * Simple buttons+ -- $simple+ , emitB+ , modded+ , layerToggle+ , layerSwitch+ , layerAdd+ , layerRem+ , pass+ , cmdButton++ -- * Button combinators+ -- $combinators+ , aroundNext+ , layerDelay+ , layerNext+ , tapHold+ , multiTap+ , tapNext+ , tapHoldNext+ , tapNextRelease+ , tapHoldNextRelease+ , tapMacro+ )+where++import KMonad.Prelude++import KMonad.Action+import KMonad.Keyboard+import KMonad.Util+++--------------------------------------------------------------------------------+-- $but+--+-- This section contains the basic definition of KMonad's 'Button' datatype. A+-- 'Button' is essentially a collection of 2 different actions, 1 to perform on+-- 'Press' and another on 'Release'.++-- | A 'Button' consists of two 'MonadK' actions, one to take when a press is+-- registered from the OS, and another when a release is registered.+data Button = Button+ { _pressAction :: !Action -- ^ Action to take when pressed+ , _releaseAction :: !Action -- ^ Action to take when released+ }+makeClassy ''Button++-- | Create a 'Button' out of a press and release action+--+-- NOTE: Since 'AnyK' is an existentially qualified 'MonadK', the monadic+-- actions specified must be runnable by all implementations of 'MonadK', and+-- therefore can only rely on functionality from 'MonadK'. I.e. the actions must+-- be pure 'MonadK'.+mkButton :: AnyK () -> AnyK () -> Button+mkButton a b = Button (Action a) (Action b)++-- | Create a new button with only a 'Press' action+onPress :: AnyK () -> Button+onPress p = mkButton p $ pure ()+++--------------------------------------------------------------------------------+-- $running+--+-- Triggering the actions stored in a 'Button'.++-- | Perform both the press and release of a button immediately+tap :: MonadK m => Button -> m ()+tap b = do+ runAction $ b^.pressAction+ runAction $ b^.releaseAction++-- | Perform the press action of a Button and register its release callback.+--+-- This performs the action stored in the 'pressAction' field and registers a+-- callback that will trigger the 'releaseAction' when the release is detected.+press :: MonadK m => Button -> m ()+press b = do+ runAction $ b^.pressAction+ awaitMy Release $ do+ runAction $ b^.releaseAction+ pure Catch++--------------------------------------------------------------------------------+-- $simple+--+-- A collection of simple buttons. These are basically almost direct wrappings+-- around 'MonadK' functionality.++-- | A button that emits a Press of a keycode when pressed, and a release when+-- released.+emitB :: Keycode -> Button+emitB c = mkButton+ (emit $ mkPress c)+ (emit $ mkRelease c)++-- | Create a new button that first presses a 'Keycode' before running an inner+-- button, releasing the 'Keycode' again after the inner 'Button' is released.+modded ::+ Keycode -- ^ The 'Keycode' to `wrap around` the inner button+ -> Button -- ^ The button to nest inside `being modded`+ -> Button+modded modder = around (emitB modder)++-- | Create a button that toggles a layer on and off+layerToggle :: LayerTag -> Button+layerToggle t = mkButton+ (layerOp $ PushLayer t)+ (layerOp $ PopLayer t)++-- | Create a button that switches the base-layer on a press+layerSwitch :: LayerTag -> Button+layerSwitch t = onPress (layerOp $ SetBaseLayer t)++-- | Create a button that adds a layer on a press+layerAdd :: LayerTag -> Button+layerAdd t = onPress (layerOp $ PushLayer t)++-- | Create a button that removes the top instance of a layer on a press+layerRem :: LayerTag -> Button+layerRem t = onPress (layerOp $ PopLayer t)++-- | Create a button that does nothing (but captures the input)+pass :: Button+pass = onPress $ pure ()++-- | Create a button that executes a shell command on press+cmdButton :: Text -> Button+cmdButton t = onPress $ shellCmd t++--------------------------------------------------------------------------------+-- $combinators+--+-- Functions that take 'Button's and combine them to form new 'Button's.++-- | Create a new button from 2 buttons, an inner and an outer. When the new+-- button is pressed, first the outer is pressed, then the inner. On release,+-- the inner is released first, and then the outer.+around ::+ Button -- ^ The outer 'Button'+ -> Button -- ^ The inner 'Button'+ -> Button -- ^ The resulting nested 'Button'+around outer inner = Button+ (Action (runAction (outer^.pressAction) *> runAction (inner^.pressAction)))+ (Action (runAction (inner^.releaseAction) *> runAction (outer^.releaseAction)))++-- | A 'Button' that, once pressed, will surround the next button with another.+--+-- Think of this as, essentially, a tappable mod. For example, an 'aroundNext+-- KeyCtrl' would, once tapped, then make the next keypress C-<whatever>.+aroundNext ::+ Button -- ^ The outer 'Button'+ -> Button -- ^ The resulting 'Button'+aroundNext b = onPress $ await isPress $ \e -> do+ runAction $ b^.pressAction+ await (isReleaseOf $ e^.keycode) $ \_ -> do+ runAction $ b^.releaseAction+ pure NoCatch+ pure NoCatch++-- | Create a new button that performs both a press and release of the input+-- button on just a press or release+tapOn ::+ Switch -- ^ Which 'Switch' should trigger the tap+ -> Button -- ^ The 'Button' to tap+ -> Button -- ^ The tapping 'Button'+tapOn Press b = mkButton (tap b) (pure ())+tapOn Release b = mkButton (pure ()) (tap b)++-- | Create a 'Button' that performs a tap of one button if it is released+-- within an interval. If the interval is exceeded, press the other button (and+-- release it when a release is detected).+tapHold :: Milliseconds -> Button -> Button -> Button+tapHold ms t h = onPress $ withinHeld ms (matchMy Release)+ (press h) -- If we catch timeout before release+ (const $ tap t *> pure Catch) -- If we catch release before timeout++-- | Create a 'Button' that performs a tap of 1 button if the next event is its+-- own release, or else switches to holding some other button if the next event+-- is a different keypress.+tapNext :: Button -> Button -> Button+tapNext t h = onPress $ hookF InputHook $ \e -> do+ p <- matchMy Release+ if p e+ then tap t *> pure Catch+ else press h *> pure NoCatch++-- | Like 'tapNext', except that after some interval it switches anyways+tapHoldNext :: Milliseconds -> Button -> Button -> Button+tapHoldNext ms t h = onPress $ within ms (pure $ const True) (press h) $ \tr -> do+ p <- matchMy Release+ if p $ tr^.event+ then tap t *> pure Catch+ else press h *> pure NoCatch++-- | Create a tap-hold style button that makes its decision based on the next+-- detected release in the following manner:+-- 1. It is the release of this button: We are tapping+-- 2. It is of some other button that was pressed *before* this one, ignore.+-- 3. It is of some other button that was pressed *after* this one, we hold.+--+-- It does all of this while holding processing of other buttons, so time will+-- get rolled back like a TapHold button.+tapNextRelease :: Button -> Button -> Button+tapNextRelease t h = onPress $ do+ hold True+ go []+ where+ go :: MonadK m => [Keycode] -> m ()+ go ks = hookF InputHook $ \e -> do+ p <- matchMy Release+ let isRel = isRelease e+ if+ -- If the next event is my own release: we act as if we were tapped+ | p e -> doTap+ -- If the next event is the release of some button that was held after me+ -- we act as if we were held+ | isRel && (e^.keycode `elem` ks) -> doHold e+ -- Else, if it is a press, store the keycode and wait again+ | not isRel -> go ((e^.keycode):ks) *> pure NoCatch+ -- Else, if it is a release of some button held before me, just ignore+ | otherwise -> go ks *> pure NoCatch++ -- Behave like a tap is simple: tap the button `t` and release processing+ doTap :: MonadK m => m Catch+ doTap = tap t *> hold False *> pure Catch++ -- Behave like a hold is not simple: first we release the processing hold,+ -- then we catch the release of ButtonX that triggered this action, and then+ -- we rethrow this release.+ doHold :: MonadK m => KeyEvent -> m Catch+ doHold e = press h *> hold False *> inject e *> pure Catch+++-- | Create a tap-hold style button that makes its decision based on the next+-- detected release in the following manner:+-- 1. It is the release of this button: We are tapping+-- 2. It is of some other button that was pressed *before* this one, ignore.+-- 3. It is of some other button that was pressed *after* this one, we hold.+--+-- If we encounter the timeout before any other release, we switch to holding+-- mode.+--+-- It does all of this while holding processing of other buttons, so time will+-- get rolled back like a TapHold button.+tapHoldNextRelease :: Milliseconds -> Button -> Button -> Button+tapHoldNextRelease ms t h = onPress $ do+ hold True+ go ms []+ where++ go :: MonadK m => Milliseconds -> [Keycode] -> m ()+ go ms' ks = tHookF InputHook ms' onTimeout $ \r -> do+ p <- matchMy Release+ let e = r^.event+ let isRel = isRelease e+ if+ -- If the next event is my own release: act like tapped+ | p e -> onRelSelf+ -- If the next event is another release that was pressed after me+ | isRel && (e^.keycode `elem` ks) -> onRelOther e+ -- If the next event is a press, store and recurse+ | not isRel -> go (ms' - r^.elapsed) (e^.keycode : ks) *> pure NoCatch+ -- If the next event is a release of some button pressed before me, recurse+ | otherwise -> go (ms' - r^.elapsed) ks *> pure NoCatch++ onTimeout :: MonadK m => m ()+ onTimeout = press h *> hold False++ onRelSelf :: MonadK m => m Catch+ onRelSelf = tap t *> hold False *> pure Catch++ onRelOther :: MonadK m => KeyEvent -> m Catch+ onRelOther e = press h *> hold False *> inject e *> pure Catch+++-- | Create a 'Button' that contains a number of delays and 'Button's. As long+-- as the next press is registered before the timeout, the multiTap descends+-- into its list. The moment a delay is exceeded or immediately upon reaching+-- the last button, that button is pressed.+multiTap :: Button -> [(Milliseconds, Button)] -> Button+multiTap l bs = onPress $ go bs+ where+ go :: [(Milliseconds, Button)] -> AnyK ()+ go [] = press l+ go ((ms, b):bs') = do+ -- This is a bit complicated. What we do is:+ -- 1. We wait for the release of the key that triggered this action+ -- 2A. If it doesn't occur in the interval we press the button from the list+ -- and we are done.+ -- 2B. If we do detect the release, we must now keep waiting to detect another press.+ -- 3A. If we do not detect a press before the interval is up, we know a tap occured,+ -- so we tap the current button and we are done.+ -- 3B. If we detect another press, then the user is descending into the buttons tied+ -- to this multi-tap, so we recurse on the remaining buttons.+ let onMatch t = do+ within (ms - t^.elapsed) (matchMy Press)+ (tap b)+ (const $ go bs' *> pure Catch)+ pure Catch+ within ms (matchMy Release) (press b) onMatch+++-- | Create a 'Button' that performs a series of taps on press. Note that the+-- last button is only released when the tapMacro itself is released.+tapMacro :: [Button] -> Button+tapMacro bs = onPress $ go bs+ where+ go [] = pure ()+ go (b:[]) = press b+ go (b:rst) = tap b >> go rst+++-- | Switch to a layer for a period of time, then automatically switch back+layerDelay :: Milliseconds -> LayerTag -> Button+layerDelay d t = onPress $ do+ layerOp (PushLayer t)+ after d (layerOp $ PopLayer t)++-- | Switch to a layer for the next button-press and switch back automaically.+--+-- NOTE: liable to change, this is essentially just `aroundNext` and+-- `layerToggle` combined.+layerNext :: LayerTag -> Button+layerNext t = onPress $ do+ layerOp (PushLayer t)+ await isPress (\_ -> whenDone (layerOp $ PopLayer t) *> pure NoCatch)++
+ src/KMonad/Keyboard.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE DeriveAnyClass #-}+{-|+Module : KMonad.Keyboard+Description : Basic keyboard types+Copyright : (c) David Janssen, 2019+License : MIT+Maintainer : janssen.dhj@gmail.com+Stability : experimental+Portability : portable++This module contains or reexports all the basic, non-IO concepts related to+dealing with key codes, events, and mappings. For keyboard-related IO see+"KMonad.Keyboard.IO".++-}+module KMonad.Keyboard+ ( -- * KeyEvents and their helpers+ -- $event+ Switch(..)+ , KeyEvent+ , switch+ , keycode+ , mkKeyEvent+ , mkPress+ , mkRelease++ -- * Predicates+ , KeyPred+ , isPress+ , isRelease+ , isKeycode+ , isPressOf+ , isReleaseOf++ -- * LMaps+ -- $lmap+ , LayerTag+ , LMap++ -- * Reexports+ , module KMonad.Keyboard.Keycode+ )++where++import KMonad.Prelude++import KMonad.Keyboard.Keycode++import qualified Data.LayerStack as Ls+++--------------------------------------------------------------------------------+-- $event+--+-- An 'KeyEvent' in KMonad is either the 'Press' or 'Release' of a particular+-- 'Keycode'. A complete list of keycodes can be found in+-- "KMonad.Keyboard.Keycode".++-- | KMonad recognizes 2 different types of actions: presses and releases. Note+-- that we do not handle repeat events at all.+data Switch+ = Press+ | Release+ deriving (Eq, Ord, Show, Enum, Generic, Hashable)++-- | An 'KeyEvent' is a 'Switch' on a particular 'Keycode'+data KeyEvent = KeyEvent+ { _switch :: Switch -- ^ Whether the 'KeyEvent' was a 'Press' or 'Release'+ , _keycode :: Keycode -- ^ The 'Keycode' mapped to this 'KeyEvent'+ } deriving (Eq, Show, Generic, Hashable)+makeLenses ''KeyEvent++-- | A 'Display' instance for 'KeyEvent's that prints them out nicely.+instance Display KeyEvent where+ textDisplay a = tshow (a^.switch) <> " " <> textDisplay (a^.keycode)++-- | An 'Ord' instance, where Press > Release, and otherwise we 'Ord' on the+-- 'Keycode'+instance Ord KeyEvent where+ a `compare` b = case (a^.switch) `compare` (b^.switch) of+ EQ -> (a^.keycode) `compare` (b^.keycode)+ x -> x++-- | Create a new 'KeyEvent' from a 'Switch' and a 'Keycode'+mkKeyEvent :: Switch -> Keycode -> KeyEvent+mkKeyEvent = KeyEvent++-- | Create a 'KeyEvent' that represents pressing a key+mkPress :: Keycode -> KeyEvent+mkPress = KeyEvent Press++-- | Create a 'KeyEvent' that represents releaseing a key+mkRelease :: Keycode -> KeyEvent+mkRelease = KeyEvent Release+++-- | Predicate on KeyEvent's+type KeyPred = KeyEvent -> Bool++-- | Return whether the provided KeyEvent is a Press+isPress :: KeyPred+isPress = (== Press) . view switch++-- | Return whether the provided KeyEvent is a Release+isRelease :: KeyPred+isRelease = not . isPress++-- | Return whether the provided KeyEvent matches a particular Keycode+isKeycode :: Keycode -> KeyPred+isKeycode c = (== c) . view keycode++-- | Returth whether the provided KeyEvent matches the release of the Keycode+isReleaseOf :: Keycode -> KeyPred+isReleaseOf = (==) . mkRelease++-- | Return whether the provided KeyEvent matches the press of the Keycode+isPressOf :: Keycode -> KeyPred+isPressOf = (==) . mkPress++++--------------------------------------------------------------------------------+-- $lmap+--+-- Type aliases for specifying stacked-layer mappings++-- | Layers are identified by a tag that is simply a 'Text' value.+type LayerTag = Text++-- | 'LMap's are mappings from 'LayerTag'd maps from 'Keycode' to things.+type LMap a = Ls.LayerStack LayerTag Keycode a
+ src/KMonad/Keyboard/ComposeSeq.hs view
@@ -0,0 +1,732 @@+{-|+Module : KMonad.Keyboard.ComposeSeq+Description : A list of compose-sequences+Copyright : (c) David Janssen, 2019+License : MIT+Maintainer : janssen.dhj@gmail.com+Stability : experimental+Portability : portable++This module contains only a Haskellified list of (nearly) all X11 compose-key+sequences. For each entry we have the sequence of keys that defines it, the+UTF-8 character that it represents, and the X11 name for this+sequence/character.++-}+module KMonad.Keyboard.ComposeSeq+ ( -- * Sequences+ ssComposed+ )+where++import KMonad.Prelude++--------------------------------------------------------------------------------++-- | A collection of all supported compose-key sequences (nearly all X11+-- compose-key sequences). Each tuple consists of:+-- 1. A string that, when parsed to a tap-macro, will emit the sequence.+-- 2. The UTF-8 character that it represents+-- 3. A descriptive-name+--+ssComposed :: [(Text, Char, Text)]+ssComposed =+ [ ("' '" , '´' , "acute")+ , ( "^ -" , '¯' , "macron" )+ , ( "spc (" , '˘' , "breve" )+ , ( "\" \"" , '¨' , "diaeresis" )+ , ("spc <" , 'ˇ' , "caron")+ , ("` spc" , '`' , "grave")+ , (", spc" , '¸' , "cedilla")+ , ("spc spc" , ' ' , "nobreakspace")+ , ("spc ." , ' ' , "U2008")+ , ("o c" , '©' , "copyright")+ , ("o r" , '®' , "registered")+ , (". >" , '›' , "U203a")+ , (". <" , '‹' , "U2039")+ , (". ." , '…' , "ellipsis")+ , (". -" , '·' , "periodcentered")+ , (". =" , '•' , "enfilledcircbullet")+ , ("! ^" , '¦' , "brokenbar")+ , ("! !" , '¡' , "exclamdown")+ , ("p !" , '¶' , "paragraph")+ , ("+ -" , '±' , "plusminus")+ , ("? ?" , '¿' , "questiondown")+ , ("s s" , 'ß' , "ssharp")+ , ("S S" , 'ẞ' , "U1e9e")+ , ("o e" , 'œ' , "oe")+ , ("O E" , 'Œ' , "OE")+ , ("a e" , 'æ' , "ae")+ , ("A E" , 'Æ' , "AE")+ , ("f f" , 'ff' , "Ufb00")+ , ("f i" , 'fi' , "Ufb01")+ , ("f l" , 'fl' , "Ufb02")+ , ("F i" , 'ffi' , "Ufb03")+ , ("F l" , 'ffl' , "Ufb04")+ , ("I J" , 'IJ' , "U0132")+ , ("i j" , 'ij' , "U0133")+ , ("o o" , '°' , "degree")+ , ("< <" , '«' , "guillemotleft")+ , ("> >" , '»' , "guillemotright")+ , ("' <" , '‘' , "U2018")+ , ("> '" , '’' , "U2019")+ , (", '" , '‚' , "U201a")+ , ("\" <" , '“' , "U201c")+ , ("\" >" , '”' , "U201d")+ , ("\" ," , '„' , "U201e")+ , ("% o" , '‰' , "U2030")+ , ("C E" , '₠' , "U20a0")+ , ("/ C" , '₡' , "U20a1")+ , ("C r" , '₢' , "U20a2")+ , ("F r" , '₣' , "U20a3")+ , ("= L" , '₤' , "U20a4")+ , ("/ m" , '₥' , "U20a5")+ , ("= N" , '₦' , "U20a6")+ , ("P t" , '₧' , "U20a7")+ , ("R s" , '₨' , "U20a8")+ , ("= W" , '₩' , "U20a9")+ , ("= d" , '₫' , "U20ab")+ , ("C =" , '€' , "EuroSign")+ , ("P =" , '₽' , "U20bd")+ , ("R =" , '₹' , "U20b9")+ , ("C |" , '¢' , "cent")+ , ("L -" , '£' , "sterling")+ , ("Y =" , '¥' , "yen")+ , ("f s" , 'ſ' , "U017f")+ , ("- - ." , '–' , "U2013")+ , ("- - -" , '—' , "U2014")+ , ("# q" , '♩' , "U2669")+ , ("# e" , '♪' , "U266a")+ , ("# E" , '♫' , "U266b")+ , ("# S" , '♬' , "U266c")+ , ("# b" , '♭' , "U266d")+ , ("# f" , '♮' , "U266e")+ , ("# #" , '♯' , "U266f")+ , ("s o" , '§' , "section")+ , ("o x" , '¤' , "currency")+ , ("N o" , '№' , "numerosign")+ , ("? !" , '⸘' , "U2E18")+ , ("! ?" , '‽' , "U203D")+ , ("C C C P" , '☭' , "U262D")+ , ("O A" , 'Ⓐ' , "U24B6")+ , ("< 3" , '♥' , "U2665")+ , (": )" , '☺' , "U263A")+ , (": (" , '☹' , "U2639")+ , ("\\ o /" , '🙌' , "Man with arms raised")+ , ("p o o" , '💩' , "U1F4A9")+ , ("L L A P" , '🖖' , "U1F596")+ , (", -" , '¬' , "notsign")+ , ("^ _ a" , 'ª' , "ordfeminine")+ , ("^ 2" , '²' , "twosuperior")+ , ("^ 3" , '³' , "threesuperior")+ , ("m u" , 'µ' , "mu")+ , ("^ 1" , '¹' , "onesuperior")+ , ("^ _ o" , 'º' , "masculine")+ , ("1 4" , '¼' , "onequarter")+ , ("1 2" , '½' , "onehalf")+ , ("3 4" , '¾' , "threequarters")+ , ("A `" , 'À' , "Agrave")+ , ("' A" , 'Á' , "Aacute")+ , ("^ A" , 'Â' , "Acircumflex")+ , ("~ A" , 'Ã' , "Atilde")+ , ("\" A" , 'Ä' , "Adiaeresis")+ , ("o A" , 'Å' , "Aring")+ , (", C" , 'Ç' , "Ccedilla")+ , ("` E" , 'È' , "Egrave")+ , ("' E" , 'É' , "Eacute")+ , ("^ E" , 'Ê' , "Ecircumflex")+ , ("\" E" , 'Ë' , "Ediaeresis")+ , ("` I" , 'Ì' , "Igrave")+ , ("' I" , 'Í' , "Iacute")+ , ("I ^" , 'Î' , "Icircumflex")+ , ("\" I" , 'Ï' , "Idiaeresis")+ , ("D H" , 'Ð' , "ETH")+ , ("~ N" , 'Ñ' , "Ntilde")+ , ("` O" , 'Ò' , "Ograve")+ , ("' O" , 'Ó' , "Oacute")+ , ("^ O" , 'Ô' , "Ocircumflex")+ , ("~ O" , 'Õ' , "Otilde")+ , ("\" O" , 'Ö' , "Odiaeresis")+ , ("x x" , '×' , "multiply")+ , ("/ O" , 'Ø' , "Oslash")+ , ("' Y" , 'Ý' , "Yacute")+ , ("T H" , 'Þ' , "THORN")+ , ("` a" , 'à' , "agrave")+ , ("' a" , 'á' , "aacute")+ , ("^ a" , 'â' , "acircumflex")+ , ("~ a" , 'ã' , "atilde")+ , ("\" a" , 'ä' , "adiaeresis")+ , ("o a" , 'å' , "aring")+ , (", c" , 'ç' , "ccedilla")+ , ("` e" , 'è' , "egrave")+ , ("' e" , 'é' , "eacute")+ , ("^ e" , 'ê' , "ecircumflex")+ , ("\" e" , 'ë' , "ediaeresis")+ , ("` i" , 'ì' , "igrave")+ , ("' i" , 'í' , "iacute")+ , ("^ i" , 'î' , "icircumflex")+ , ("\" i" , 'ï' , "idiaeresis")+ , ("d h" , 'ð' , "eth")+ , ("~ n" , 'ñ' , "ntilde")+ , ("` o" , 'ò' , "ograve")+ , ("' o" , 'ó' , "oacute")+ , ("^ o" , 'ô' , "ocircumflex")+ , ("~ o" , 'õ' , "otilde")+ , ("\" o" , 'ö' , "odiaeresis")+ , (": -" , '÷' , "division")+ , ("/ o" , 'ø' , "oslash")+ , ("` u" , 'ù' , "ugrave")+ , ("' u" , 'ú' , "uacute")+ , ("^ u" , 'û' , "ucircumflex")+ , ("\" u" , 'ü' , "udiaeresis")+ , ("' y" , 'ý' , "yacute")+ , ("t h" , 'þ' , "thorn")+ , ("\" y" , 'ÿ' , "ydiaeresis")+ , ("_ A" , 'Ā' , "U0100")+ , ("_ a" , 'ā' , "U0101")+ , ("u A" , 'Ă' , "U0102")+ , ("u a" , 'ă' , "U0103")+ , ("; A" , 'Ą' , "U0104")+ , ("; a" , 'ą' , "U0105")+ , ("' C" , 'Ć' , "U0106")+ , ("' c" , 'ć' , "U0107")+ , ("^ C" , 'Ĉ' , "U0108")+ , ("^ c" , 'ĉ' , "U0109")+ , ("C ." , 'Ċ' , "U010A")+ , (". c" , 'ċ' , "U010B")+ , ("c C" , 'Č' , "U010C")+ , ("c c" , 'č' , "U010D")+ , ("c D" , 'Ď' , "U010E")+ , ("c d" , 'ď' , "U010F")+ , ("- D" , 'Đ' , "Dstroke")+ , ("- d" , 'đ' , "dstroke")+ , ("_ E" , 'Ē' , "U0112")+ , ("_ e" , 'ē' , "U0113")+ , ("b E" , 'Ĕ' , "U0114")+ , ("b e" , 'ĕ' , "U0115")+ , (". E" , 'Ė' , "U0116")+ , (". e" , 'ė' , "U0117")+ , ("; E" , 'Ę' , "U0118")+ , ("; e" , 'ę' , "U0119")+ , ("c E" , 'Ě' , "U011A")+ , ("c e" , 'ě' , "U011B")+ , ("^ G" , 'Ĝ' , "U011C")+ , ("^ g" , 'ĝ' , "U011D")+ , ("b G" , 'Ğ' , "U011E")+ , ("b g" , 'ğ' , "U011F")+ , (". G" , 'Ġ' , "U0120")+ , (". g" , 'ġ' , "U0121")+ , ("G ," , 'Ģ' , "U0122")+ , (", g" , 'ģ' , "U0123")+ , ("^ H" , 'Ĥ' , "U0124")+ , ("^ h" , 'ĥ' , "U0125")+ , ("/ H" , 'Ħ' , "U0126")+ , ("/ h" , 'ħ' , "U0127")+ , ("~ I" , 'Ĩ' , "U0128")+ , ("~ i" , 'ĩ' , "U0129")+ , ("_ I" , 'Ī' , "U012A")+ , ("_ i" , 'ī' , "U012B")+ , ("b I" , 'Ĭ' , "U012C")+ , ("b i" , 'ĭ' , "U012D")+ , ("; I" , 'Į' , "U012E")+ , ("; i" , 'į' , "U012F")+ , (". I" , 'İ' , "U0130")+ , ("i ." , 'ı' , "U0131")+ , ("^ J" , 'Ĵ' , "U0134")+ , ("^ j" , 'ĵ' , "U0135")+ , (", K" , 'Ķ' , "U0136")+ , (", k" , 'ķ' , "U0137")+ , ("k k" , 'ĸ' , "U0138")+ , ("' L" , 'Ĺ' , "U0139")+ , ("' l" , 'ĺ' , "U013A")+ , (", L" , 'Ļ' , "U013B")+ , (", l" , 'ļ' , "U013C")+ , ("c L" , 'Ľ' , "U013D")+ , ("c l" , 'ľ' , "U013E")+ , ("/ L" , 'Ł' , "U0141")+ , ("/ l" , 'ł' , "U0142")+ , ("' N" , 'Ń' , "U0143")+ , ("' n" , 'ń' , "U0144")+ , (", N" , 'Ņ' , "U0145")+ , (", n" , 'ņ' , "U0146")+ , ("c N" , 'Ň' , "U0147")+ , ("c n" , 'ň' , "U0148")+ , ("N G" , 'Ŋ' , "U014A")+ , ("n g" , 'ŋ' , "U014B")+ , ("_ O" , 'Ō' , "U014C")+ , ("_ o" , 'ō' , "U014D")+ , ("b O" , 'Ŏ' , "U014E")+ , ("b o" , 'ŏ' , "U014F")+ , ("= O" , 'Ő' , "U0150")+ , ("= o" , 'ő' , "U0151")+ , ("' R" , 'Ŕ' , "U0154")+ , ("' r" , 'ŕ' , "U0155")+ , ("R ," , 'Ŗ' , "U0156")+ , (", r" , 'ŗ' , "U0157")+ , ("c R" , 'Ř' , "U0158")+ , ("c r" , 'ř' , "U0159")+ , ("' S" , 'Ś' , "U015A")+ , ("' s" , 'ś' , "U015B")+ , ("^ S" , 'Ŝ' , "U015C")+ , ("^ s" , 'ŝ' , "U015D")+ , (", S" , 'Ş' , "U015E")+ , (", s" , 'ş' , "U015F")+ , ("c S" , 'Š' , "U0160")+ , ("c s" , 'š' , "U0161")+ , (", T" , 'Ţ' , "U0162")+ , (", t" , 'ţ' , "U0163")+ , ("c T" , 'Ť' , "U0164")+ , ("c t" , 'ť' , "U0165")+ , ("/ T" , 'Ŧ' , "U0166")+ , ("/ t" , 'ŧ' , "U0167")+ , ("~ u" , 'ũ' , "U0169")+ , ("_ u" , 'ū' , "U016B")+ , ("u u" , 'ŭ' , "U016D")+ , ("o u" , 'ů' , "U016F")+ , ("= u" , 'ű' , "U0171")+ , ("; u" , 'ų' , "U0173")+ , ("^ W" , 'Ŵ' , "U0174")+ , ("^ w" , 'ŵ' , "U0175")+ , ("^ Y" , 'Ŷ' , "U0176")+ , ("^ y" , 'ŷ' , "U0177")+ , ("\" Y" , 'Ÿ' , "U0178")+ , ("' Z" , 'Ź' , "U0179")+ , ("' z" , 'ź' , "U017A")+ , (". Z" , 'Ż' , "U017B")+ , (". z" , 'ż' , "U017C")+ , ("c Z" , 'Ž' , "U017D")+ , ("c z" , 'ž' , "U017E")+ , ("/ b" , 'ƀ' , "U0180")+ , ("/ I" , 'Ɨ' , "U0197")+ , ("+ O" , 'Ơ' , "U01A0")+ , ("+ o" , 'ơ' , "U01A1")+ , ("+ u" , 'ư' , "U01B0")+ , ("/ Z" , 'Ƶ' , "U01B5")+ , ("/ z" , 'ƶ' , "U01B6")+ , ("c A" , 'Ǎ' , "U01CD")+ , ("c a" , 'ǎ' , "U01CE")+ , ("c I" , 'Ǐ' , "U01CF")+ , ("c i" , 'ǐ' , "U01D0")+ , ("c O" , 'Ǒ' , "U01D1")+ , ("c o" , 'ǒ' , "U01D2")+ , ("c u" , 'ǔ' , "U01D4")+ , ("_ \" u" , 'ǖ' , "U01D6")+ , ("' \" u" , 'ǘ' , "U01D8")+ , ("c \" u" , 'ǚ' , "U01DA")+ , ("` \" u" , 'ǜ' , "U01DC")+ , ("_ \" A" , 'Ǟ' , "U01DE")+ , ("_ \" a" , 'ǟ' , "U01DF")+ , ("_ . A" , 'Ǡ' , "U01E0")+ , ("_ . a" , 'ǡ' , "U01E1")+ , ("/ G" , 'Ǥ' , "U01E4")+ , ("/ g" , 'ǥ' , "U01E5")+ , ("c G" , 'Ǧ' , "U01E6")+ , ("c g" , 'ǧ' , "U01E7")+ , ("c K" , 'Ǩ' , "U01E8")+ , ("c k" , 'ǩ' , "U01E9")+ , ("; O" , 'Ǫ' , "U01EA")+ , ("; o" , 'ǫ' , "U01EB")+ , ("_ ; O" , 'Ǭ' , "U01EC")+ , ("_ ; o" , 'ǭ' , "U01ED")+ , ("c j" , 'ǰ' , "U01F0")+ , ("' G" , 'Ǵ' , "U01F4")+ , ("' g" , 'ǵ' , "U01F5")+ , ("` N" , 'Ǹ' , "U01F8")+ , ("` n" , 'ǹ' , "U01F9")+ , ("* ' A" , 'Ǻ' , "U01FA")+ , ("* ' a" , 'ǻ' , "U01FB")+ , ("' / O" , 'Ǿ' , "U01FE")+ , ("c H" , 'Ȟ' , "U021E")+ , ("c h" , 'ȟ' , "U021F")+ , (". A" , 'Ȧ' , "U0226")+ , (". a" , 'ȧ' , "U0227")+ , ("_ \" O" , 'Ȫ' , "U022A")+ , ("_ \" o" , 'ȫ' , "U022B")+ , ("_ ~ O" , 'Ȭ' , "U022C")+ , ("_ ~ o" , 'ȭ' , "U022D")+ , (". O" , 'Ȯ' , "U022E")+ , (". o" , 'ȯ' , "U022F")+ , ("_ . O" , 'Ȱ' , "U0230")+ , ("_ . o" , 'ȱ' , "U0231")+ , ("_ Y" , 'Ȳ' , "U0232")+ , ("_ y" , 'ȳ' , "U0233")+ , ("e e" , 'ə' , "U0259")+ , ("/ i" , 'ɨ' , "U0268")+ , ("^ _ h" , 'ʰ' , "U02B0")+ , ("^ _ j" , 'ʲ' , "U02B2")+ , ("^ _ r" , 'ʳ' , "U02B3")+ , ("^ _ w" , 'ʷ' , "U02B7")+ , ("^ _ y" , 'ʸ' , "U02B8")+ , ("^ _ l" , 'ˡ' , "U02E1")+ , ("^ _ s" , 'ˢ' , "U02E2")+ , ("^ _ x" , 'ˣ' , "U02E3")+ , ("\" '" , '̈́' , "U0344")+ , ("' \" spc" , '΅' , "U0385")+ , (". B" , 'Ḃ' , "U1E02")+ , (". b" , 'ḃ' , "U1E03")+ , ("! B" , 'Ḅ' , "U1E04")+ , ("! b" , 'ḅ' , "U1E05")+ , (". D" , 'Ḋ' , "U1E0A")+ , (". d" , 'ḋ' , "U1E0B")+ , ("! D" , 'Ḍ' , "U1E0C")+ , ("! d" , 'ḍ' , "U1E0D")+ , (", D" , 'Ḑ' , "U1E10")+ , (", d" , 'ḑ' , "U1E11")+ , ("` _ E" , 'Ḕ' , "U1E14")+ , ("` _ e" , 'ḕ' , "U1E15")+ , ("' _ E" , 'Ḗ' , "U1E16")+ , ("' _ e" , 'ḗ' , "U1E17")+ , ("b , E" , 'Ḝ' , "U1E1C")+ , ("b , e" , 'ḝ' , "U1E1D")+ , (". F" , 'Ḟ' , "U1E1E")+ , ("f ." , 'ḟ' , "U1E1F")+ , ("_ G" , 'Ḡ' , "U1E20")+ , ("_ g" , 'ḡ' , "U1E21")+ , (". H" , 'Ḣ' , "U1E22")+ , (". h" , 'ḣ' , "U1E23")+ , ("! H" , 'Ḥ' , "U1E24")+ , ("! h" , 'ḥ' , "U1E25")+ , ("\" H" , 'Ḧ' , "U1E26")+ , ("\" h" , 'ḧ' , "U1E27")+ , (", H" , 'Ḩ' , "U1E28")+ , (", h" , 'ḩ' , "U1E29")+ , ("' \" I" , 'Ḯ' , "U1E2E")+ , ("' \" i" , 'ḯ' , "U1E2F")+ , ("' K" , 'Ḱ' , "U1E30")+ , ("' k" , 'ḱ' , "U1E31")+ , ("! K" , 'Ḳ' , "U1E32")+ , ("! k" , 'ḳ' , "U1E33")+ , ("! L" , 'Ḷ' , "U1E36")+ , ("! l" , 'ḷ' , "U1E37")+ , ("_ ! L" , 'Ḹ' , "U1E38")+ , ("_ ! l" , 'ḹ' , "U1E39")+ , ("' M" , 'Ḿ' , "U1E3E")+ , ("' m" , 'ḿ' , "U1E3F")+ , (". M" , 'Ṁ' , "U1E40")+ , (". m" , 'ṁ' , "U1E41")+ , ("! M" , 'Ṃ' , "U1E42")+ , ("! m" , 'ṃ' , "U1E43")+ , (". N" , 'Ṅ' , "U1E44")+ , (". n" , 'ṅ' , "U1E45")+ , ("! N" , 'Ṇ' , "U1E46")+ , ("! n" , 'ṇ' , "U1E47")+ , ("' ~ O" , 'Ṍ' , "U1E4C")+ , ("' ~ o" , 'ṍ' , "U1E4D")+ , ("\" ~ O" , 'Ṏ' , "U1E4E")+ , ("\" ~ o" , 'ṏ' , "U1E4F")+ , ("` _ O" , 'Ṑ' , "U1E50")+ , ("` _ o" , 'ṑ' , "U1E51")+ , ("' _ O" , 'Ṓ' , "U1E52")+ , ("' _ o" , 'ṓ' , "U1E53")+ , ("' P" , 'Ṕ' , "U1E54")+ , ("' p" , 'ṕ' , "U1E55")+ , (". P" , 'Ṗ' , "U1E56")+ , (". p" , 'ṗ' , "U1E57")+ , (". R" , 'Ṙ' , "U1E58")+ , (". r" , 'ṙ' , "U1E59")+ , ("! R" , 'Ṛ' , "U1E5A")+ , ("! r" , 'ṛ' , "U1E5B")+ , ("_ ! R" , 'Ṝ' , "U1E5C")+ , ("_ ! r" , 'ṝ' , "U1E5D")+ , (". S" , 'Ṡ' , "U1E60")+ , (". s" , 'ṡ' , "U1E61")+ , ("! S" , 'Ṣ' , "U1E62")+ , ("! s" , 'ṣ' , "U1E63")+ , (". ' S" , 'Ṥ' , "U1E64")+ , (". ' s" , 'ṥ' , "U1E65")+ , (". ! S" , 'Ṩ' , "U1E68")+ , (". ! s" , 'ṩ' , "U1E69")+ , (". T" , 'Ṫ' , "U1E6A")+ , (". t" , 'ṫ' , "U1E6B")+ , ("! T" , 'Ṭ' , "U1E6C")+ , ("! t" , 'ṭ' , "U1E6D")+ , ("' ~ u" , 'ṹ' , "U1E79")+ , ("\" _ u" , 'ṻ' , "U1E7B")+ , ("~ V" , 'Ṽ' , "U1E7C")+ , ("~ v" , 'ṽ' , "U1E7D")+ , ("! V" , 'Ṿ' , "U1E7E")+ , ("! v" , 'ṿ' , "U1E7F")+ , ("` W" , 'Ẁ' , "U1E80")+ , ("` w" , 'ẁ' , "U1E81")+ , ("' W" , 'Ẃ' , "U1E82")+ , ("' w" , 'ẃ' , "U1E83")+ , ("\" W" , 'Ẅ' , "U1E84")+ , ("\" w" , 'ẅ' , "U1E85")+ , (". W" , 'Ẇ' , "U1E86")+ , (". w" , 'ẇ' , "U1E87")+ , ("! W" , 'Ẉ' , "U1E88")+ , ("! w" , 'ẉ' , "U1E89")+ , (". X" , 'Ẋ' , "U1E8A")+ , (". x" , 'ẋ' , "U1E8B")+ , ("\" X" , 'Ẍ' , "U1E8C")+ , ("\" x" , 'ẍ' , "U1E8D")+ , (". Y" , 'Ẏ' , "U1E8E")+ , (". y" , 'ẏ' , "U1E8F")+ , ("^ Z" , 'Ẑ' , "U1E90")+ , ("^ z" , 'ẑ' , "U1E91")+ , ("! Z" , 'Ẓ' , "U1E92")+ , ("! z" , 'ẓ' , "U1E93")+ , ("\" t" , 'ẗ' , "U1E97")+ , ("o w" , 'ẘ' , "U1E98")+ , ("o y" , 'ẙ' , "U1E99")+ , ("! A" , 'Ạ' , "U1EA0")+ , ("! a" , 'ạ' , "U1EA1")+ , ("? A" , 'Ả' , "U1EA2")+ , ("? a" , 'ả' , "U1EA3")+ , ("' ^ A" , 'Ấ' , "U1EA4")+ , ("' ^ a" , 'ấ' , "U1EA5")+ , ("` ^ A" , 'Ầ' , "U1EA6")+ , ("` ^ a" , 'ầ' , "U1EA7")+ , ("? ^ A" , 'Ẩ' , "U1EA8")+ , ("? ^ a" , 'ẩ' , "U1EA9")+ , ("~ ^ A" , 'Ẫ' , "U1EAA")+ , ("~ ^ a" , 'ẫ' , "U1EAB")+ , ("^ ! A" , 'Ậ' , "U1EAC")+ , ("^ ! a" , 'ậ' , "U1EAD")+ , ("' b A" , 'Ắ' , "U1EAE")+ , ("' b a" , 'ắ' , "U1EAF")+ , ("` b A" , 'Ằ' , "U1EB0")+ , ("` b a" , 'ằ' , "U1EB1")+ , ("? b A" , 'Ẳ' , "U1EB2")+ , ("? b a" , 'ẳ' , "U1EB3")+ , ("~ b A" , 'Ẵ' , "U1EB4")+ , ("~ b a" , 'ẵ' , "U1EB5")+ , ("b ! A" , 'Ặ' , "U1EB6")+ , ("b ! a" , 'ặ' , "U1EB7")+ , ("! E" , 'Ẹ' , "U1EB8")+ , ("! e" , 'ẹ' , "U1EB9")+ , ("? E" , 'Ẻ' , "U1EBA")+ , ("? e" , 'ẻ' , "U1EBB")+ , ("~ E" , 'Ẽ' , "U1EBC")+ , ("~ e" , 'ẽ' , "U1EBD")+ , ("' ^ E" , 'Ế' , "U1EBE")+ , ("' ^ e" , 'ế' , "U1EBF")+ , ("` ^ E" , 'Ề' , "U1EC0")+ , ("` ^ e" , 'ề' , "U1EC1")+ , ("? ^ E" , 'Ể' , "U1EC2")+ , ("? ^ e" , 'ể' , "U1EC3")+ , ("~ ^ E" , 'Ễ' , "U1EC4")+ , ("~ ^ e" , 'ễ' , "U1EC5")+ , ("^ ! E" , 'Ệ' , "U1EC6")+ , ("^ ! e" , 'ệ' , "U1EC7")+ , ("? I" , 'Ỉ' , "U1EC8")+ , ("? i" , 'ỉ' , "U1EC9")+ , ("! I" , 'Ị' , "U1ECA")+ , ("! i" , 'ị' , "U1ECB")+ , ("! O" , 'Ọ' , "U1ECC")+ , ("! o" , 'ọ' , "U1ECD")+ , ("? O" , 'Ỏ' , "U1ECE")+ , ("? o" , 'ỏ' , "U1ECF")+ , ("' ^ O" , 'Ố' , "U1ED0")+ , ("' ^ o" , 'ố' , "U1ED1")+ , ("` ^ O" , 'Ồ' , "U1ED2")+ , ("` ^ o" , 'ồ' , "U1ED3")+ , ("? ^ O" , 'Ổ' , "U1ED4")+ , ("? ^ o" , 'ổ' , "U1ED5")+ , ("~ ^ O" , 'Ỗ' , "U1ED6")+ , ("~ ^ o" , 'ỗ' , "U1ED7")+ , ("^ ! O" , 'Ộ' , "U1ED8")+ , ("^ ! o" , 'ộ' , "U1ED9")+ , ("' + O" , 'Ớ' , "U1EDA")+ , ("' + o" , 'ớ' , "U1EDB")+ , ("` + O" , 'Ờ' , "U1EDC")+ , ("` + o" , 'ờ' , "U1EDD")+ , ("? + O" , 'Ở' , "U1EDE")+ , ("? + o" , 'ở' , "U1EDF")+ , ("~ + O" , 'Ỡ' , "U1EE0")+ , ("~ + o" , 'ỡ' , "U1EE1")+ , ("! + O" , 'Ợ' , "U1EE2")+ , ("! + o" , 'ợ' , "U1EE3")+ , ("! u" , 'ụ' , "U1EE5")+ , ("? u" , 'ủ' , "U1EE7")+ , ("' + u" , 'ứ' , "U1EE9")+ , ("` + u" , 'ừ' , "U1EEB")+ , ("? + u" , 'ử' , "U1EED")+ , ("~ + u" , 'ữ' , "U1EEF")+ , ("! + u" , 'ự' , "U1EF1")+ , ("` Y" , 'Ỳ' , "U1EF2")+ , ("` y" , 'ỳ' , "U1EF3")+ , ("! Y" , 'Ỵ' , "U1EF4")+ , ("! y" , 'ỵ' , "U1EF5")+ , ("? Y" , 'Ỷ' , "U1EF6")+ , ("? y" , 'ỷ' , "U1EF7")+ , ("~ Y" , 'Ỹ' , "U1EF8")+ , ("~ y" , 'ỹ' , "U1EF9")+ , ("^ 0" , '⁰' , "U2070")+ , ("^ _ i" , 'ⁱ' , "U2071")+ , ("^ 4" , '⁴' , "U2074")+ , ("^ 5" , '⁵' , "U2075")+ , ("^ 6" , '⁶' , "U2076")+ , ("^ 7" , '⁷' , "U2077")+ , ("^ 8" , '⁸' , "U2078")+ , ("^ 9" , '⁹' , "U2079")+ , ("^ +" , '⁺' , "U207A")+ , ("^ =" , '⁼' , "U207C")+ , ("^ (" , '⁽' , "U207D")+ , ("^ )" , '⁾' , "U207E")+ , ("^ _ n" , 'ⁿ' , "U207F")+ , ("_ 0" , '₀' , "U2080")+ , ("_ 1" , '₁' , "U2081")+ , ("_ 2" , '₂' , "U2082")+ , ("_ 3" , '₃' , "U2083")+ , ("_ 4" , '₄' , "U2084")+ , ("_ 5" , '₅' , "U2085")+ , ("_ 6" , '₆' , "U2086")+ , ("_ 7" , '₇' , "U2087")+ , ("_ 8" , '₈' , "U2088")+ , ("_ 9" , '₉' , "U2089")+ , ("_ +" , '₊' , "U208A")+ , ("_ =" , '₌' , "U208C")+ , ("_ (" , '₍' , "U208D")+ , ("_ )" , '₎' , "U208E")+ , ("S M" , '℠' , "U2120")+ , ("T M" , '™' , "U2122")+ , ("1 7" , '⅐' , "U2150")+ , ("1 9" , '⅑' , "U2151")+ , ("1 1 0" , '⅒' , "U2152")+ , ("1 3" , '⅓' , "U2153")+ , ("2 3" , '⅔' , "U2154")+ , ("1 5" , '⅕' , "U2155")+ , ("2 5" , '⅖' , "U2156")+ , ("3 5" , '⅗' , "U2157")+ , ("4 5" , '⅘' , "U2158")+ , ("1 6" , '⅙' , "U2159")+ , ("5 6" , '⅚' , "U215A")+ , ("1 8" , '⅛' , "U215B")+ , ("3 8" , '⅜' , "U215C")+ , ("5 8" , '⅝' , "U215D")+ , ("7 8" , '⅞' , "U215E")+ , ("0 3" , '↉' , "U2189")+ , ("/ lft" , '↚' , "U219A")+ , ("/ rght" , '↛' , "U219B")+ , ("< -" , '←' , "U2190")+ , ("- >" , '→' , "U2192")+ , ("= >" , '⇒' , "U21D2")+ , ("{ }" , '∅' , "U2205")+ , ("/ =" , '≠' , "U2260")+ , ("d i" , '⌀' , "U2300")+ , ("( 1 )" , '①' , "U2460")+ , ("( 2 )" , '②' , "U2461")+ , ("( 3 )" , '③' , "U2462")+ , ("( 4 )" , '④' , "U2463")+ , ("( 5 )" , '⑤' , "U2464")+ , ("( 6 )" , '⑥' , "U2465")+ , ("( 7 )" , '⑦' , "U2466")+ , ("( 8 )" , '⑧' , "U2467")+ , ("( 9 )" , '⑨' , "U2468")+ , ("( 1 0 )" , '⑩' , "U2469")+ , ("( 1 1 )" , '⑪' , "U246A")+ , ("( 1 2 )" , '⑫' , "U246B")+ , ("( 1 3 )" , '⑬' , "U246C")+ , ("( 1 4 )" , '⑭' , "U246D")+ , ("( 1 5 )" , '⑮' , "U246E")+ , ("( 1 6 )" , '⑯' , "U246F")+ , ("( 1 7 )" , '⑰' , "U2470")+ , ("( 1 8 )" , '⑱' , "U2471")+ , ("( 1 9 )" , '⑲' , "U2472")+ , ("( 2 0 )" , '⑳' , "U2473")+ , ("( B )" , 'Ⓑ' , "U24B7")+ , ("( C )" , 'Ⓒ' , "U24B8")+ , ("( D )" , 'Ⓓ' , "U24B9")+ , ("( E )" , 'Ⓔ' , "U24BA")+ , ("( F )" , 'Ⓕ' , "U24BB")+ , ("( G )" , 'Ⓖ' , "U24BC")+ , ("( H )" , 'Ⓗ' , "U24BD")+ , ("( I )" , 'Ⓘ' , "U24BE")+ , ("( J )" , 'Ⓙ' , "U24BF")+ , ("( K )" , 'Ⓚ' , "U24C0")+ , ("( L )" , 'Ⓛ' , "U24C1")+ , ("( M )" , 'Ⓜ' , "U24C2")+ , ("( N )" , 'Ⓝ' , "U24C3")+ , ("( O )" , 'Ⓞ' , "U24C4")+ , ("( P )" , 'Ⓟ' , "U24C5")+ , ("( Q )" , 'Ⓠ' , "U24C6")+ , ("( R )" , 'Ⓡ' , "U24C7")+ , ("( S )" , 'Ⓢ' , "U24C8")+ , ("( T )" , 'Ⓣ' , "U24C9")+ , ("( V )" , 'Ⓥ' , "U24CB")+ , ("( W )" , 'Ⓦ' , "U24CC")+ , ("( X )" , 'Ⓧ' , "U24CD")+ , ("( Y )" , 'Ⓨ' , "U24CE")+ , ("( Z )" , 'Ⓩ' , "U24CF")+ , ("( a )" , 'ⓐ' , "U24D0")+ , ("( b )" , 'ⓑ' , "U24D1")+ , ("( c )" , 'ⓒ' , "U24D2")+ , ("( d )" , 'ⓓ' , "U24D3")+ , ("( e )" , 'ⓔ' , "U24D4")+ , ("( f )" , 'ⓕ' , "U24D5")+ , ("( g )" , 'ⓖ' , "U24D6")+ , ("( h )" , 'ⓗ' , "U24D7")+ , ("( i )" , 'ⓘ' , "U24D8")+ , ("( j )" , 'ⓙ' , "U24D9")+ , ("( k )" , 'ⓚ' , "U24DA")+ , ("( l )" , 'ⓛ' , "U24DB")+ , ("( m )" , 'ⓜ' , "U24DC")+ , ("( n )" , 'ⓝ' , "U24DD")+ , ("( o )" , 'ⓞ' , "U24DE")+ , ("( p )" , 'ⓟ' , "U24DF")+ , ("( q )" , 'ⓠ' , "U24E0")+ , ("( r )" , 'ⓡ' , "U24E1")+ , ("( s )" , 'ⓢ' , "U24E2")+ , ("( t )" , 'ⓣ' , "U24E3")+ , ("( u )" , 'ⓤ' , "U24E4")+ , ("( v )" , 'ⓥ' , "U24E5")+ , ("( w )" , 'ⓦ' , "U24E6")+ , ("( x )" , 'ⓧ' , "U24E7")+ , ("( y )" , 'ⓨ' , "U24E8")+ , ("( z )" , 'ⓩ' , "U24E9")+ , ("( 0 )" , '⓪' , "U24EA")+ , ("( 2 1 )" , '㉑' , "U3251")+ , ("( 2 2 )" , '㉒' , "U3252")+ , ("( 2 3 )" , '㉓' , "U3253")+ , ("( 2 4 )" , '㉔' , "U3254")+ , ("( 2 5 )" , '㉕' , "U3255")+ , ("( 2 6 )" , '㉖' , "U3256")+ , ("( 2 7 )" , '㉗' , "U3257")+ , ("( 2 8 )" , '㉘' , "U3258")+ , ("( 2 9 )" , '㉙' , "U3259")+ , ("( 3 0 )" , '㉚' , "U325A")+ , ("( 3 1 )" , '㉛' , "U325B")+ , ("( 3 2 )" , '㉜' , "U325C")+ , ("( 3 3 )" , '㉝' , "U325D")+ , ("( 3 4 )" , '㉞' , "U325E")+ , ("( 3 5 )" , '㉟' , "U325F")+ , ("( 3 6 )" , '㊱' , "U32B1")+ , ("( 3 7 )" , '㊲' , "U32B2")+ , ("( 3 8 )" , '㊳' , "U32B3")+ , ("( 3 9 )" , '㊴' , "U32B4")+ , ("( 4 0 )" , '㊵' , "U32B5")+ , ("( 4 1 )" , '㊶' , "U32B6")+ , ("( 4 2 )" , '㊷' , "U32B7")+ , ("( 4 3 )" , '㊸' , "U32B8")+ , ("( 4 4 )" , '㊹' , "U32B9")+ , ("( 4 5 )" , '㊺' , "U32BA")+ , ("( 4 6 )" , '㊻' , "U32BB")+ , ("( 4 7 )" , '㊼' , "U32BC")+ , ("( 4 8 )" , '㊽' , "U32BD")+ , ("( 4 9 )" , '㊾' , "U32BE")+ , ("( 5 0 )" , '㊿' , "U32BF")+ , ("; S" , 'Ș' , "U0218")+ , ("; s" , 'ș' , "U0219")+ , ("; T" , 'Ț' , "U021A")+ , ("; t" , 'ț' , "U021B")+ , ("v /" , '√' , "U221a")+ , ("8 8" , '∞' , "U221e")+ , ("= _" , '≡' , "U2261")+ , ("< _" , '≤' , "U2264")+ , ("> _" , '≥' , "U2265")+ , ("< >" , '⋄' , "U22c4")+ , (": ." , '∴' , "therefore")+ , (". :" , '∵' , "because")+ , ("[ ]" , '⌷' , "U2337")+ , ("/ -" , '⌿' , "U233f")+ , ("\\ -" , '⍀' , "U2340")+ , ("_ '" , '⍘' , "U2358")+ , ("0 ~" , '⍬' , "U236c")+ , ("| ~" , '⍭' , "U236d")++ -- Sequences that should exist but do not work+ --, ("^ spc", '^', "asciicircum") -- This overlaps with the normal 'shifted-6' macro for+ -- , ("' j", 'j́', "jacute")+ ]+
+ src/KMonad/Keyboard/IO.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE DeriveAnyClass #-}+{-|+Module : KMonad.Keyboard.IO+Description : The logic behind sending and receiving key events to the OS+Copyright : (c) David Janssen, 2019+License : MIT++Maintainer : janssen.dhj@gmail.com+Stability : experimental+Portability : non-portable (MPTC with FD, FFI to Linux-only c-code)++-}+module KMonad.Keyboard.IO+ ( -- * KeySink: send keyboard events to the OS+ -- $snk+ KeySink+ , mkKeySink+ , emitKey++ -- * KeySource: read keyboard events from the OS+ , KeySource+ , mkKeySource+ , awaitKey+ )+where++import KMonad.Prelude++import KMonad.Keyboard+import KMonad.Util++import qualified RIO.Text as T++--------------------------------------------------------------------------------+-- $snk++-- | A 'KeySink' sends key actions to the OS+newtype KeySink = KeySink { emitKeyWith :: KeyEvent -> IO () }++-- | Create a new 'KeySink'+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+ -> RIO e (Acquire KeySink)+mkKeySink o c w = do+ u <- askUnliftIO+ let open = unliftIO u $ logInfo "Opening KeySink" >> o+ let close snk = unliftIO u $ logInfo "Closing KeySink" >> c snk+ let write snk a = unliftIO u $ w snk a+ `catch` logRethrow "Encountered error in KeySink"+ pure $ KeySink . write <$> mkAcquire open close++-- | Emit a key to the OS+emitKey :: (HasLogFunc e) => KeySink -> KeyEvent -> RIO e ()+emitKey snk e = do+ logDebug $ "Emitting: " <> display e+ liftIO $ emitKeyWith snk e+++--------------------------------------------------------------------------------+-- $src++-- | A 'KeySource' is an action that awaits 'KeyEvent's from the OS+newtype KeySource = KeySource { awaitKeyWith :: IO KeyEvent}++-- | Create a new KeySource+mkKeySource :: HasLogFunc e+ => RIO e src -- ^ Action to acquire the keysink+ -> (src -> RIO e ()) -- ^ Action to close the keysink+ -> (src -> RIO e KeyEvent) -- ^ Action to write with the keysink+ -> RIO e (Acquire KeySource)+mkKeySource o c r = do+ u <- askUnliftIO+ let open = unliftIO u $ logInfo "Opening KeySource" >> o+ let close src = unliftIO u $ logInfo "Closing KeySource" >> c src+ let read src = unliftIO u $ r src+ `catch` logRethrow "Encountered error in KeySource"+ pure $ KeySource . read <$> mkAcquire open close++-- | Wait for the next key from the OS+awaitKey :: (HasLogFunc e) => KeySource -> RIO e KeyEvent+awaitKey src = do+ e <- liftIO . awaitKeyWith $ src+ logDebug $ "\n" <> display (T.replicate 80 "-")+ <> "\nReceived event: " <> display e+ pure e
+ src/KMonad/Keyboard/IO/Linux/DeviceSource.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE DeriveAnyClass #-}+{-|+Module : KMonad.Keyboard.IO.Linux.DeviceSource+Description : Load and acquire a linux /dev/input device+Copyright : (c) David Janssen, 2019+License : MIT+Maintainer : janssen.dhj@gmail.com+Stability : experimental+Portability : portable++-}+module KMonad.Keyboard.IO.Linux.DeviceSource+ ( deviceSource+ , deviceSource64++ , KeyEventParser+ , decode64+ )+where++import KMonad.Prelude+import Foreign.C.Types+import System.Posix++import KMonad.Keyboard.IO.Linux.Types+import KMonad.Util++import qualified Data.Serialize as B (decode)+import qualified RIO.ByteString as B++--------------------------------------------------------------------------------+-- $err++data DeviceSourceError+ = IOCtlGrabError FilePath+ | IOCtlReleaseError 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 (KeyIODecodeError msg) = "KeyEvent decode failed with msg: " <> msg++makeClassyPrisms ''DeviceSourceError++--------------------------------------------------------------------------------+-- $ffi+foreign import ccall "ioctl_keyboard"+ c_ioctl_keyboard :: CInt -> 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))+++--------------------------------------------------------------------------------+-- $decoding++-- | A 'KeyEventParser' describes how to read and parse 'LinuxKeyEvent's from+-- the binary data-stream provided by the device-file.+data KeyEventParser = KeyEventParser+ { _nbytes :: !Int+ -- ^ Size of 1 input event in bytes+ , _prs :: !(B.ByteString -> Either String LinuxKeyEvent)+ -- ^ Function to convert bytestring to event+ }+makeClassy ''KeyEventParser++-- | Default configuration for parsing keyboard events+defEventParser :: KeyEventParser+defEventParser = KeyEventParser 24 decode64++-- | The KeyEventParser that works on my 64-bit Linux environment+decode64 :: B.ByteString -> Either String LinuxKeyEvent+decode64 bs = (linuxKeyEvent . fliptup) <$> result+ where+ result :: Either String (Int32, Word16, Word16, Word64, Word64)+ result = B.decode . B.reverse $ bs++ fliptup (a, b, c, d, e) = (e, d, c, b, a)+++--------------------------------------------------------------------------------+-- $types++-- | Configurable components of a DeviceSource+data DeviceSourceCfg = DeviceSourceCfg+ { _pth :: !FilePath -- ^ Path to the event-file+ , _parser :: !KeyEventParser -- ^ The method used to decode events+ }+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+ }+makeClassy ''DeviceFile++instance HasDeviceSourceCfg DeviceFile where deviceSourceCfg = cfg+instance HasKeyEventParser DeviceFile where keyEventParser = cfg.parser++-- | Open a device file+deviceSource :: HasLogFunc e+ => KeyEventParser -- ^ The method by which to read and decode events+ -> FilePath -- ^ The filepath to the device file+ -> RIO e (Acquire KeySource)+deviceSource pr pt = mkKeySource (lsOpen pr pt) lsClose lsRead++-- | Open a device file on a standard linux 64 bit architecture+deviceSource64 :: HasLogFunc e+ => FilePath -- ^ The filepath to the device file+ -> RIO e (Acquire KeySource)+deviceSource64 = deviceSource defEventParser+++--------------------------------------------------------------------------------+-- $io++-- | Open the keyboard, perform an ioctl grab and return a 'DeviceFile'. 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 ReadOnly Nothing $+ OpenFileFlags False False False False False+ hd <- liftIO $ fdToHandle h+ logInfo $ "Initiating ioctl grab"+ ioctl_keyboard h True `onErr` IOCtlGrabError pt+ return $ DeviceFile (DeviceSourceCfg pt pr) h hd++-- | 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+ logInfo $ "Releasing ioctl grab"+ ioctl_keyboard (src^.fd) False `onErr` IOCtlReleaseError (src^.pth)+ liftIO . closeFd $ src^.fd++-- | 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)+ case (src^.prs $ bts) of+ Right p -> case fromLinuxKeyEvent p of+ Just e -> return e+ Nothing -> lsRead src+ Left s -> throwIO $ KeyIODecodeError s
+ src/KMonad/Keyboard/IO/Linux/Types.hs view
@@ -0,0 +1,122 @@+{-|+Module : KMonad.Keyboard.IO.Linux.Types+Description : The types particular to Linux key IO+Copyright : (c) David Janssen, 2019+License : MIT++Maintainer : janssen.dhj@gmail.com+Stability : experimental+Portability : non-portable (MPTC with FD, FFI to Linux-only c-code)++-}+module KMonad.Keyboard.IO.Linux.Types+ ( -- * The LinuxKeyEvent datatype, its constructors, and instances+ -- $types+ LinuxKeyEvent(..)+ , linuxKeyEvent+ , sync++ -- * Casting between 'KeyEvent' and 'LinuxKeyEvent'+ -- $linuxev+ , toLinuxKeyEvent+ , fromLinuxKeyEvent++ -- * Reexport common modules+ , module KMonad.Keyboard+ , module KMonad.Keyboard.IO+ )+where++import KMonad.Prelude++import Data.Time.Clock.System+import Foreign.C.Types (CInt)+import RIO.Partial (toEnum)++import KMonad.Keyboard+import KMonad.Keyboard.IO+import KMonad.Util+++--------------------------------------------------------------------------------+-- $helper++fi :: Integral a => a -> CInt+fi = fromIntegral++--------------------------------------------------------------------------------+-- $types+--+-- Linux produces a stream of binary data representing all its input events+-- through the \/dev\/input files. Each event is represented by 5 numbers:+-- seconds, microseconds, event-type, event-code, and event-value. For more+-- explanation look at: https://www.kernel.org/doc/Documentation/input/input.txt++-- | The LinuxKeyEvent datatype+newtype LinuxKeyEvent = LinuxKeyEvent (CInt, CInt, CInt, CInt, CInt)+ deriving Show++instance Display LinuxKeyEvent where+ textDisplay (LinuxKeyEvent (s, ns, typ, c, val)) = mconcat+ [ tshow s, ".", tshow ns, ": "+ , "type: ", tshow typ, ", "+ , "code: ", tshow c, ", "+ , "val: ", tshow val+ ]++-- | A smart constructor that casts from any integral+linuxKeyEvent+ :: (Integral a, Integral b, Integral c, Integral d, Integral e)+ => (a, b, c, d, e) -- ^ The tuple representing the event+ -> LinuxKeyEvent -- ^ The LinuxKeyEvent+linuxKeyEvent (a, b, c, d, e) = LinuxKeyEvent (f a, f b, f c, f d, f e)+ where+ f :: Integral a => a -> CInt+ f = fromIntegral++-- | Constructor for linux sync events. Whenever you write an event to linux,+-- you need to emit a 'sync' to signal to linux that it should sync all queued+-- updates.+sync :: SystemTime -> LinuxKeyEvent+sync (MkSystemTime s ns) = LinuxKeyEvent (fi s, fi ns, 0, 0, 0)+++-------------------------------------------------------------------------------+-- $linuxev+--+-- We only represent a subset of all the possible input events produced by+-- Linux. First of all, we disregard all event types that are not key events, so+-- we quietly ignore all sync and scan events. There other other events that are+-- there to do things like toggle LEDs on your keyboard that we also ignore.+--+-- Furthermore, within the category of KeyEvents, we only register presses and+-- releases, and completely ignore repeat events.+--+-- The correspondence between LinuxKeyEvents and core KeyEvents can best be read+-- in the above-mentioned documentation, but the quick version is this:+-- Typ: 1 = KeyEvent (see below)+-- 4 = @scancode@ event (we neither read nor write)+-- 0 = 'sync' event (we don't read, but do generate for writing)+-- Val: for keys: 0 = Release, 1 = Press, 2 = Repeat+-- for sync: always 0+-- Code: for keys: an Int value corresponding to a keycode+-- see: https://github.com/torvalds/linux/blob/master/include/uapi/linux/input-event-codes.h+-- for sync: always 0++-- | Translate a 'LinuxKeyEvent' to a kmonad 'KeyEvent'+fromLinuxKeyEvent :: LinuxKeyEvent -> Maybe KeyEvent+fromLinuxKeyEvent (LinuxKeyEvent (_, _, typ, c, val))+ | typ == 1 && val == 0 = Just . mkRelease $ kc+ | typ == 1 && val == 1 = Just . mkPress $ kc+ | otherwise = Nothing+ where+ kc = toEnum . fromIntegral $ c -- This is theoretically partial, but practically not++-- | Translate kmonad 'KeyEvent' along with a 'SystemTime' to 'LinuxKeyEvent's+-- for writing.+toLinuxKeyEvent :: KeyEvent -> SystemTime -> LinuxKeyEvent+toLinuxKeyEvent e (MkSystemTime s ns)+ = LinuxKeyEvent (fi s, fi ns, 1, c, val)+ where+ c = fi . fromEnum $ e^.keycode+ val = if (e^.switch == Press) then 1 else 0
+ src/KMonad/Keyboard/IO/Linux/UinputSink.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE DeriveAnyClass #-}+{-|+Module : KMonad.Keyboard.IO.Linux.UinputSink+Description : Using Linux's uinput interface to emit events+Copyright : (c) David Janssen, 2019+License : MIT+Maintainer : janssen.dhj@gmail.com+Stability : experimental+Portability : portable+-}+module KMonad.Keyboard.IO.Linux.UinputSink+ ( UinputSink+ , UinputCfg(..)+ , keyboardName+ , vendorCode+ , productCode+ , productVersion+ , postInit+ , uinputSink+ , defUinputCfg+ )+where++import KMonad.Prelude++import Data.Time.Clock.System (getSystemTime)++import Foreign.C.String+import Foreign.C.Types+import System.Posix+import UnliftIO.Async (async)+import UnliftIO.Process (callCommand)++import KMonad.Keyboard.IO.Linux.Types+import KMonad.Util++--------------------------------------------------------------------------------+-- $err++type SinkId = String++-- | A collection of everything that can go wrong with the 'UinputSink'+data UinputSinkError+ = UinputRegistrationError SinkId -- ^ Could not register device+ | UinputReleaseError SinkId -- ^ Could not release device+ | SinkEncodeError SinkId LinuxKeyEvent -- ^ Could not decode event+ deriving Exception++instance Show UinputSinkError where+ show (UinputRegistrationError snk) = "Could not register sink with OS: " <> snk+ show (UinputReleaseError snk) = "Could not unregister sink with OS: " <> snk+ show (SinkEncodeError snk a) = unwords+ [ "Could not encode Keyaction"+ , show a+ , "to bytes for writing to"+ , snk+ ]++makeClassyPrisms ''UinputSinkError+++--------------------------------------------------------------------------------+-- $cfg++-- | Configuration of the Uinput keyboard to instantiate+data UinputCfg = UinputCfg+ { _vendorCode :: !CInt+ , _productCode :: !CInt+ , _productVersion :: !CInt+ , _keyboardName :: !String+ , _postInit :: !(Maybe String)+ } deriving (Eq, Show)+makeClassy ''UinputCfg++-- | Default Uinput configuration+defUinputCfg :: UinputCfg+defUinputCfg = UinputCfg+ { _vendorCode = 0x1235+ , _productCode = 0x5679+ , _productVersion = 0x0000+ , _keyboardName = "KMonad simulated keyboard"+ , _postInit = Nothing+ }++-- | UinputSink is an MVar to a filehandle+data UinputSink = UinputSink+ { _cfg :: UinputCfg+ , _st :: MVar Fd+ }+makeLenses ''UinputSink++-- | Return a new uinput 'KeySink' with extra options+uinputSink :: HasLogFunc e => UinputCfg -> RIO e (Acquire KeySink)+uinputSink c = mkKeySink (usOpen c) usClose usWrite++--------------------------------------------------------------------------------+-- FFI calls and type-friendly wrappers++foreign import ccall "acquire_uinput_keysink"+ c_acquire_uinput_keysink+ :: CInt -- ^ Posix handle to the file to open+ -> CString -- ^ Name to give to the keyboard+ -> CInt -- ^ Vendor ID+ -> CInt -- ^ Product ID+ -> CInt -- ^ Version ID+ -> IO Int++foreign import ccall "release_uinput_keysink"+ c_release_uinput_keysink :: CInt -> IO Int++foreign import ccall "send_event"+ c_send_event :: CInt -> CInt -> CInt -> CInt -> CInt -> CInt -> IO Int++-- | Create and acquire a Uinput device+acquire_uinput_keysink :: MonadIO m => Fd -> UinputCfg -> m Int+acquire_uinput_keysink (Fd h) c = liftIO $ do+ cstr <- newCString $ c^.keyboardName+ c_acquire_uinput_keysink h cstr+ (c^.vendorCode) (c^.productCode) (c^.productVersion)++-- | Release a Uinput device+release_uinput_keysink :: MonadIO m => Fd -> m Int+release_uinput_keysink (Fd h) = liftIO $ c_release_uinput_keysink h++-- | Using a Uinput device, send a LinuxKeyEvent to the Linux kernel+send_event :: ()+ => UinputSink+ -> Fd+ -> LinuxKeyEvent+ -> RIO e ()+send_event u (Fd h) e@(LinuxKeyEvent (s', ns', typ, c, val)) = do+ (liftIO $ c_send_event h typ c val s' ns')+ `onErr` SinkEncodeError (u^.cfg.keyboardName) e+++--------------------------------------------------------------------------------++-- | Create a new UinputSink+usOpen :: HasLogFunc e => UinputCfg -> RIO e UinputSink+usOpen c = do+ fd <- liftIO . openFd "/dev/uinput" WriteOnly Nothing $+ OpenFileFlags False False False True False+ logInfo "Registering Uinput device"+ acquire_uinput_keysink fd c `onErr` UinputRegistrationError (c ^. keyboardName)+ flip (maybe $ pure ()) (c^.postInit) $ \cmd -> do+ logInfo $ "Running UinputSink command: " <> displayShow cmd+ void . async . callCommand $ cmd+ UinputSink c <$> newMVar fd++-- | Close a 'UinputSink'+usClose :: HasLogFunc e => UinputSink -> RIO e ()+usClose snk = withMVar (snk^.st) $ \h -> finally (release h) (close h)+ where+ release h = do+ logInfo $ "Unregistering Uinput device"+ release_uinput_keysink h+ `onErr` UinputReleaseError (snk^.cfg.keyboardName)++ close h = do+ logInfo $ "Closing Uinput device file"+ liftIO $ closeFd h++-- | Write a keyboard event to the sink and sync the driver state. Using an MVar+-- ensures that we can never have 2 threads try to write at the same time.+usWrite :: HasLogFunc e => UinputSink -> KeyEvent -> RIO e ()+usWrite u e = withMVar (u^.st) $ \fd -> do+ now <- liftIO $ getSystemTime+ send_event u fd . toLinuxKeyEvent e $ now+ send_event u fd . sync $ now
+ src/KMonad/Keyboard/IO/Mac/IOKitSource.hs view
@@ -0,0 +1,81 @@+module KMonad.Keyboard.IO.Mac.IOKitSource+ ( iokitSource+ )+where++import KMonad.Prelude++import Foreign.Marshal hiding (void)+import Foreign.Ptr+import Foreign.Storable+import Foreign.C.String++import KMonad.Keyboard+import KMonad.Keyboard.IO+import KMonad.Keyboard.IO.Mac.Types++--------------------------------------------------------------------------------++-- | Use the mac c-api to `grab` a keyboard+foreign import ccall "grab_kb"+ grab_kb :: CString -> IO Word8++-- | Release the keyboard hook+foreign import ccall "release_kb"+ release_kb :: IO Word8++-- | 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 MacKeyEvent -> IO Word8+++data EvBuf = EvBuf+ { _buffer :: !(Ptr MacKeyEvent)+ }+makeLenses ''EvBuf++-- | Return a KeySource using the Mac IOKit approach+iokitSource :: HasLogFunc e+ => (Maybe String)+ -> RIO e (Acquire KeySource)+iokitSource name = mkKeySource (iokitOpen name) iokitClose iokitRead+++--------------------------------------------------------------------------------++-- | Ask IOKit to open keyboards matching the specified name+iokitOpen :: HasLogFunc e+ => (Maybe String)+ -> RIO e EvBuf+iokitOpen m = do+ logInfo "Opening IOKit devices"+ liftIO $ do++ case m of+ Nothing -> void $ grab_kb nullPtr+ Just s -> do+ str <- newCString s+ void $ grab_kb str+ free str++ buf <- mallocBytes $ sizeOf (undefined :: MacKeyEvent)+ pure $ EvBuf buf++-- | Ask Mac to close the queue+iokitClose :: HasLogFunc e => EvBuf -> RIO e ()+iokitClose b = do+ logInfo "Closing IOKit devices"+ liftIO $ do+ _ <- release_kb+ free $ b^.buffer++-- | Get a new 'KeyEvent' from Mac+--+-- NOTE: This can throw an error if the event fails to convert.+iokitRead :: HasLogFunc e => EvBuf -> RIO e KeyEvent+iokitRead b = do+ we <- liftIO $ do+ _ <- wait_key $ b^.buffer+ peek $ b^.buffer+ either throwIO pure $ fromMacKeyEvent we
+ src/KMonad/Keyboard/IO/Mac/KextSink.hs view
@@ -0,0 +1,46 @@+module KMonad.Keyboard.IO.Mac.KextSink+ ( kextSink+ )+where++import KMonad.Prelude++import Foreign.Ptr+import Foreign.Marshal+import Foreign.Storable++import KMonad.Keyboard+import KMonad.Keyboard.IO+import KMonad.Keyboard.IO.Mac.Types++foreign import ccall "send_key"+ send_key :: Ptr MacKeyEvent -> IO ()++data EvBuf = EvBuf+ { _buffer :: Ptr MacKeyEvent -- ^ The pointer we write events to+ }+makeClassy ''EvBuf++kextSink :: HasLogFunc e => RIO e (Acquire KeySink)+kextSink = mkKeySink skOpen skClose skSend++-- | Create the 'EvBuf' environment+skOpen :: HasLogFunc e => RIO e EvBuf+skOpen = do+ logInfo "Initializing Mac key sink"+ liftIO $ EvBuf <$> mallocBytes (sizeOf (undefined :: MacKeyEvent))++-- | Close the 'EvBuf' environment+skClose :: HasLogFunc e => EvBuf -> RIO e ()+skClose sk = do+ logInfo "Closing Mac key sink"+ liftIO . free $ sk^.buffer++-- | Write an event to the pointer and prompt windows to inject it+--+-- NOTE: This can throw an error if event-conversion fails.+skSend :: HasLogFunc e => EvBuf -> KeyEvent -> RIO e ()+skSend sk e = either throwIO go $ toMacKeyEvent e+ where go e' = liftIO $ do+ poke (sk^.buffer) e'+ send_key $ sk^.buffer
+ src/KMonad/Keyboard/IO/Mac/Types.hs view
@@ -0,0 +1,306 @@+module KMonad.Keyboard.IO.Mac.Types+ ( MacError(..)+ , MacKeyEvent+ , mkMacKeyEvent+ , toMacKeyEvent+ , fromMacKeyEvent+ )++where++import KMonad.Prelude++import Foreign.Storable+import KMonad.Keyboard++import qualified RIO.HashMap as M+++----------------------------------------------------------------------------+-- $err++-- | Everything that can go wrong with Mac Key-IO+data MacError+ = NoMacKeycodeTo Keycode -- ^ Error translating to 'MacKeycode'+ | NoMacKeycodeFrom MacKeycode -- ^ Error translating from 'MacKeycode'++instance Exception MacError+instance Show MacError where+ show e = case e of+ NoMacKeycodeTo c -> "Cannot translate to mac keycode: " <> show c+ NoMacKeycodeFrom i -> "Cannot translate from mac keycode: " <> show i++--------------------------------------------------------------------------------+-- $typ++type MacSwitch = Word8 -- ^ Type alias for the switch value+type MacKeycode = Word32 -- ^ Type alias for the Mac keycode++-- | 'MacKeyEvent' is the C-representation of a a 'KeyEvent' for our Mac API.+--+-- It contains a 'Word8' signifying whether the event was a Press (0)+-- or Release (1), and a 'Word32' (uint32_t) signifying the Mac+-- keycode (the upper 16 bits represent the IOKit usage page, and the+-- lower 16 bits represent the IOKit usage).+--+-- NOTE: Mac and Linux keycodes do not line up. Internally we use Linux+-- Keycodes for everything, we translate at the KeyIO stage (here).+newtype MacKeyEvent = MacKeyEvent (MacSwitch, MacKeycode)+ deriving (Eq, Ord, Show)++-- | This lets us send 'MacKeyEvent's between Haskell and C.+instance Storable MacKeyEvent where+ alignment _ = 4 -- lowest common denominator of: 1 4+ sizeOf _ = 8 -- (1 + 3-padding) + 4+ peek ptr = do+ s <- peekByteOff ptr 0+ c <- peekByteOff ptr 4+ return $ MacKeyEvent (s, c)+ poke ptr (MacKeyEvent (s, c)) = do+ pokeByteOff ptr 0 s+ pokeByteOff ptr 4 c++mkMacKeyEvent :: MacSwitch -> MacKeycode -> MacKeyEvent+mkMacKeyEvent s e = MacKeyEvent (s, e)++--------------------------------------------------------------------------------+-- $conv++-- | Convert between 'MacSwitch' and 'Switch' representations.+--+-- NOTE: Although 'MacSwitch' could theoretically be something besides 0 or 1,+-- practically it can't, because those are the only values the API generates,+-- guaranteed.+_MacSwitch :: Iso' MacSwitch Switch+_MacSwitch = iso to' from'+ where+ to' w = if w == 0 then Press else Release+ from' s = if s == Press then 0 else 1++-- | Lookup the corresponding 'Keycode' for this 'MacKeycode'+fromMacKeycode :: MacKeycode -> Maybe Keycode+fromMacKeycode = flip M.lookup kcMap++-- | Lookup the correspondig 'MacKeycode' for this 'Keycode'+toMacKeycode :: Keycode -> Maybe MacKeycode+toMacKeycode = flip M.lookup revMap+ where revMap = M.fromList $ (M.toList kcMap) ^.. folded . swapped++-- | Convert a 'KeyEvent' to a 'MacKeyEvent'+--+-- NOTE: Mac keycodes are different, and I am not confident I have full+-- coverage, therefore this conversion is not total. We are going to leave this+-- error-handling in until we are sure this is covered well. Once it lines up+-- perfectly, this is essentially an Iso.+toMacKeyEvent :: KeyEvent -> Either MacError MacKeyEvent+toMacKeyEvent e = case toMacKeycode $ e^.keycode of+ Just c -> Right $ MacKeyEvent (e^.switch.from _MacSwitch, c)+ Nothing -> Left . NoMacKeycodeTo $ e^.keycode++-- | Convert a 'MacKeyEvent' to a 'KeyEvent'+--+-- NOTE: Same limitations as 'toMacKeyEvent' apply+fromMacKeyEvent :: MacKeyEvent -> Either MacError KeyEvent+fromMacKeyEvent (MacKeyEvent (s, c)) = case fromMacKeycode c of+ Just c' -> Right $ mkKeyEvent (s^._MacSwitch) c'+ Nothing -> Left . NoMacKeycodeFrom $ c+++--------------------------------------------------------------------------------+-- $kc++-- | Mac does not use the same keycodes as Linux, so we need to translate.+--+-- See https://opensource.apple.com/source/IOHIDFamily/IOHIDFamily-315.7.16/IOHIDFamily/IOHIDUsageTables.h+-- See https://opensource.apple.com/source/IOHIDFamily/IOHIDFamily-700/IOHIDFamily/AppleHIDUsageTables.h.auto.html+kcMap :: M.HashMap MacKeycode Keycode+kcMap = M.fromList $+ [ (0x00070000, KeyError) -- There's no documentation on this error code, but+ -- I've seen it sent when the rollover is exceeded on+ -- my macbook internal keyboard+ , (0x00070001, KeyError) -- kHIDUsage_KeyErrorRollOver+ , (0x00070002, KeyError) -- kHIDUsage_KeyPOSTFail+ , (0x00070003, KeyError) -- kHIDUsage_Undefined+ , (0x00070004, KeyA)+ , (0x00070005, KeyB)+ , (0x00070006, KeyC)+ , (0x00070007, KeyD)+ , (0x00070008, KeyE)+ , (0x00070009, KeyF)+ , (0x0007000A, KeyG)+ , (0x0007000B, KeyH)+ , (0x0007000C, KeyI)+ , (0x0007000D, KeyJ)+ , (0x0007000E, KeyK)+ , (0x0007000F, KeyL)+ , (0x00070010, KeyM)+ , (0x00070011, KeyN)+ , (0x00070012, KeyO)+ , (0x00070013, KeyP)+ , (0x00070014, KeyQ)+ , (0x00070015, KeyR)+ , (0x00070016, KeyS)+ , (0x00070017, KeyT)+ , (0x00070018, KeyU)+ , (0x00070019, KeyV)+ , (0x0007001A, KeyW)+ , (0x0007001B, KeyX)+ , (0x0007001C, KeyY)+ , (0x0007001D, KeyZ)+ , (0x0007001E, Key1)+ , (0x0007001F, Key2)+ , (0x00070020, Key3)+ , (0x00070021, Key4)+ , (0x00070022, Key5)+ , (0x00070023, Key6)+ , (0x00070024, Key7)+ , (0x00070025, Key8)+ , (0x00070026, Key9)+ , (0x00070027, Key0)+ , (0x00070028, KeyEnter)+ , (0x00070029, KeyEsc)+ , (0x0007002A, KeyBackspace)+ , (0x0007002B, KeyTab)+ , (0x0007002C, KeySpace)+ , (0x0007002D, KeyMinus)+ , (0x0007002E, KeyEqual)+ , (0x0007002F, KeyLeftBrace)+ , (0x00070030, KeyRightBrace)+ , (0x00070031, KeyBackslash)+ -- , (0x00070032, KeyNonUSPound)+ , (0x00070033, KeySemicolon)+ , (0x00070034, KeyApostrophe)+ , (0x00070035, KeyGrave)+ , (0x00070036, KeyComma)+ , (0x00070037, KeyDot)+ , (0x00070038, KeySlash)+ , (0x00070039, KeyCapsLock)+ , (0x0007003A, KeyF1)+ , (0x0007003B, KeyF2)+ , (0x0007003C, KeyF3)+ , (0x0007003D, KeyF4)+ , (0x0007003E, KeyF5)+ , (0x0007003F, KeyF6)+ , (0x00070040, KeyF7)+ , (0x00070041, KeyF8)+ , (0x00070042, KeyF9)+ , (0x00070043, KeyF10)+ , (0x00070044, KeyF11)+ , (0x00070045, KeyF12)+ , (0x00070046, KeyPrint)+ , (0x00070047, KeyScrollLock)+ , (0x00070048, KeyPause)+ , (0x00070049, KeyInsert)+ , (0x0007004A, KeyHome)+ , (0x0007004B, KeyPageUp)+ , (0x0007004C, KeyDelete)+ , (0x0007004D, KeyEnd)+ , (0x0007004E, KeyPageDown)+ , (0x0007004F, KeyRight)+ , (0x00070050, KeyLeft)+ , (0x00070051, KeyDown)+ , (0x00070052, KeyUp)+ , (0x00070053, KeyNumLock)+ , (0x00070054, KeyKpSlash)+ , (0x00070055, KeyKpAsterisk)+ , (0x00070056, KeyKpMinus)+ , (0x00070057, KeyKpPlus)+ , (0x00070058, KeyKpenter)+ , (0x00070059, KeyKp1)+ , (0x0007005A, KeyKp2)+ , (0x0007005B, KeyKp3)+ , (0x0007005C, KeyKp4)+ , (0x0007005D, KeyKp5)+ , (0x0007005E, KeyKp6)+ , (0x0007005F, KeyKp7)+ , (0x00070060, KeyKp8)+ , (0x00070061, KeyKp9)+ , (0x00070062, KeyKp0)+ , (0x00070063, KeyKpDot)+ -- , (0x00070064, KeyNonUSBackslash)+ -- , (0x00070065, KeyApplication)+ , (0x00070066, KeyPower)+ , (0x00070067, KeyKpEqual)+ , (0x00070068, KeyF13)+ , (0x00070069, KeyF14)+ , (0x0007006A, KeyF15)+ , (0x0007006B, KeyF16)+ , (0x0007006C, KeyF17)+ , (0x0007006D, KeyF18)+ , (0x0007006E, KeyF19)+ , (0x0007006F, KeyF20)+ , (0x00070070, KeyF21)+ , (0x00070071, KeyF22)+ , (0x00070072, KeyF23)+ , (0x00070073, KeyF24)+ -- , (0x00070074, KeyExecute)+ , (0x00070075, KeyHelp)+ , (0x00070076, KeyMenu)+ -- , (0x00070077, KeySelect)+ , (0x00070078, KeyStop)+ , (0x00070079, KeyAgain)+ , (0x0007007A, KeyUndo)+ , (0x0007007B, KeyCut)+ , (0x0007007C, KeyCopy)+ , (0x0007007D, KeyPaste)+ , (0x0007007E, KeyFind)+ , (0x0007007F, KeyMute)+ , (0x00070080, KeyVolumeUp)+ , (0x00070081, KeyVolumeDown)+ -- , (0x00070082, KeyLockingCapsLock)+ -- , (0x00070083, KeyLockingNumLock)+ -- , (0x00070084, KeyLockingScrollLock)+ , (0x00070085, KeyKpComma)+ -- , (0x00070086, KeyKpEqualSignAS400)+ -- , (0x00070087, KeyInternational1)+ -- , (0x00070088, KeyInternational2)+ -- , (0x00070089, KeyInternational3)+ -- , (0x0007008A, KeyInternational4)+ -- , (0x0007008B, KeyInternational5)+ -- , (0x0007008C, KeyInternational6)+ -- , (0x0007008D, KeyInternational7)+ -- , (0x0007008E, KeyInternational8)+ -- , (0x0007008F, KeyInternational9)+ -- , (0x00070090, KeyLANG1)+ -- , (0x00070091, KeyLANG2)+ -- , (0x00070092, KeyLANG3)+ -- , (0x00070093, KeyLANG4)+ -- , (0x00070094, KeyLANG5)+ -- , (0x00070095, KeyLANG6)+ -- , (0x00070096, KeyLANG7)+ -- , (0x00070097, KeyLANG8)+ -- , (0x00070098, KeyLANG9)+ -- , (0x00070099, KeyAlternateErase)+ -- , (0x0007009A, KeySysReqOrAttention)+ , (0x0007009B, KeyCancel)+ -- , (0x0007009C, KeyClear)+ -- , (0x0007009D, KeyPrior)+ -- , (0x0007009E, KeyReturn)+ -- , (0x0007009F, KeySeparator)+ -- , (0x000700A0, KeyOut)+ -- , (0x000700A1, KeyOper)+ -- , (0x000700A2, KeyClearOrAgain)+ -- , (0x000700A3, KeyCrSelOrProps)+ -- , (0x000700A4, KeyExSel)+ -- /* 0x000700A5-0x000700DF Reserved */+ , (0x000700E0, KeyLeftCtrl)+ , (0x000700E1, KeyLeftShift)+ , (0x000700E2, KeyLeftAlt)+ , (0x000700E3, KeyLeftMeta)+ , (0x000700E4, KeyRightCtrl)+ , (0x000700E5, KeyRightShift)+ , (0x000700E6, KeyRightAlt)+ , (0x000700E7, KeyRightMeta)+ -- /* 0x000700E8-0x0007FFFF Reserved */+ , (0x0007FFFF, KeyReserved)+ , (0x000C00B5, KeyNextSong)+ , (0x000C00B6, KeyPreviousSong)+ , (0x000C00CD, KeyPlayPause)+ , (0x00FF0003, KeyFn)+ , (0x00FF0004, KeyBrightnessUp)+ , (0x00FF0005, KeyBrightnessDown)+ , (0x00FF0008, KeyBacklightUp)+ , (0x00FF0009, KeyBacklightDown)+ , (0xFF010004, KeyLaunchpad)+ , (0xFF010010, KeyMissionCtrl)+ ]
+ src/KMonad/Keyboard/IO/Windows/LowLevelHookSource.hs view
@@ -0,0 +1,84 @@+{-|+Module : KMonad.Keyboard.IO.Windows.LowLevelHookSource+Description : Load and acquire a windows low-level keyboard hook.+Copyright : (c) David Janssen, 2019+License : MIT+Maintainer : janssen.dhj@gmail.com+Stability : experimental+Portability : portable++-}+module KMonad.Keyboard.IO.Windows.LowLevelHookSource+ ( llHook+ )+where++import KMonad.Prelude++import Foreign.Marshal hiding (void)+import Foreign.Ptr+import Foreign.Storable++import KMonad.Keyboard+import KMonad.Keyboard.IO+import KMonad.Keyboard.IO.Windows.Types++--------------------------------------------------------------------------------++-- | Use the windows c-api to `grab` a keyboard+foreign import ccall "grab_kb"+ grab_kb :: IO Word8++-- | Release the keyboard hook+foreign import ccall "release_kb"+ release_kb :: IO Word8++-- | 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 ()+++--------------------------------------------------------------------------------++-- | Data used to track `connection` to windows process+data LLHook = LLHook+ { _thread :: !(Async Word8) -- ^ The thread-id of the listen-process+ , _buffer :: !(Ptr WinKeyEvent) -- ^ Buffer used to communicate with process+ }+makeLenses ''LLHook++-- | Return a KeySource using the Windows low-level hook approach.+llHook :: HasLogFunc e => RIO e (Acquire KeySource)+llHook = mkKeySource llOpen llClose llRead+++--------------------------------------------------------------------------------++-- | Ask windows to install a hook and allocate the reading-buffer+llOpen :: HasLogFunc e => RIO e LLHook+llOpen = do+ logInfo "Registering low-level Windows keyboard hook"+ liftIO $ do+ tid <- async grab_kb+ buf <- mallocBytes $ sizeOf (undefined :: WinKeyEvent)+ pure $ LLHook tid buf++-- | Ask windows to unregister the hook and free the data-buffer+llClose :: HasLogFunc e => LLHook -> RIO e ()+llClose ll = do+ logInfo "Unregistering low-level Windows keyboard hook"+ liftIO $ do+ _ <- release_kb+ cancel $ ll^.thread -- This might not be necessary, but it is safer+ free $ ll^.buffer++-- | Get a new 'KeyEvent' from Windows+--+-- 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+ either throwIO pure $ fromWinKeyEvent we
+ src/KMonad/Keyboard/IO/Windows/SendEventSink.hs view
@@ -0,0 +1,64 @@+{-|+Module : KMonad.Keyboard.IO.Windows.SendEventSink+Description : Using Windows' send_event functionality to inject KeyEvent's+Copyright : (c) David Janssen, 2019+License : MIT+Maintainer : janssen.dhj@gmail.com+Stability : experimental+Portability : portable++This uses @sendKey@ from the @keyio_win.c@ to send keys to Windows. This itself+then uses the Windows 'SendInput' system call.++-}+module KMonad.Keyboard.IO.Windows.SendEventSink+ ( sendEventKeySink+ )+where++import KMonad.Prelude++import Foreign.Ptr+import Foreign.Marshal+import Foreign.Storable++import KMonad.Keyboard+import KMonad.Keyboard.IO+import KMonad.Keyboard.IO.Windows.Types+++--------------------------------------------------------------------------------++foreign import ccall "sendKey"+ sendKey :: Ptr WinKeyEvent -> IO ()++-- | The SKSink environment+data SKSink = SKSink+ { _buffer :: Ptr WinKeyEvent -- ^ The pointer we write events to+ }+makeClassy ''SKSink++-- | Return a 'KeySink' using Window's @sendEvent@ functionality.+sendEventKeySink :: HasLogFunc e => RIO e (Acquire KeySink)+sendEventKeySink = mkKeySink skOpen skClose skSend++-- | Create the 'SKSink' environment+skOpen :: HasLogFunc e => RIO e SKSink+skOpen = do+ logInfo "Initializing Windows key sink"+ liftIO $ SKSink <$> mallocBytes (sizeOf (undefined :: WinKeyEvent))++-- | Close the 'SKSink' environment+skClose :: HasLogFunc e => SKSink -> RIO e ()+skClose sk = do+ logInfo "Closing Windows key sink"+ liftIO . free $ sk^.buffer++-- | Write an event to the pointer and prompt windows to inject it+--+-- NOTE: This can throw an error if event-conversion fails.+skSend :: HasLogFunc e => SKSink -> KeyEvent -> RIO e ()+skSend sk e = either throwIO go $ toWinKeyEvent e+ where go e' = liftIO $ do+ poke (sk^.buffer) e'+ sendKey $ sk^.buffer
+ src/KMonad/Keyboard/IO/Windows/Types.hs view
@@ -0,0 +1,312 @@+{-|+Module : KMonad.Keyboard.IO.Windows.Types+Description : The Windows-specific representation of KeyEvent.+Copyright : (c) David Janssen, 2019+License : MIT+Maintainer : janssen.dhj@gmail.com+Stability : experimental+Portability : portable++NOTE: The representation here lines up with the @keyio_win.c@ module, not with+Windows in general. There is some translation happening in the c-code.++-}+module KMonad.Keyboard.IO.Windows.Types+ ( WinError(..)+ , WinKeyEvent+ , mkWinKeyEvent+ , toWinKeyEvent+ , fromWinKeyEvent+ )++where++import KMonad.Prelude++import Foreign.Storable+import KMonad.Keyboard++import qualified RIO.HashMap as M+++----------------------------------------------------------------------------+-- $err++-- | Everything that can go wrong with Windows Key-IO+data WinError+ = NoWinKeycodeTo Keycode -- ^ Error translating to 'WinKeycode'+ | NoWinKeycodeFrom WinKeycode -- ^ Error translating from 'WinKeycode'++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++--------------------------------------------------------------------------------+-- $typ++type WinSwitch = Word8 -- ^ Type alias for the switch value+type WinKeycode = Word32 -- ^ Type alias for the windows encoded keycode++-- | 'WinKeyEvent' is the C-representation of a a 'KeyEvent' for our Windows API.+--+-- It contains a 'Word8' signifying whether the event was a Press (0) or Release+-- (1), and a 'Word32' (Windows @DWORD@) signifying the *Windows keycode*.+--+-- NOTE: Windows and Linux keycodes do not line up. Internally we use Linux+-- Keycodes for everything, we translate at the KeyIO stage (here).+newtype WinKeyEvent = WinKeyEvent (WinSwitch, WinKeycode)+ deriving (Eq, Ord, Show)++-- | This lets us send 'WinKeyEvent's between Haskell and C.+instance Storable WinKeyEvent where+ alignment _ = 4 -- lowest common denominator of: 1 4+ sizeOf _ = 8 -- (1 + 3-padding) + 4+ peek ptr = do+ s <- peekByteOff ptr 0+ c <- peekByteOff ptr 4+ return $ WinKeyEvent (s, c)+ poke ptr (WinKeyEvent (s, c)) = do+ pokeByteOff ptr 0 s+ pokeByteOff ptr 4 c++mkWinKeyEvent :: WinSwitch -> WinKeycode -> WinKeyEvent+mkWinKeyEvent s e = WinKeyEvent (s, e)++--------------------------------------------------------------------------------+-- $conv++-- | Convert between 'WinSwitch' and 'Switch' representations.+--+-- NOTE: Although 'WinSwitch' could theoretically be something besides 0 or 1,+-- practically it can't, because those are the only values the API generates,+-- guaranteed.+_WinSwitch :: Iso' WinSwitch Switch+_WinSwitch = iso to' from'+ where+ to' w = if w == 0 then Press else Release+ from' s = if s == Press then 0 else 1++-- | Lookup the corresponding 'Keycode' for this 'WinKeycode'+fromWinKeycode :: WinKeycode -> Maybe Keycode+fromWinKeycode = flip M.lookup kcMap++-- | Lookup the correspondig 'WinKeycode' for this 'Keycode'+toWinKeycode :: Keycode -> Maybe WinKeycode+toWinKeycode = flip M.lookup revMap+ where revMap = M.fromList $ (M.toList kcMap) ^.. folded . swapped++-- | Convert a 'KeyEvent' to a 'WinKeyEvent'+--+-- NOTE: Windows keycodes are different, and I am not confident I have full+-- coverage, therefore this conversion is not total. We are going to leave this+-- error-handling in until we are sure this is covered well. Once it lines up+-- perfectly, this is essentially an Iso.+toWinKeyEvent :: KeyEvent -> Either WinError WinKeyEvent+toWinKeyEvent e = case toWinKeycode $ e^.keycode of+ Just c -> Right $ WinKeyEvent (e^.switch.from _WinSwitch, c)+ Nothing -> Left . NoWinKeycodeTo $ e^.keycode++-- | Convert a 'WinKeyEvent' to a 'KeyEvent'+--+-- NOTE: Same limitations as 'toWinKeyEvent' apply+fromWinKeyEvent :: WinKeyEvent -> Either WinError KeyEvent+fromWinKeyEvent (WinKeyEvent (s, c)) = case fromWinKeycode c of+ Just c' -> Right $ mkKeyEvent (s^._WinSwitch) c'+ Nothing -> Left . NoWinKeycodeFrom $ c+++--------------------------------------------------------------------------------+-- $kc++-- | Windows does not use the same keycodes as Linux, so we need to translate.+--+-- FIXME: There are loads of missing correspondences, mostly for rare-keys. How+-- do these line up? Ideally this mapping would be total.+kcMap :: M.HashMap WinKeycode Keycode+kcMap = M.fromList $+ [ (0x00, Missing254) -- Not documented, but happens often. Why??+ , (0x08, KeyBackspace)+ , (0x09, KeyTab)+ , (0x0C, KeyKp5) -- VK_CLEAR: NumPad 5 when numlock is not engaged+ , (0x0D, KeyEnter)+ , (0x10, KeyLeftShift) -- No 'sidedness'??+ , (0x11, KeyLeftCtrl) -- No 'sidedness'??+ , (0x12, KeyLeftAlt) -- No 'sidedness'??+ , (0x13, KeyPause)+ , (0x14, KeyCapsLock)+ , (0x15, KeyKatakana) -- Also: KeyHangul+ -- , (0x17, ???) -- Defined as VK_JUNJA+ -- , (0x18, ???) -- Defined as VK_HANJA+ -- , (0x19, ???) -- Defined as VK_KANJI+ , (0x1B, KeyEsc)+ -- , (0x1C, ???) -- Defined as VK_CONVERT+ -- , (0x1D, ???) -- Defined as VK_NONCONVERT+ -- , (0x1E, ???) -- Defined as VK_ACCEPT+ -- , (0x1F, ???) -- Defined as VK_MODECHANGE+ , (0x20, KeySpace)+ , (0x21, KeyPageUp)+ , (0x22, KeyPageDown)+ , (0x23, KeyEnd)+ , (0x24, KeyHome)+ , (0x25, KeyLeft)+ , (0x26, KeyUp)+ , (0x27, KeyRight)+ , (0x28, KeyDown)+ -- , (0x29, ???) -- Defined as VK_SELECT+ , (0x2A, KeyPrint)+ -- , (0x2B, ???) -- Defined as VK_EXECUTE+ , (0x2C, KeyPrint) -- Defined as VK_PRINT_SCREEN+ , (0x2D, KeyInsert)+ , (0x2E, KeyDelete)+ , (0x2F, KeyHelp)+ , (0x30, Key0)+ , (0x31, Key1)+ , (0x32, Key2)+ , (0x33, Key3)+ , (0x34, Key4)+ , (0x35, Key5)+ , (0x36, Key6)+ , (0x37, Key7)+ , (0x38, Key8)+ , (0x39, Key9)+ , (0x41, KeyA)+ , (0x42, KeyB)+ , (0x43, KeyC)+ , (0x44, KeyD)+ , (0x45, KeyE)+ , (0x46, KeyF)+ , (0x47, KeyG)+ , (0x48, KeyH)+ , (0x49, KeyI)+ , (0x4A, KeyJ)+ , (0x4B, KeyK)+ , (0x4C, KeyL)+ , (0x4D, KeyM)+ , (0x4E, KeyN)+ , (0x4F, KeyO)+ , (0x50, KeyP)+ , (0x51, KeyQ)+ , (0x52, KeyR)+ , (0x53, KeyS)+ , (0x54, KeyT)+ , (0x55, KeyU)+ , (0x56, KeyV)+ , (0x57, KeyW)+ , (0x58, KeyX)+ , (0x59, KeyY)+ , (0x5A, KeyZ)+ , (0x5B, KeyLeftMeta) -- Defined as Left Windows key (Natural Keyboard)+ , (0x5C, KeyRightMeta) -- Defined as Right Windows key (Natural Keyboard)+ , (0x5D, KeyCompose) -- Defined as Applications key (Natural Keyboard)+ , (0x5F, KeySleep)+ , (0x60, KeyKp0)+ , (0x61, KeyKp1)+ , (0x62, KeyKp2)+ , (0x63, KeyKp3)+ , (0x64, KeyKp4)+ , (0x65, KeyKp5)+ , (0x66, KeyKp6)+ , (0x67, KeyKp7)+ , (0x68, KeyKp8)+ , (0x69, KeyKp9)+ , (0x6A, KeyKpAsterisk)+ , (0x6B, KeyKpPlus)+ -- , (0x6C, KeyKpDot) -- Defined as VK_SEPARATOR+ , (0x6D, KeyKpMinus)+ , (0x6E, KeyKpDot)+ , (0x6F, KeyKpSlash)+ , (0x70, KeyF1)+ , (0x71, KeyF2)+ , (0x72, KeyF3)+ , (0x73, KeyF4)+ , (0x74, KeyF5)+ , (0x75, KeyF6)+ , (0x76, KeyF7)+ , (0x77, KeyF8)+ , (0x78, KeyF9)+ , (0x79, KeyF10)+ , (0x7A, KeyF11)+ , (0x7B, KeyF12)+ , (0x7C, KeyF13)+ , (0x7D, KeyF14)+ , (0x7E, KeyF15)+ , (0x7F, KeyF16)+ , (0x80, KeyF17)+ , (0x81, KeyF18)+ , (0x82, KeyF19)+ , (0x83, KeyF20)+ , (0x84, KeyF21)+ , (0x85, KeyF22)+ , (0x86, KeyF23)+ , (0x87, KeyF24)+ , (0x90, KeyNumLock)+ , (0x91, KeyScrollLock)+ , (0xA0, KeyLeftShift)+ , (0xA1, KeyRightShift)+ , (0xA2, KeyLeftCtrl)+ , (0xA3, KeyRightCtrl)+ , (0xA4, KeyLeftAlt)+ , (0xA5, KeyRightAlt)+ -- , (0xA6, ???) -- Defined as VK_BROWSER_BACK+ -- , (0xA7, ???) -- Defined as VK_BROWSER_FORWARD+ -- , (0xA8, ???) -- Defined as VK_BROWSER_REFRESH+ -- , (0xA9, ???) -- Defined as VK_BROWSER_STOP+ -- , (0xAA, ???) -- Defined as VK_BROWSER_SEARCH+ -- , (0xAB, ???) -- Defined as VK_BROWSER_FAVORITES+ -- , (0xAC, ???) -- Defined as VK_BROWSER_HOME+ , (0xAD, KeyMute)+ , (0xAE, KeyVolumeDown)+ , (0xAF, KeyVolumeUp)+ , (0xB0, KeyNextSong)+ , (0xB1, KeyPreviousSong)+ , (0xB2, KeyStopCd)+ , (0xB3, KeyPlayPause)+ , (0xB4, KeyMail)+ , (0xB5, KeyMedia)+ -- , (0xB6, ???) -- Defined as VK_LAUNCH_APP1+ -- , (0xB7, ???) -- Defined as VK_LAUNCH_APP2+ , (0xBA, KeySemicolon) -- Defined as VK_OEM_1+ , (0xBB, KeyEqual) -- Defined as VK_OEM_PLUS+ , (0xBC, KeyComma) -- Defined as VK_OEM_COMMA+ , (0xBD, KeyMinus) -- Defined as VK_OEM_MINUS+ , (0xBE, KeyDot) -- Defined as VK_OEM_PERIOD+ , (0xBF, KeySlash) -- Defined as VK_OEM_2+ , (0xC0, KeyGrave) -- Defined as VK_OEM_3+ , (0xDB, KeyLeftBrace) -- Defined as VK_OEM_4+ , (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+ -- , (0xE1, ???) -- Defined as `OEM specific`+ , (0xE2, Key102nd)+ -- , (0xE3, ???) -- Defined as `OEM specific`+ -- , (0xE4, ???) -- Defined as `OEM specific`+ -- , (0xE5, ???) -- Defined as OEM PROCESS key+ -- , (0xE6, ???) -- Defined as `OEM specific`+ -- , (0xE7, ???) -- Defined as VK_PACKET+ -- , (0xE9, ???) -- Defined as `OEM specific`+ -- , (0xEA, ???) -- Defined as `OEM specific`+ -- , (0xEB, ???) -- Defined as `OEM specific`+ -- , (0xEC, ???) -- Defined as `OEM specific`+ -- , (0xED, ???) -- Defined as `OEM specific`+ -- , (0xEE, ???) -- Defined as `OEM specific`+ -- , (0xEF, ???) -- Defined as `OEM specific`+ -- , (0xF0, ???) -- Defined as `OEM specific`+ -- , (0xF1, ???) -- Defined as `OEM specific`+ -- , (0xF2, ???) -- Defined as `OEM specific`+ -- , (0xF3, ???) -- Defined as `OEM specific`+ -- , (0xF4, ???) -- Defined as `OEM specific`+ -- , (0xF5, ???) -- Defined as `OEM specific`+ -- , (0xF6, ???) -- Defined as VK_ATTN+ -- , (0xF7, ???) -- Defined as VK_CRSEL+ -- , (0xF8, ???) -- Defined as VK_EXSEL+ -- , (0xF9, ???) -- Defined as VK_EREOF+ , (0xFA, KeyPlay)+ -- , (0xFB, ???) -- Defined as VK_ZOOM+ -- , (0xFC, ???) -- Defined as VK_NONAME+ -- , (0xFD, ???) -- Defined as VK_PA1+ -- , (0xFE, ???) -- Defined as VK_CLEAR+ ]+
+ src/KMonad/Keyboard/Keycode.hs view
@@ -0,0 +1,412 @@+{-# LANGUAGE DeriveAnyClass, CPP #-}+{-|+Module : KMonad.Keyboard.Keycode+Description : Description of all possible keycodes.+Copyright : (c) David Janssen, 2019+License : MIT+Maintainer : janssen.dhj@gmail.com+Stability : experimental+Portability : portable++'Keycode's are represented as a large enum lining up the keycodes defined in the Linux headers.++-}+module KMonad.Keyboard.Keycode+ ( -- * The core Keycode type+ -- $typ+ Keycode(..)++ -- * Naming utilities to refer to Keycodes+ -- $names+ , keyNames++ )+where++import KMonad.Prelude++import qualified Data.MultiMap as Q+import qualified RIO.HashSet as S+import qualified RIO.Text as T+import qualified RIO.Text.Partial as T (head)++--------------------------------------------------------------------------------+-- $typ+--+-- 'Keycode's are defined as a large ADT that mimics the keycodes from the Linux+-- headers:+-- https://github.com/torvalds/linux/blob/master/include/uapi/linux/input-event-codes.h.+--+-- Anywhere there are missing regions in the linux headers, we've defined+-- @MissingXX@ values for the ADT.+--+-- Calling 'RIO.Partial.toEnum' on a Linux keycode value should produce the+-- corresponding 'Keycode' value and vice-versa.++-- | The 'Keycode' datatype, as an 'Enum' of all the values a 'Keycode' can take.+data Keycode+ = KeyReserved+ | KeyEsc+ | Key1+ | Key2+ | Key3+ | Key4+ | Key5+ | Key6+ | Key7+ | Key8+ | Key9+ | Key0+ | KeyMinus+ | KeyEqual+ | KeyBackspace+ | KeyTab+ | KeyQ+ | KeyW+ | KeyE+ | KeyR+ | KeyT+ | KeyY+ | KeyU+ | KeyI+ | KeyO+ | KeyP+ | KeyLeftBrace+ | KeyRightBrace+ | KeyEnter+ | KeyLeftCtrl+ | KeyA+ | KeyS+ | KeyD+ | KeyF+ | KeyG+ | KeyH+ | KeyJ+ | KeyK+ | KeyL+ | KeySemicolon+ | KeyApostrophe+ | KeyGrave+ | KeyLeftShift+ | KeyBackslash+ | KeyZ+ | KeyX+ | KeyC+ | KeyV+ | KeyB+ | KeyN+ | KeyM+ | KeyComma+ | KeyDot+ | KeySlash+ | KeyRightShift+ | KeyKpAsterisk+ | KeyLeftAlt+ | KeySpace+ | KeyCapsLock+ | KeyF1+ | KeyF2+ | KeyF3+ | KeyF4+ | KeyF5+ | KeyF6+ | KeyF7+ | KeyF8+ | KeyF9+ | KeyF10+ | KeyNumLock+ | KeyScrollLock+ | KeyKp7+ | KeyKp8+ | KeyKp9+ | KeyKpMinus+ | KeyKp4+ | KeyKp5+ | KeyKp6+ | KeyKpPlus+ | KeyKp1+ | KeyKp2+ | KeyKp3+ | KeyKp0+ | KeyKpDot+ | Missing84+ | KeyZenkakuHankaku+ | Key102nd+ | KeyF11+ | KeyF12+ | KeyRo+ | KeyKatakana+ | KeyHiragana+ | KeyHenkan+ | KeyKatakanaHiragana+ | KeyMuhenkan+ | KeyKpjpcomma+ | KeyKpEnter+ | KeyRightCtrl+ | KeyKpSlash+ | KeySysRq+ | KeyRightAlt+ | KeyLinefeed+ | KeyHome+ | KeyUp+ | KeyPageUp+ | KeyLeft+ | KeyRight+ | KeyEnd+ | KeyDown+ | KeyPageDown+ | KeyInsert+ | KeyDelete+ | KeyMacro+ | KeyMute+ | KeyVolumeDown+ | KeyVolumeUp+ | KeyPower+ | KeyKpEqual+ | KeyKpPlusMinus+ | KeyPause+ | KeyScale+ | KeyKpComma+ | KeyHangeul+ | KeyHanja+ | KeyYen+ | KeyLeftMeta+ | KeyRightMeta+ | KeyCompose+ | KeyStop+ | KeyAgain+ | KeyProps+ | KeyUndo+ | KeyFront+ | KeyCopy+ | KeyOpen+ | KeyPaste+ | KeyFind+ | KeyCut+ | KeyHelp+ | KeyMenu+ | KeyCalc+ | KeySetup+ | KeySleep+ | KeyWakeUp+ | KeyFile+ | KeySendFile+ | KeyDeleteFile+ | KeyXfer+ | KeyProg1+ | KeyProg2+ | KeyWww+ | KeyMsDos+ | KeyCoffee+ | KeyDirection+ | KeyCycleWindows+ | KeyMail+ | KeyBookmarks+ | KeyComputer+ | KeyBack+ | KeyForward+ | KeyCloseCd+ | KeyEjectCd+ | KeyEjectCloseCd+ | KeyNextSong+ | KeyPlayPause+ | KeyPreviousSong+ | KeyStopCd+ | KeyRecord+ | KeyRewind+ | KeyPhone+ | KeyIso+ | KeyConfig+ | KeyHomepage+ | KeyRefresh+ | KeyExit+ | KeyMove+ | KeyEdit+ | KeyScrollUp+ | KeyScrollDown+ | KeyKpLeftParen+ | KeyKpRightParen+ | KeyNew+ | KeyRedo+ | KeyF13+ | KeyF14+ | KeyF15+ | KeyF16+ | KeyF17+ | KeyF18+ | KeyF19+ | KeyF20+ | KeyF21+ | KeyF22+ | KeyF23+ | KeyF24+ | Missing195+ | Missing196+ | Missing197+ | Missing198+ | Missing199+ | KeyPlayCd+ | KeyPauseCd+ | KeyProg3+ | KeyProg4+ | KeyDashboard+ | KeySuspend+ | KeyClose+ | KeyPlay+ | KeyFastForward+ | KeyBassBoost+ | KeyPrint+ | KeyHp+ | KeyCamera+ | KeySound+ | KeyQuestion+ | KeyEmail+ | KeyChat+ | KeySearch+ | KeyConnect+ | KeyFinance+ | KeySport+ | KeyShop+ | KeyAlterase+ | KeyCancel+ | KeyBrightnessDown+ | KeyBrightnessUp+ | KeyMedia+ | KeySwitchVideoMode+ | KeyKbdIllumToggle+ | KeyKbdIllumDown+ | KeyKbdIllumUp+ | KeySend+ | KeyReply+ | KeyForwardMail+ | KeySave+ | KeyDocuments+ | KeyBattery+ | KeyBluetooth+ | KeyWlan+ | KeyUwb+ | KeyUnknown+ | KeyVideoNext+ | KeyVideoPrev+ | KeyBrightnessCycle+ | KeyBrightnessZero+ | KeyDisplayOff+ | KeyWimax+ | Missing247+ | Missing248+ | Missing249+ | Missing250+ | Missing251+ | Missing252+ | Missing253+ | Missing254+ | Missing255+#ifdef darwin_HOST_OS+ | KeyFn+ | KeyLaunchpad+ | KeyMissionCtrl+ | KeyBacklightDown+ | KeyBacklightUp+ | KeyError+#endif+ deriving (Eq, Show, Bounded, Enum, Ord, Generic, Hashable)+++instance Display Keycode where+ textDisplay c = (\t -> "<" <> t <> ">") . fromMaybe (tshow c)+ $ minimumByOf (_Just . folded) cmpName (keyNames ^. at c)+ where cmpName a b =+ -- Prefer the shortest, and if equal, lowercased version+ case compare (T.length a) (T.length b) of+ EQ -> compare (T.head b) (T.head a)+ o -> o++--------------------------------------------------------------------------------+-- $sets++-- | The set of all existing 'Keycode'+kcAll :: S.HashSet Keycode+kcAll = S.fromList $ [minBound .. maxBound]++-- | The set of all 'Keycode' that are not of the MissingXX pattern+kcNotMissing :: S.HashSet Keycode+kcNotMissing = S.fromList $ kcAll ^.. folded . filtered (T.isPrefixOf "Key" . tshow)++--------------------------------------------------------------------------------+-- $names++-- | Helper function to generate easy name maps+nameKC :: Foldable t+ => (Keycode -> Text)+ -> t Keycode+ -> Q.MultiMap Keycode Text+nameKC f = Q.mkMultiMap . map go . toList+ where go k = (k, [f k, T.toLower $ f k])++-- | A collection of 'Keycode' to 'Text' mappings+keyNames :: Q.MultiMap Keycode Text+keyNames = mconcat+ [ nameKC tshow kcAll+ , nameKC (T.drop 3 . tshow) kcNotMissing+ , aliases+ ]++-- | A collection of useful aliases to refer to keycode names+aliases :: Q.MultiMap Keycode Text+aliases = Q.mkMultiMap+ [ (KeyEnter, ["ret", "return", "ent"])+ , (KeyMinus, ["min", "-"])+ , (KeyEqual, ["eql", "="])+ , (KeySleep, ["zzz"])+ , (KeySpace, ["spc"])+ , (KeyPageUp, ["pgup"])+ , (KeyPageDown, ["pgdn"])+ , (KeyInsert, ["ins"])+ , (KeyDelete, ["del"])+ , (KeyVolumeUp, ["volu"])+ , (KeyVolumeDown, ["voldwn", "vold"])+ , (KeyBrightnessUp, ["brup", "bru"])+ , (KeyBrightnessDown, ["brdown", "brdwn", "brdn"])+ , (KeyLeftAlt, ["lalt", "alt"])+ , (KeyRightAlt, ["ralt"])+ , (KeyCompose, ["comp", "cmps", "cmp"])+ , (KeyLeftShift, ["lshift", "lshft", "lsft", "shft", "sft"])+ , (KeyRightShift, ["rshift", "rshft", "rsft"])+ , (KeyLeftCtrl, ["lctrl", "lctl", "ctl"])+ , (KeyRightCtrl, ["rctrl", "rctl"])+ , (KeyLeftMeta, ["lmeta", "lmet", "met"])+ , (KeyRightMeta, ["rmeta", "rmet"])+ , (KeyBackspace, ["bks", "bspc"])+ , (KeyCapsLock, ["caps"])+ , (KeyGrave, ["grv"])+ , (Key102nd, ["102d"])+ , (KeyForward, ["fwd"])+ , (KeyScrollLock, ["scrlck", "slck"])+ , (KeyPrint, ["prnt"])+ , (KeyWakeUp, ["wkup"])+ , (KeyLeft, ["lft"])+ , (KeyRight, ["rght"])+ , (KeyLeftBrace, ["lbrc", "["])+ , (KeyRightBrace, ["rbrc", "]"])+ , (KeySemicolon, ["scln", ";"])+ , (KeyApostrophe, ["apos", "'"])+ , (KeyGrave, ["grv", "`"])+ , (KeyBackslash, ["bksl", "\\"]) -- NOTE: "\\" here is a 1char string, the first \ is consumed by Haskell as an escape character+ , (KeyComma, ["comm", ","])+ , (KeyDot, ["."])+ , (KeySlash, ["/"])+ , (KeyNumLock, ["nlck"])+ , (KeyKpSlash, ["kp/"])+ , (KeyKpEnter, ["kprt"])+ , (KeyKpPlus, ["kp+"])+ , (KeyKpAsterisk, ["kp*"])+ , (KeyKpMinus, ["kp-"])+ , (KeyKpDot, ["kp."])+ , (KeySysRq, ["ssrq", "sys"])+#ifdef darwin_HOST_OS+ , (KeyLaunchpad, ["lp"])+ , (KeyMissionCtrl, ["mctl"])+ , (KeyBacklightDown, ["bldn"])+ , (KeyBacklightUp, ["blup"])+#endif+ ]
+ src/KMonad/Prelude.hs view
@@ -0,0 +1,37 @@+{-# OPTIONS_GHC -Wno-dodgy-imports #-}+{-|+Module : KMonad.Prelude+Description : Code that will be imported into every module+Copyright : (c) David Janssen, 2019+License : MIT++Maintainer : janssen.dhj@gmail.com+Stability : experimental+Portability : non-portable (MPTC with FD, FFI to Linux-only c-code)+-}++module KMonad.Prelude+ ( module X )+where++import Control.Lens as X+import Control.Monad.Cont as X+import Data.Acquire as X+import GHC.Conc as X (orElse)+import RIO.Text as X (unlines, lines)++import RIO as X hiding+ (-- Not the lens stuff, I want more support for lenses from "Control.Lens"+ view, ASetter, ASetter', Lens, Getting, Lens'+ , SimpleGetter, lens, over, set, sets, to, (^.)++ -- The following line is required for newer stack releases.+ -- This is also the reason for the OPTIONS_GHC pragma+ , (^..), (^?), preview, (%~), (.~)++ -- Some stuff I'd rather default to Text+ , unlines, lines++ -- Will import these when I need it+ , some, many+ )
+ src/KMonad/Util.hs view
@@ -0,0 +1,127 @@+{-|+Module : KMonad.Util+Description : Various bits and bobs that I don't know where to put+Copyright : (c) David Janssen, 2019+License : MIT+Maintainer : janssen.dhj@gmail.com+Stability : experimental+Portability : portable++Contains code for making it slighly easier to work with time, errors, and+Acquire datatypes.++-}+module KMonad.Util+ ( -- * Time units and utils+ -- $time+ Milliseconds+ , tDiff++ -- * Random utility helpers that have no better home+ , onErr+ , using+ , logRethrow++ -- * Some helpers to launch background process+ , withLaunch+ , withLaunch_+ , launch+ , launch_+ )++where++import KMonad.Prelude++import Data.Time.Clock+import Data.Time.Clock.System++--------------------------------------------------------------------------------+-- $time+--++-- | Newtype wrapper around 'Int' to add type safety to our time values+newtype Milliseconds = Milliseconds Int+ deriving (Eq, Ord, Num, Real, Enum, Integral, Show, Read, Generic, Display)++-- | Calculate how much time has elapsed between 2 time points+tDiff :: ()+ => SystemTime -- ^ The earlier timepoint+ -> SystemTime -- ^ The later timepoint+ -> Milliseconds -- ^ The time in milliseconds between the two+tDiff a b = let+ a' = systemToUTCTime a+ b' = systemToUTCTime b+ d = diffUTCTime b' a'+ in round $ d * 1000+-- tDiff (MkSystemTime s_a ns_a) (MkSystemTime s_b ns_b) = let+ -- s = fromIntegral $ (s_b - s_a) * 1000+ -- ns = fromIntegral $ (ns_b - ns_a) `div` 1000000+ -- in s + ns++--------------------------------------------------------------------------------+-- $util++-- | A helper function that helps to throw errors when a return code is -1.+-- Easiest when used as infix like this:+--+-- > someFFIcall `onErr` MyCallFailedError someData+--+onErr :: (MonadUnliftIO m, Exception e) => m Int -> e -> m ()+onErr a err = a >>= \ret -> when (ret == -1) $ throwIO err++-- | 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)+++-- | Log an error message and then rethrow the error+--+-- Particularly useful as a suffix using `catch`. i.e.+--+-- > doSomething `catch` logRethrow "I caught something"+logRethrow :: HasLogFunc e+ => Text+ -> SomeException -- ^ The error to throw+ -> RIO e a+logRethrow t e = do+ logError $ display t <> ": " <> display e+ throwIO e++-- | Launch a process that repeats an action indefinitely. If an error ever+-- occurs, print it and rethrow it. Ensure the process is cleaned up upon error+-- and/or shutdown.+withLaunch :: HasLogFunc e+ => Text -- ^ The name of this process (for logging)+ -> RIO e a -- ^ The action to repeat forever+ -> ((Async a) -> RIO e b) -- ^ The foreground action to run+ -> RIO e b -- ^ The resulting action+withLaunch n a f = do+ logInfo $ "Launching process: " <> display n+ withAsync+ (forever a+ `catch` logRethrow ("Encountered error in <" <> textDisplay n <> ">")+ `finally` logInfo ("Closing process: " <> display n))+ (\a' -> link a' >> f a')++-- | Like withLaunch, but without ever needing access to the async process+withLaunch_ :: HasLogFunc e+ => Text -- ^ The name of this process (for logging)+ -> RIO e a -- ^ The action to repeat forever+ -> RIO e b -- ^ The foreground action to run+ -> RIO e b -- ^ The resulting action+withLaunch_ n a f = withLaunch n a (const f)++-- | Like 'withLaunch', but in the ContT monad+launch :: HasLogFunc e+ => Text -- ^ The name of this process (for logging)+ -> RIO e a -- ^ The action to repeat forever+ -> ContT r (RIO e) (Async a)+launch n = ContT . withLaunch n++-- | Like 'withLaunch_', but in the ContT monad+launch_ :: HasLogFunc e+ => Text -- ^ The name of this process (for logging)+ -> RIO e a -- ^ The action to repeat forever+ -> ContT r (RIO e) ()+launch_ n a = ContT $ \next -> withLaunch_ n a (next ())