diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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 diff --git a/c_src/keyio.c b/c_src/keyio.c new file mode 100644 --- /dev/null +++ b/c_src/keyio.c @@ -0,0 +1,76 @@ +#include +#include +#include +#include +#include +#include +#include +#include + +// 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)); +} + diff --git a/c_src/keyio_win.c b/c_src/keyio_win.c new file mode 100644 --- /dev/null +++ b/c_src/keyio_win.c @@ -0,0 +1,266 @@ +// Necessary to get mingw to compile for some reason +/* #define WINVER 0x0601 */ +/* #define _WIN32_WINNT 0x0601 */ + +#include +#include +#include + + +// 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) +{ + + */ diff --git a/c_src/mac/keyio_mac.cpp b/c_src/mac/keyio_mac.cpp new file mode 100644 --- /dev/null +++ b/c_src/mac/keyio_mac.cpp @@ -0,0 +1,354 @@ +#include +#include +#include +#include +#include +#include +#include + +#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 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 +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 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; +} diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -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. diff --git a/kmonad.cabal b/kmonad.cabal new file mode 100644 --- /dev/null +++ b/kmonad.cabal @@ -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 diff --git a/src/Data/LayerStack.hs b/src/Data/LayerStack.hs new file mode 100644 --- /dev/null +++ b/src/Data/LayerStack.hs @@ -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 diff --git a/src/Data/MultiMap.hs b/src/Data/MultiMap.hs new file mode 100644 --- /dev/null +++ b/src/Data/MultiMap.hs @@ -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 (:[])) diff --git a/src/KMonad/Action.hs b/src/KMonad/Action.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/Action.hs @@ -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) diff --git a/src/KMonad/App.hs b/src/KMonad/App.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/App.hs @@ -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) diff --git a/src/KMonad/App/BEnv.hs b/src/KMonad/App/BEnv.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/App/BEnv.hs @@ -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) diff --git a/src/KMonad/App/Dispatch.hs b/src/KMonad/App/Dispatch.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/App/Dispatch.hs @@ -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) diff --git a/src/KMonad/App/Hooks.hs b/src/KMonad/App/Hooks.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/App/Hooks.hs @@ -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 diff --git a/src/KMonad/App/Keymap.hs b/src/KMonad/App/Keymap.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/App/Keymap.hs @@ -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 diff --git a/src/KMonad/App/Sluice.hs b/src/KMonad/App/Sluice.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/App/Sluice.hs @@ -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 diff --git a/src/KMonad/Args.hs b/src/KMonad/Args.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/Args.hs @@ -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 + } diff --git a/src/KMonad/Args/Cmd.hs b/src/KMonad/Args/Cmd.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/Args/Cmd.hs @@ -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) ] + diff --git a/src/KMonad/Args/Joiner.hs b/src/KMonad/Args/Joiner.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/Args/Joiner.hs @@ -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 diff --git a/src/KMonad/Args/Parser.hs b/src/KMonad/Args/Parser.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/Args/Parser.hs @@ -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) + diff --git a/src/KMonad/Args/Types.hs b/src/KMonad/Args/Types.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/Args/Types.hs @@ -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 diff --git a/src/KMonad/Button.hs b/src/KMonad/Button.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/Button.hs @@ -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-. +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) + + diff --git a/src/KMonad/Keyboard.hs b/src/KMonad/Keyboard.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/Keyboard.hs @@ -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 diff --git a/src/KMonad/Keyboard/ComposeSeq.hs b/src/KMonad/Keyboard/ComposeSeq.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/Keyboard/ComposeSeq.hs @@ -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") + ] + diff --git a/src/KMonad/Keyboard/IO.hs b/src/KMonad/Keyboard/IO.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/Keyboard/IO.hs @@ -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 diff --git a/src/KMonad/Keyboard/IO/Linux/DeviceSource.hs b/src/KMonad/Keyboard/IO/Linux/DeviceSource.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/Keyboard/IO/Linux/DeviceSource.hs @@ -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 diff --git a/src/KMonad/Keyboard/IO/Linux/Types.hs b/src/KMonad/Keyboard/IO/Linux/Types.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/Keyboard/IO/Linux/Types.hs @@ -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 diff --git a/src/KMonad/Keyboard/IO/Linux/UinputSink.hs b/src/KMonad/Keyboard/IO/Linux/UinputSink.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/Keyboard/IO/Linux/UinputSink.hs @@ -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 diff --git a/src/KMonad/Keyboard/IO/Mac/IOKitSource.hs b/src/KMonad/Keyboard/IO/Mac/IOKitSource.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/Keyboard/IO/Mac/IOKitSource.hs @@ -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 diff --git a/src/KMonad/Keyboard/IO/Mac/KextSink.hs b/src/KMonad/Keyboard/IO/Mac/KextSink.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/Keyboard/IO/Mac/KextSink.hs @@ -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 diff --git a/src/KMonad/Keyboard/IO/Mac/Types.hs b/src/KMonad/Keyboard/IO/Mac/Types.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/Keyboard/IO/Mac/Types.hs @@ -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) + ] diff --git a/src/KMonad/Keyboard/IO/Windows/LowLevelHookSource.hs b/src/KMonad/Keyboard/IO/Windows/LowLevelHookSource.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/Keyboard/IO/Windows/LowLevelHookSource.hs @@ -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 diff --git a/src/KMonad/Keyboard/IO/Windows/SendEventSink.hs b/src/KMonad/Keyboard/IO/Windows/SendEventSink.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/Keyboard/IO/Windows/SendEventSink.hs @@ -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 diff --git a/src/KMonad/Keyboard/IO/Windows/Types.hs b/src/KMonad/Keyboard/IO/Windows/Types.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/Keyboard/IO/Windows/Types.hs @@ -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 + ] + diff --git a/src/KMonad/Keyboard/Keycode.hs b/src/KMonad/Keyboard/Keycode.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/Keyboard/Keycode.hs @@ -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 + ] diff --git a/src/KMonad/Prelude.hs b/src/KMonad/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/Prelude.hs @@ -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 + ) diff --git a/src/KMonad/Util.hs b/src/KMonad/Util.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/Util.hs @@ -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 ())