diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -15,7 +15,7 @@ ) where -import KMonad.Args (run) +import qualified KMonad.App as KMonad (main) main :: IO () -main = run +main = KMonad.main diff --git a/c_src/mac/dext.cpp b/c_src/mac/dext.cpp new file mode 100644 --- /dev/null +++ b/c_src/mac/dext.cpp @@ -0,0 +1,96 @@ +#include "keyio_mac.hpp" + +#include "virtual_hid_device_driver.hpp" +#include "virtual_hid_device_service.hpp" + +/* + * 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 pqrs::karabiner::driverkit::virtual_hid_device_service::client *client; +static pqrs::karabiner::driverkit::virtual_hid_device_driver::hid_report::keyboard_input keyboard; +static pqrs::karabiner::driverkit::virtual_hid_device_driver::hid_report::apple_vendor_top_case_input top_case; +static pqrs::karabiner::driverkit::virtual_hid_device_driver::hid_report::apple_vendor_keyboard_input apple_keyboard; +static pqrs::karabiner::driverkit::virtual_hid_device_driver::hid_report::consumer_input consumer; + +int init_sink() { + pqrs::dispatcher::extra::initialize_shared_dispatcher(); + std::filesystem::path client_socket_file_path("/tmp/karabiner_driverkit_virtual_hid_device_service_client.sock"); + client = new pqrs::karabiner::driverkit::virtual_hid_device_service::client(client_socket_file_path); + auto copy = client; + client->async_driver_loaded(); + client->async_driver_version_matched(); + client->async_virtual_hid_keyboard_ready(); + client->async_virtual_hid_pointing_ready(); + /**/ + client->connected.connect([copy] { + std::cout << "connected" << std::endl; + copy->async_virtual_hid_keyboard_initialize(pqrs::hid::country_code::us); + }); + client->connect_failed.connect([](auto&& error_code) { + std::cout << "connect_failed " << error_code << std::endl; + }); + client->closed.connect([] { + std::cout << "closed" << std::endl; + }); + client->error_occurred.connect([](auto&& error_code) { + std::cout << "error_occurred " << error_code << std::endl; + }); + client->driver_loaded_response.connect([](auto&& driver_loaded) { + static std::optional previous_value; + + if (previous_value != driver_loaded) { + std::cout << "driver_loaded " << driver_loaded << std::endl; + previous_value = driver_loaded; + } + }); + client->driver_version_matched_response.connect([](auto&& driver_version_matched) { + static std::optional previous_value; + if (previous_value != driver_version_matched) { + std::cout << "driver_version_matched " << driver_version_matched << std::endl; + previous_value = driver_version_matched; + } + }); + /**/ + client->async_start(); + return 0; +} + +int exit_sink() { + free(client); + pqrs::dispatcher::extra::terminate_shared_dispatcher(); + return 0; +} + +/* + * This gets us some code reuse (see the send_key overload below) + */ +template +int send_key(T &keyboard, struct KeyEvent *e) { + if(e->type == 1) keyboard.keys.insert(e->usage); + else if(e->type == 0) keyboard.keys.erase(e->usage); + else return 1; + client->async_post_report(keyboard); + return 0; +} + + +/* + * 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) { + auto usage_page = pqrs::hid::usage_page::value_t(e->page); + if(usage_page == pqrs::hid::usage_page::keyboard_or_keypad) + return send_key(keyboard, e); + else if(usage_page == pqrs::hid::usage_page::apple_vendor_top_case) + return send_key(top_case, e); + else if(usage_page == pqrs::hid::usage_page::apple_vendor_keyboard) + return send_key(apple_keyboard, e); + else if(usage_page == pqrs::hid::usage_page::consumer) + return send_key(consumer, e); + else + return 1; +} diff --git a/c_src/mac/kext.cpp b/c_src/mac/kext.cpp new file mode 100644 --- /dev/null +++ b/c_src/mac/kext.cpp @@ -0,0 +1,117 @@ +#include "keyio_mac.hpp" + +#include "karabiner_virtual_hid_device_methods.hpp" + +/* + * 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; + +int exit_sink() { + int retval = 0; + kern_return_t kr = pqrs::karabiner_virtual_hid_device_methods::reset_virtual_hid_keyboard(connect); + if (kr != KERN_SUCCESS) { + print_iokit_error("reset_virtual_hid_keyboard", kr); + retval = 1; + } + if (connect) { + kr = IOServiceClose(connect); + if(kr != KERN_SUCCESS) { + print_iokit_error("IOServiceClose", kr); + retval = 1; + } + } + if (service) { + kr = IOObjectRelease(service); + if(kr != KERN_SUCCESS) { + print_iokit_error("IOObjectRelease", kr); + retval = 1; + } + } + return retval; +} + +int init_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) { + print_iokit_error("IOServiceGetMatchingService"); + return 1; + } + kr = IOServiceOpen(service, mach_task_self(), kIOHIDServerConnectType, &connect); + if (kr != KERN_SUCCESS) { + print_iokit_error("IOServiceOpen", kr); + 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) { + print_iokit_error("initialize_virtual_hid_keyboard", kr); + return 1; + } + while (true) { + bool ready; + kr = pqrs::karabiner_virtual_hid_device_methods::is_virtual_hid_keyboard_ready(connect, ready); + if (kr != KERN_SUCCESS) { + print_iokit_error("is_virtual_hid_keyboard_ready", kr); + 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) { + print_iokit_error("initialize_virtual_hid_keyboard", kr); + return kr; + } + } + return 0; +} + +/* + * This gets us some code reuse (see the send_key overload below) + */ +template +int send_key(T &keyboard, struct KeyEvent *e) { + if(e->type == 1) keyboard.keys.insert(e->usage); + else if(e->type == 0) keyboard.keys.erase(e->usage); + else return 1; + 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) { + auto usage_page = pqrs::karabiner_virtual_hid_device::usage_page(e->page); + 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; +} diff --git a/c_src/mac/keyio_mac.cpp b/c_src/mac/keyio_mac.cpp deleted file mode 100644 --- a/c_src/mac/keyio_mac.cpp +++ /dev/null @@ -1,354 +0,0 @@ -#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 --- a/changelog.md +++ b/changelog.md @@ -1,9 +1,50 @@ # 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] +## Unreleased -## [0.4.1] - 2020-09-12 +### Added + +### Changed + +### Fixed + +## 0.4.2 – 2023-10-07 + +### Added + +- Added `around-next-single`, a variant of `around-next` that will release its + context on any change, as opposed to only on the release of the 'arounded' + button. +- Added default compose sequence for Ü +- Added systemd user unit +- Added runit startup script +- Added short delay in startup +- Added macOS 11.0 support +- Added a `sticky-key` +- Expanded documentation +- Added `--version` (`-V`) flag +- Added `+,` for "add a cedilla" +- Added `:timeout-button` keyword to `tap-hold-next` and + `tap-hold-next-release`, so that they can switch to a button other than the + hold button when the timeout expires. +- Added openrc startup script + +### Changed + +- Reorganized codebase +- The `multi-tap` key now immediately taps the current key when another + key is pressed during tapping. + +### Fixed + +- Fixed compilation error under Mac, having to do with typo in Keycodes +- Fixed issue with empty-names for uinput-sinks +- Ignore SIGCHLD to deal with non-termination bug + +## 0.4.1 - 2020-09-12 + - First release where we start tracking changes. diff --git a/kmonad.cabal b/kmonad.cabal --- a/kmonad.cabal +++ b/kmonad.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: kmonad -version: 0.4.1 +version: 0.4.2 license: MIT license-file: LICENSE maintainer: janssen.dhj@gmail.com @@ -17,31 +17,51 @@ build-type: Simple extra-source-files: changelog.md +flag kext + description: build against the kext [macOS only] + default: False + +flag dext + description: build against the dext [macOS only] + default: False + 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.App.Main + KMonad.App.Types KMonad.Args KMonad.Args.Cmd KMonad.Args.Parser KMonad.Args.Joiner + KMonad.Args.TH KMonad.Args.Types - KMonad.Button + KMonad.Model + KMonad.Model.Action + KMonad.Model.BEnv + KMonad.Model.Button + KMonad.Model.Dispatch + KMonad.Model.Hooks + KMonad.Model.Keymap + KMonad.Model.Sluice + KMonad.Gesture KMonad.Keyboard - KMonad.Keyboard.Keycode KMonad.Keyboard.ComposeSeq KMonad.Keyboard.IO + KMonad.Keyboard.Keycode + KMonad.Keyboard.Ops + KMonad.Keyboard.Types + KMonad.Parsing KMonad.Prelude + KMonad.Prelude.Imports + KMonad.Prelude.Definitions KMonad.Util + KMonad.Util.LayerStack + KMonad.Util.MultiMap + Paths_kmonad hs-source-dirs: src + autogen-modules: Paths_kmonad default-language: Haskell2010 default-extensions: ConstraintKinds DeriveFunctor DeriveGeneric DeriveTraversable @@ -52,16 +72,17 @@ 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 + base <4.18, + cereal <0.6, + lens <5.3, + megaparsec <9.4, + mtl <2.3, + optparse-applicative <0.18, + resourcet <1.3, + rio <0.2, + time <1.13, + unliftio <0.3, + template-haskell <2.20 if os(linux) exposed-modules: @@ -70,7 +91,7 @@ KMonad.Keyboard.IO.Linux.UinputSink c-sources: c_src/keyio.c - build-depends: unix >=2.7.2.2 && <2.8 + build-depends: unix <2.8 if os(windows) exposed-modules: @@ -79,7 +100,7 @@ KMonad.Keyboard.IO.Windows.Types c-sources: c_src/keyio_win.c - build-depends: Win32 >=2.6.1.0 && <2.7 + build-depends: Win32 if os(osx) exposed-modules: @@ -87,17 +108,43 @@ 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 + build-depends: unix <2.8 + if flag(kext) + cxx-options: -std=c++14 + cxx-sources: c_src/mac/kext.cpp + + if flag(dext) + cxx-options: -std=c++2a + cxx-sources: c_src/mac/dext.cpp + 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 + base <4.18, + kmonad + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + build-tool-depends: hspec-discover:hspec-discover >=2 && <3 + hs-source-dirs: test + other-modules: KMonad.GestureSpec + 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 + build-depends: + base <4.18, + kmonad, + hspec <2.11 diff --git a/src/Data/LayerStack.hs b/src/Data/LayerStack.hs deleted file mode 100644 --- a/src/Data/LayerStack.hs +++ /dev/null @@ -1,155 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Data/MultiMap.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-| -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 deleted file mode 100644 --- a/src/KMonad/Action.hs +++ /dev/null @@ -1,243 +0,0 @@ -{-| -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 --- a/src/KMonad/App.hs +++ b/src/KMonad/App.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE CPP #-} {-| Module : KMonad.App Description : The central app-loop of KMonad @@ -10,238 +11,7 @@ -} module KMonad.App - ( AppCfg(..) - , HasAppCfg(..) - , startApp - ) + ( main ) 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) +import KMonad.App.Main ( main ) diff --git a/src/KMonad/App/BEnv.hs b/src/KMonad/App/BEnv.hs deleted file mode 100644 --- a/src/KMonad/App/BEnv.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-| -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 deleted file mode 100644 --- a/src/KMonad/App/Dispatch.hs +++ /dev/null @@ -1,114 +0,0 @@ -{-| -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 deleted file mode 100644 --- a/src/KMonad/App/Hooks.hs +++ /dev/null @@ -1,199 +0,0 @@ -{-| -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 deleted file mode 100644 --- a/src/KMonad/App/Keymap.hs +++ /dev/null @@ -1,121 +0,0 @@ -{-| -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/Main.hs b/src/KMonad/App/Main.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/App/Main.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE CPP #-} +{-| +Module : KMonad.App.Main +Description : The entry-point to KMonad +Copyright : (c) David Janssen, 2021 +License : MIT + +Maintainer : janssen.dhj@gmail.com +Stability : experimental +Portability : non-portable + +-} +module KMonad.App.Main + ( -- * The entry-point to KMonad + main + ) +where + +import KMonad.Prelude + +import KMonad.Args +import KMonad.App.Types +import KMonad.Keyboard +import KMonad.Util +import KMonad.Model + + + +import qualified KMonad.Model.Dispatch as Dp +import qualified KMonad.Model.Hooks as Hs +import qualified KMonad.Model.Sluice as Sl +import qualified KMonad.Model.Keymap as Km + +-- FIXME: This should live somewhere else + +#ifdef linux_HOST_OS +import System.Posix.Signals (Handler(Ignore), installHandler, sigCHLD) +#endif + +-------------------------------------------------------------------------------- +-- $start +-- +-- How to start KMonad + +-- | The first command in KMonad +-- +-- Get the invocation from the command-line, then do something with it. +main :: IO () +main = 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 + unless (c^.dryRun) $ startApp cfg + +-------------------------------------------------------------------------------- +-- $init +-- +-- The steps required to turn a configuration into the initial KMonad env + +-- | 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 + + -- Wait a bit for the user to release the 'Return' key with which they started KMonad + threadDelay $ fromIntegral (cfg^.startDelay) * 1000 + + -- 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 newEmptyTMVarIO + 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 + } + +-------------------------------------------------------------------------------- +-- $emit +-- +-- How to use a KMonad env to emit keys to the OS +-- +-- FIXME: this needs to live somewhere else + +-- | 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 + when ft $ do + emit $ mkPress c + await (isReleaseOf c) $ \_ -> do + emit $ mkRelease c + pure Catch + + -- 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 >>= \case + Nothing -> pure () + Just a -> runAction a + pure Catch + +-------------------------------------------------------------------------------- +-- $loop +-- +-- The app-loop of KMonad + +-- | 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 = do +#ifdef linux_HOST_OS + -- Ignore SIGCHLD to avoid zombie processes. + liftIO . void $ installHandler sigCHLD Ignore Nothing +#endif + runContT (initAppEnv c) (`runRIO` loop) diff --git a/src/KMonad/App/Sluice.hs b/src/KMonad/App/Sluice.hs deleted file mode 100644 --- a/src/KMonad/App/Sluice.hs +++ /dev/null @@ -1,119 +0,0 @@ -{-| -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/App/Types.hs b/src/KMonad/App/Types.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/App/Types.hs @@ -0,0 +1,149 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +module KMonad.App.Types + ( AppCfg(..) + , AppEnv(..) + , KEnv(..) + , HasAppCfg(..) + , HasAppEnv(..) + , HasKEnv(..) + ) +where + +import KMonad.Prelude + +import UnliftIO.Process (CreateProcess(close_fds), createProcess_, shell) + +import KMonad.Keyboard +import KMonad.Keyboard.IO +import KMonad.Model.Action +import KMonad.Model.Button +import KMonad.Model.BEnv +import KMonad.Util + +import qualified KMonad.Model.Dispatch as Dp +import qualified KMonad.Model.Hooks as Hs +import qualified KMonad.Model.Sluice as Sl +import qualified KMonad.Model.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 + , _startDelay :: Milliseconds -- ^ How long to wait before acquiring the input keyboard + } +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 + +-------------------------------------------------------------------------------- +-- $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) + +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 + spawnCommand . unpack $ t + else + logInfo $ "Received but not running: " <> display t + where + spawnCommand :: MonadIO m => String -> m () + spawnCommand cmd = void $ createProcess_ "spawnCommand" + (shell cmd){ -- We don't want the child process to inherit things like + -- our keyboard grab (this would, for example, make it + -- impossible for a command to restart kmonad). + close_fds = True + } diff --git a/src/KMonad/Args.hs b/src/KMonad/Args.hs --- a/src/KMonad/Args.hs +++ b/src/KMonad/Args.hs @@ -10,11 +10,11 @@ -} module KMonad.Args - ( run ) + ( getCmd, loadConfig, Cmd, HasCmd(..)) where import KMonad.Prelude -import KMonad.App +import KMonad.App.Types import KMonad.Args.Cmd import KMonad.Args.Joiner import KMonad.Args.Parser @@ -23,40 +23,60 @@ -------------------------------------------------------------------------------- -- --- | 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 +loadConfig :: HasLogFunc e => Cmd -> RIO e AppCfg +loadConfig cmd = do - tks <- loadTokens pth -- This can throw a PErrors - cgt <- joinConfigIO tks -- This can throw a JoinError + tks <- loadTokens (cmd^.cfgFile) -- This can throw a ParseError + cgt <- joinConfigIO (joinCLI cmd 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 + -- Emit the release of if requested + -- Assemble the AppCfg record pure $ AppCfg { _keySinkDev = snk , _keySourceDev = src - , _keymapCfg = _km cgt - , _firstLayer = _fstL cgt - , _fallThrough = _flt cgt - , _allowCmd = _allow cgt + , _keymapCfg = _km cgt + , _firstLayer = _fstL cgt + , _fallThrough = _flt cgt + , _allowCmd = _allow cgt + , _startDelay = _strtDel cmd } + + +-- | Join the options given from the command line with the one read from the +-- configuration file. +-- This does not yet throw any kind of exception, as we are simply inserting the +-- given options into every 'KDefCfg' block that we see. +joinCLI :: Cmd -> [KExpr] -> [KExpr] +joinCLI cmd = traverse._KDefCfg %~ insertCliOption cliList + where + -- | All options and flags that were given on the command line. + cliList :: DefSettings + cliList = catMaybes $ + map flagToMaybe [cmd^.cmdAllow, cmd^.fallThrgh] + <> [cmd^.iToken, cmd^.oToken, cmd^.cmpSeq, cmd^.initStr] + + -- | Convert command line flags to a 'Maybe' type, where the non-presence, as + -- well as the default value of a flag will be interpreted as @Nothing@ + flagToMaybe :: DefSetting -> Maybe DefSetting + flagToMaybe = \case + SAllowCmd b -> if b then Just (SAllowCmd b) else Nothing + SFallThrough b -> if b then Just (SFallThrough b) else Nothing + _ -> Nothing + + -- | Insert all command line options, potentially overwriting already existing + -- options that were given in the configuration file. This is a paramorphism + insertCliOption :: DefSettings -> DefSettings -> DefSettings + insertCliOption cliSettings cfgSettings = + foldr (\s cfgs -> + if s `elem` cfgs + then map (\x -> if s == x then s else x) cfgs + else s : cfgs) + cfgSettings + cliSettings diff --git a/src/KMonad/Args/Cmd.hs b/src/KMonad/Args/Cmd.hs --- a/src/KMonad/Args/Cmd.hs +++ b/src/KMonad/Args/Cmd.hs @@ -16,8 +16,16 @@ ) where -import KMonad.Prelude +import KMonad.Prelude hiding (try) +import KMonad.Args.Parser (itokens, keywordButtons, noKeywordButtons, otokens, symbol, numP) +import KMonad.Args.TH (gitHash) +import KMonad.Args.Types (DefSetting(..)) +import KMonad.Util +import Paths_kmonad (version) +import qualified KMonad.Parsing as M -- [M]egaparsec functionality + +import Data.Version (showVersion) import Options.Applicative @@ -28,21 +36,38 @@ -- | 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 + { _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 + , _strtDel :: Milliseconds -- ^ How long to wait before acquiring the input keyboard + + -- All 'KDefCfg' options of a 'KExpr' + , _cmdAllow :: DefSetting -- ^ Allow execution of arbitrary shell-commands? + , _fallThrgh :: DefSetting -- ^ Re-emit unhandled events? + , _initStr :: Maybe DefSetting -- ^ TODO: What does this do? + , _cmpSeq :: Maybe DefSetting -- ^ Key to use for compose-key sequences + , _oToken :: Maybe DefSetting -- ^ How to emit the output + , _iToken :: Maybe DefSetting -- ^ How to capture the input } 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." - ) +getCmd = customExecParser (prefs showHelpOnEmpty) $ + info (cmdP <**> versioner <**> helper) + ( fullDesc + <> progDesc "Start KMonad" + <> header "kmonad - an onion of buttons." + ) +-- | Equip a parser with version information about the program +versioner :: Parser (a -> a) +versioner = infoOption (showVersion version <> ", commit " <> $(gitHash)) + ( long "version" + <> short 'V' + <> help "Show version" + ) -------------------------------------------------------------------------------- -- $prs @@ -51,7 +76,17 @@ -- | Parse the full command cmdP :: Parser Cmd -cmdP = Cmd <$> fileP <*> dryrunP <*> levelP +cmdP = + Cmd <$> fileP + <*> dryrunP + <*> levelP + <*> startDelayP + <*> cmdAllowP + <*> fallThrghP + <*> initStrP + <*> cmpSeqP + <*> oTokenP + <*> iTokenP -- | Parse a filename that points us at the config-file fileP :: Parser FilePath @@ -67,6 +102,7 @@ <> 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 @@ -79,3 +115,73 @@ f = maybeReader $ flip lookup [ ("debug", LevelDebug), ("warn", LevelWarn) , ("info", LevelInfo), ("error", LevelError) ] +-- | Allow the execution of arbitrary shell-commands +cmdAllowP :: Parser DefSetting +cmdAllowP = SAllowCmd <$> switch + ( long "allow-cmd" + <> short 'c' + <> help "Whether to allow the execution of arbitrary shell-commands" + ) + +-- | Re-emit unhandled events +fallThrghP :: Parser DefSetting +fallThrghP = SFallThrough <$> switch + ( long "fallthrough" + <> short 'f' + <> help "Whether to simply re-emit unhandled events" + ) + +-- | TODO what does this do? +initStrP :: Parser (Maybe DefSetting) +initStrP = optional $ SInitStr <$> strOption + ( long "init" + <> short 't' + <> metavar "STRING" + <> help "TODO" + ) + +-- | Key to use for compose-key sequences +cmpSeqP :: Parser (Maybe DefSetting) +cmpSeqP = optional $ SCmpSeq <$> option + (tokenParser keywordButtons <|> megaReadM (M.choice noKeywordButtons)) + ( long "cmp-seq" + <> short 's' + <> metavar "BUTTON" + <> help "Which key to use to emit compose-key sequences" + ) + +-- | Where to emit the output +oTokenP :: Parser (Maybe DefSetting) +oTokenP = optional $ SOToken <$> option (tokenParser otokens) + ( long "output" + <> short 'o' + <> metavar "OTOKEN" + <> help "Emit output to OTOKEN" + ) + +-- | How to capture the keyboard input +iTokenP :: Parser (Maybe DefSetting) +iTokenP = optional $ SIToken <$> option (tokenParser itokens) + ( long "input" + <> short 'i' + <> metavar "ITOKEN" + <> help "Capture input via ITOKEN" + ) + +-- | Parse a flag that disables auto-releasing the release of enter +startDelayP :: Parser Milliseconds +startDelayP = option (fromIntegral <$> megaReadM numP) + ( long "start-delay" + <> short 'w' + <> value 300 + <> showDefaultWith (show . unMS ) + <> help "How many ms to wait before grabbing the input keyboard (time to release enter if launching from terminal)") + +-- | Transform a bunch of tokens of the form @(Keyword, Parser)@ into an +-- optparse-applicative parser +tokenParser :: [(Text, M.Parser a)] -> ReadM a +tokenParser = megaReadM . M.choice . map (M.try . uncurry ((*>) . symbol)) + +-- | Megaparsec <--> optparse-applicative interface +megaReadM :: M.Parser a -> ReadM a +megaReadM p = eitherReader (mapLeft show . M.parse p "" . fromString) diff --git a/src/KMonad/Args/Joiner.hs b/src/KMonad/Args/Joiner.hs --- a/src/KMonad/Args/Joiner.hs +++ b/src/KMonad/Args/Joiner.hs @@ -28,8 +28,8 @@ import KMonad.Args.Types -import KMonad.Action -import KMonad.Button +import KMonad.Model.Action +import KMonad.Model.Button import KMonad.Keyboard import KMonad.Keyboard.IO @@ -50,9 +50,9 @@ import Control.Monad.Except -import RIO.List (uncons, headMaybe) +import RIO.List (headMaybe, intersperse, uncons) import RIO.Partial (fromJust) -import qualified Data.LayerStack as L +import qualified KMonad.Util.LayerStack as L import qualified RIO.HashMap as M import qualified RIO.Text as T @@ -129,7 +129,7 @@ -- | Extract anything matching a particular prism from a list extract :: Prism' a b -> [a] -> [b] -extract p = catMaybes . map (preview p) +extract p = mapMaybe (preview p) data SingletonError = None @@ -144,14 +144,14 @@ -- | 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 +oneBlock t l = (view kes <&> (extract l >>> onlyOne)) >>= \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') +joinConfig = getOverride >>= \cfg -> local (const cfg) joinConfig' -- | Join an entire 'CfgToken' from the current list of 'KExpr'. joinConfig' :: J CfgToken @@ -166,8 +166,8 @@ al <- getAllow -- Extract the other blocks and join them into a keymap - let als = extract _KDefAlias $ es - let lys = extract _KDefLayer $ es + let als = extract _KDefAlias es + let lys = extract _KDefLayer es src <- oneBlock "defsrc" _KDefSrc (km, fl) <- joinKeymap src als lys @@ -199,10 +199,9 @@ 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 :: HasLogFunc lf => RIO lf a -> lf -> IO a runLF = flip runRIO - -- | Extract the KeySource-loader from the 'KExpr's getI :: J (LogFunc -> IO (Acquire KeySource)) getI = do @@ -230,7 +229,7 @@ Left None -> pure False Left Duplicate -> throwError $ DuplicateSetting "fallthrough" --- | Extract the fallthrough setting +-- | Extract the allow-cmd setting getAllow :: J Bool getAllow = do cfg <- oneBlock "defcfg" _KDefCfg @@ -239,6 +238,15 @@ Left None -> pure False Left Duplicate -> throwError $ DuplicateSetting "allow-cmd" +-- | Extract the cmp-seq-delay setting +getCmpSeqDelay :: J (Maybe Int) +getCmpSeqDelay = do + cfg <- oneBlock "defcfg" _KDefCfg + case onlyOne . extract _SCmpSeqDelay $ cfg of + Right b -> pure (Just b) + Left None -> pure Nothing + Left Duplicate -> throwError $ DuplicateSetting "cmp-seq-delay" + #ifdef linux_HOST_OS -- | The Linux correspondence between IToken and actual code @@ -252,7 +260,7 @@ 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 (KSendEventSink _) = throwError $ InvalidOS "SendEventSink" pickOutput KKextSink = throwError $ InvalidOS "KextSink" #endif @@ -267,9 +275,9 @@ -- | 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" +pickOutput (KSendEventSink di) = pure $ runLF (sendEventKeySink di) +pickOutput (KUinputSink _ _) = throwError $ InvalidOS "UinputSink" +pickOutput KKextSink = throwError $ InvalidOS "KextSink" #endif @@ -285,7 +293,7 @@ pickOutput :: OToken -> J (LogFunc -> IO (Acquire KeySink)) pickOutput KKextSink = pure $ runLF kextSink pickOutput (KUinputSink _ _) = throwError $ InvalidOS "UinputSink" -pickOutput KSendEventSink = throwError $ InvalidOS "SendEventSink" +pickOutput (KSendEventSink _) = throwError $ InvalidOS "SendEventSink" #endif @@ -302,7 +310,7 @@ 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) + else flip (M.insert t) mp <$> unnest (joinButton ns mp b) -------------------------------------------------------------------------------- -- $but @@ -310,7 +318,7 @@ -- | 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)) +unnest = (maybe (throwError NestedTrans) pure =<<) -- | Turn a button token into an actual KMonad `Button` value joinButton :: LNames -> Aliases -> DefButton -> J (Maybe Button) @@ -321,6 +329,7 @@ go = unnest . joinButton ns als jst = fmap Just fi = fromIntegral + isps l = traverse go . maybe l ((`intersperse` l) . KPause . fi) in \case -- Variable dereference KRef t -> case M.lookup t als of @@ -329,7 +338,9 @@ -- Various simple buttons KEmit c -> ret $ emitB c - KCommand t -> ret $ cmdButton t + KPressOnly c -> ret $ pressOnly c + KReleaseOnly c -> ret $ releaseOnly c + KCommand pr mbR -> ret $ cmdButton pr mbR KLayerToggle t -> if t `elem` ns then ret $ layerToggle t else throwError $ MissingLayer t @@ -350,19 +361,29 @@ 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 + KComposeSeq bs -> do csd <- getCmpSeqDelay + c <- view cmpKey + jst $ tapMacro . (c:) <$> isps bs csd + KTapMacro bs mbD -> jst $ tapMacro <$> isps bs mbD + KBeforeAfterNext b a -> jst $ beforeAfterNext <$> go b <*> go a + KTapMacroRelease bs mbD -> + jst $ tapMacroRelease <$> isps bs mbD 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 + KTapHoldNext s t h mtb + -> jst $ tapHoldNext (fi s) <$> go t <*> go h <*> traverse go mtb KTapNextRelease t h -> jst $ tapNextRelease <$> go t <*> go h - KTapHoldNextRelease ms t h - -> jst $ tapHoldNextRelease (fi ms) <$> go t <*> go h + KTapHoldNextRelease ms t h mtb + -> jst $ tapHoldNextRelease (fi ms) <$> go t <*> go h <*> traverse go mtb + KTapNextPress t h -> jst $ tapNextPress <$> go t <*> go h KAroundNext b -> jst $ aroundNext <$> go b + KAroundNextSingle b -> jst $ aroundNextSingle <$> go b + KAroundNextTimeout ms b t -> jst $ aroundNextTimeout (fi ms) <$> go b <*> go t 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 + KStickyKey s d -> jst $ stickyKey (fi s) <$> go d -- Non-action buttons KTrans -> pure Nothing @@ -382,7 +403,7 @@ 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) + pure (L.mkLayerStack lys', _layerName . fromJust . headMaybe $ lys) -- | Check and join 1 deflayer. joinLayer :: diff --git a/src/KMonad/Args/Parser.hs b/src/KMonad/Args/Parser.hs --- a/src/KMonad/Args/Parser.hs +++ b/src/KMonad/Args/Parser.hs @@ -16,22 +16,36 @@ -} module KMonad.Args.Parser - ( parseTokens + ( -- * Parsing 'KExpr's + parseTokens , loadTokens + + -- * Building Parsers + , symbol + , numP + + -- * Parsers for Tokens and Buttons + , otokens + , itokens + , keywordButtons + , noKeywordButtons ) where import KMonad.Prelude hiding (try, bool) +import KMonad.Parsing 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 KMonad.Util.MultiMap as Q import qualified RIO.Text as T import qualified Text.Megaparsec.Char.Lexer as L @@ -40,14 +54,14 @@ -- $run -- | Try to parse a list of 'KExpr' from 'Text' -parseTokens :: Text -> Either PErrors [KExpr] +parseTokens :: Text -> Either ParseError [KExpr] parseTokens t = case runParser configP "" t of - Left e -> Left $ PErrors e + Left e -> Left $ ParseError 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 +loadTokens pth = (readFileUtf8 pth <&> parseTokens) >>= \case Left e -> throwM e Right xs -> pure xs @@ -55,13 +69,6 @@ -------------------------------------------------------------------------------- -- $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 @@ -102,7 +109,7 @@ x -> x -- | Make a parser that matches a terminated symbol or fails - mkOne (s, x) = terminated (string s) *> pure x + mkOne (s, x) = terminated (string s) $> x -- | Run a parser between 2 sets of parentheses paren :: Parser a -> Parser a @@ -114,9 +121,14 @@ -- | Run a parser that parser a bool value bool :: Parser Bool -bool = symbol "true" *> pure True - <|> symbol "false" *> pure False +bool = (symbol "true" $> True) + <|> (symbol "false" $> False) +-- | Parse a LISP-like keyword of the form @:keyword value@ +keywordP :: Text -> Parser p -> Parser p +keywordP kw p = symbol (":" <> kw) *> lexeme p + "Keyword " <> ":" <> T.unpack kw + -------------------------------------------------------------------------------- -- $elem -- @@ -130,7 +142,7 @@ numP :: Parser Int numP = L.decimal --- | Parse text with escaped characters between "s +-- | Parse text with escaped characters between double quotes. textP :: Parser Text textP = do _ <- char '\"' @@ -171,7 +183,7 @@ -- | 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 + map f $ cps <> num <> oth <> lng where cps = zip (map T.singleton ['A'..'Z']) [ KeyA, KeyB, KeyC, KeyD, KeyE, KeyF, KeyG, KeyH, KeyI, KeyJ, KeyK, KeyL, KeyM, @@ -181,6 +193,8 @@ oth = zip (map T.singleton "<>:~\"|{}+?") [ KeyComma, KeyDot, KeySemicolon, KeyGrave, KeyApostrophe, KeyBackslash , KeyLeftBrace, KeyRightBrace, KeyEqual, KeySlash] + lng = [ ("quot", KeyApostrophe), ("pipe", KeyBackslash), ("cln", KeySemicolon) + , ("tild", KeyGrave) , ("udrs", KeyMinus)] -- | Names for various buttons buttonNames :: [(Text, DefButton)] @@ -203,7 +217,7 @@ , ("A-", KeyLeftAlt), ("M-", KeyLeftMeta) , ("RS-", KeyRightShift), ("RC-", KeyRightCtrl) , ("RA-", KeyRightAlt), ("RM-", KeyRightMeta)] - prfx = choice $ map (\(t, p) -> prefix (string t) *> pure (KEmit p)) mods + prfx = choice $ map (\(t, p) -> prefix (string t) $> KEmit p) mods -- | Parse Pxxx as pauses (useful in macros) pauseP :: Parser DefButton @@ -211,14 +225,16 @@ -- | #()-syntax tap-macro rmTapMacroP :: Parser DefButton -rmTapMacroP = KTapMacro <$> (char '#' *> paren (some buttonP)) +rmTapMacroP = + char '#' *> paren (KTapMacro <$> some buttonP + <*> optional (keywordP "delay" numP)) -- | 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 + s <- case find (\(_, c', _) -> c' == c) ssComposed of Nothing -> fail "Unrecognized compose-char" Just b -> pure $ b^._1 @@ -231,7 +247,7 @@ deadkeySeqP :: Parser [DefButton] deadkeySeqP = do _ <- prefix (char '+') - c <- satisfy (`elem` ("~'^`\"" :: String)) + c <- satisfy (`elem` ("~'^`\"," :: String)) case runParser buttonP "" (T.singleton c) of Left _ -> fail "Could not parse deadkey sequence" Right b -> pure [b] @@ -239,26 +255,56 @@ -- | 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 + map (uncurry statement) keywordButtons ++ noKeywordButtons + ) "button" + +-- | Parsers for buttons that have a keyword at the start; the format is +-- @(keyword, how to parse the token)@ +keywordButtons :: [(Text, Parser DefButton)] +keywordButtons = + [ ("around" , KAround <$> buttonP <*> buttonP) + , ("press-only" , KPressOnly <$> keycodeP) + , ("release-only" , KReleaseOnly <$> keycodeP) + , ("multi-tap" , KMultiTap <$> timed <*> buttonP) + , ("tap-hold" , KTapHold <$> lexeme numP <*> buttonP <*> buttonP) + , ("tap-hold-next" + , KTapHoldNext <$> lexeme numP <*> buttonP <*> buttonP + <*> optional (keywordP "timeout-button" buttonP)) + , ("tap-next-release" + , KTapNextRelease <$> buttonP <*> buttonP) + , ("tap-hold-next-release" + , KTapHoldNextRelease <$> lexeme numP <*> buttonP <*> buttonP + <*> optional (keywordP "timeout-button" buttonP)) + , ("tap-next-press" + , KTapNextPress <$> buttonP <*> buttonP) + , ("tap-next" , KTapNext <$> buttonP <*> buttonP) + , ("layer-toggle" , KLayerToggle <$> lexeme word) + , ("momentary-layer" , KLayerToggle <$> lexeme word) + , ("layer-switch" , KLayerSwitch <$> lexeme word) + , ("permanent-layer" , KLayerSwitch <$> lexeme word) + , ("layer-add" , KLayerAdd <$> lexeme word) + , ("layer-rem" , KLayerRem <$> lexeme word) + , ("layer-delay" , KLayerDelay <$> lexeme numP <*> lexeme word) + , ("layer-next" , KLayerNext <$> lexeme word) + , ("around-next" , KAroundNext <$> buttonP) + , ("before-after-next", KBeforeAfterNext <$> buttonP <*> buttonP) + , ("around-next-timeout", KAroundNextTimeout <$> lexeme numP <*> buttonP <*> buttonP) + , ("tap-macro" + , KTapMacro <$> lexeme (some buttonP) <*> optional (keywordP "delay" numP)) + , ("tap-macro-release" + , KTapMacroRelease <$> lexeme (some buttonP) <*> optional (keywordP "delay" numP)) + , ("cmd-button" , KCommand <$> lexeme textP <*> optional (lexeme textP)) + , ("pause" , KPause . fromIntegral <$> numP) + , ("sticky-key" , KStickyKey <$> lexeme numP <*> buttonP) + ] + where + timed :: Parser [(Int, DefButton)] + timed = many ((,) <$> lexeme numP <*> lexeme buttonP) + +-- | Parsers for buttons that do __not__ have a keyword at the start +noKeywordButtons :: [Parser DefButton] +noKeywordButtons = + [ KComposeSeq <$> deadkeySeqP , KRef <$> derefP , lexeme $ fromNamed buttonNames , try moddedP @@ -266,29 +312,33 @@ , 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] +itokenP = choice $ map (try . uncurry statement) itokens +-- | Input tokens to parse; the format is @(keyword, how to parse the token)@ +itokens :: [(Text, Parser IToken)] +itokens = + [ ("device-file" , KDeviceSource <$> (T.unpack <$> textP)) + , ("low-level-hook", pure KLowLevelHookSource) + , ("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] +otokenP = choice $ map (try . uncurry statement) otokens +-- | Output tokens to parse; the format is @(keyword, how to parse the token)@ +otokens :: [(Text, Parser OToken)] +otokens = + [ ("uinput-sink" , KUinputSink <$> lexeme textP <*> optional textP) + , ("send-event-sink", KSendEventSink <$> optional ((,) <$> lexeme numP <*> numP)) + , ("kext" , pure KKextSink)] + -- | Parse the DefCfg token defcfgP :: Parser DefSettings defcfgP = some (lexeme settingP) @@ -297,12 +347,13 @@ 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 + [ 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 + , SCmpSeqDelay <$> f "cmp-seq-delay" numP ]) -------------------------------------------------------------------------------- @@ -323,4 +374,3 @@ -- $deflayer deflayerP :: Parser DefLayer deflayerP = DefLayer <$> lexeme word <*> many (lexeme buttonP) - diff --git a/src/KMonad/Args/TH.hs b/src/KMonad/Args/TH.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/Args/TH.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE BlockArguments #-} +{-| +Module : KMonad.Args.TH +Description : Template Haskell to use in the CLI +Copyright : (c) slotThe, 2021 +License : MIT + +Maintainer : soliditsallgood@mailbox.org +Stability : experimental +Portability : non-portable (TH) + +-} +module KMonad.Args.TH (gitHash) where + +import KMonad.Prelude + +import Language.Haskell.TH (Exp, Q) +import Language.Haskell.TH.Syntax (runIO) +import UnliftIO.Process (readProcessWithExitCode) + + +-- | Get the git hash of the current revision at compile time +gitHash :: Q Exp +gitHash = do + str <- runIO do + (exitCode, hash, _) <- readProcessWithExitCode "git" ["rev-parse", "HEAD"] "" + pure case exitCode of + ExitSuccess -> takeWhile (/= '\n') hash + _ -> "" + [| fromString str |] diff --git a/src/KMonad/Args/Types.hs b/src/KMonad/Args/Types.hs --- a/src/KMonad/Args/Types.hs +++ b/src/KMonad/Args/Types.hs @@ -10,12 +10,9 @@ -} module KMonad.Args.Types - ( -- * $bsc - Parser - , PErrors(..) - + ( -- * $cfg - , CfgToken(..) + CfgToken(..) -- * $but , DefButton(..) @@ -35,67 +32,59 @@ -- * $lenses , AsKExpr(..) , AsDefSetting(..) - - -- * Reexports - , module Text.Megaparsec - , module Text.Megaparsec.Char ) where import KMonad.Prelude -import KMonad.Button +import KMonad.Model.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 +-- FIXME: This is really broken: why are there 2 lists of 'DefButton's? There is +-- one here, and one in Parser/Types.hs + -- | Button ADT data DefButton = KRef Text -- ^ Reference a named button | KEmit Keycode -- ^ Emit a keycode + | KPressOnly Keycode -- ^ Emit only the press of a keycode + | KReleaseOnly Keycode -- ^ Emit only the release of 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 + | KTapHoldNext Int DefButton DefButton (Maybe DefButton) + -- ^ Mixture between KTapNext and KTapHold | KTapNextRelease DefButton DefButton -- ^ Do 2 things based on behavior - | KTapHoldNextRelease Int DefButton DefButton + | KTapHoldNextRelease Int DefButton DefButton (Maybe DefButton) -- ^ Like KTapNextRelease but with a timeout + | KTapNextPress DefButton DefButton -- ^ Like KTapNextRelease but also hold on presses | KAroundNext DefButton -- ^ Surround a future button + | KAroundNextSingle 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 + | KAroundNextTimeout Int DefButton DefButton + | KTapMacro [DefButton] (Maybe Int) + -- ^ Sequence of buttons to tap, possible delay between each press + | KTapMacroRelease [DefButton] (Maybe Int) + -- ^ Sequence of buttons to tap, tap last on release, possible delay between each press | 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 + | KCommand Text (Maybe Text) -- ^ Execute a shell command on press, as well + -- as possibly on release + | KStickyKey Int DefButton -- ^ Act as if a button is pressed for a period of time + | KBeforeAfterNext DefButton DefButton -- ^ Surround a future button in a before and after tap | KTrans -- ^ Transparent button that does nothing | KBlock -- ^ Button that catches event deriving Show @@ -156,7 +145,7 @@ -- | All different output-tokens KMonad can take data OToken = KUinputSink Text (Maybe Text) - | KSendEventSink + | KSendEventSink (Maybe (Int, Int)) | KKextSink deriving Show @@ -168,8 +157,21 @@ | SInitStr Text | SFallThrough Bool | SAllowCmd Bool + | SCmpSeqDelay Int deriving Show makeClassyPrisms ''DefSetting + +-- | 'Eq' instance for a 'DefSetting'. Because every one of these options may be +-- given at most once, we only need to check the outermost constructor in order +-- to test for equality +instance Eq DefSetting where + SIToken{} == SIToken{} = True + SOToken{} == SOToken{} = True + SCmpSeq{} == SCmpSeq{} = True + SInitStr{} == SInitStr{} = True + SFallThrough{} == SFallThrough{} = True + SAllowCmd{} == SAllowCmd{} = True + _ == _ = False -- | A list of different 'DefSetting' values type DefSettings = [DefSetting] diff --git a/src/KMonad/Button.hs b/src/KMonad/Button.hs deleted file mode 100644 --- a/src/KMonad/Button.hs +++ /dev/null @@ -1,355 +0,0 @@ -{-| -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/Gesture.hs b/src/KMonad/Gesture.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/Gesture.hs @@ -0,0 +1,154 @@ +-- | + +module KMonad.Gesture + +where + +import KMonad.Prelude hiding (try) +import KMonad.Parsing + +import Control.Monad.Except +import Control.Monad.State +import Data.Char + +import RIO.List.Partial (head) +import RIO.Seq (Seq(..)) + +import qualified RIO.List as L +import qualified RIO.Seq as Q +import qualified RIO.Set as S + + +-------------------------------------------------------------------------------- + +data Toggle a = On a | Off a deriving (Eq, Show, Functor) + +-- | A sequence of toggle-changes guaranteed to be valid +newtype Gesture a = Gesture { _gesture :: Q.Seq (Toggle a) } + deriving (Eq, Show, Functor) + +instance Semigroup (Gesture a) where + (Gesture a) <> (Gesture b) = Gesture $ a <> b +instance Monoid (Gesture a) where + mempty = Gesture Q.empty + +-- | All the ways a '[Toggle a]' can be an invalid 'Gesture' +data GestureError a + = OffWithoutOn a -- ^ An Off not preceded by an On + | OnWithoutOff a -- ^ An On not succeeded by an Off + deriving (Eq, Show) + + +-------------------------------------------------------------------------------- + +-- | A lens into the i +tag :: Lens' (Toggle a) a +tag = lens get set + where get (On x) = x + get (Off x) = x + set (On _) x = On x + set (Off _) x = Off x + +-- | A fold of all the unique elements in a gesture +tags :: Ord a => Fold (Gesture a) a +tags = folding $ \(Gesture as) -> toList . S.fromList $ as^..folded.tag + +-- | Create a tapping gesture +tap :: a -> Gesture a +tap a = Gesture . Q.fromList $ [On a, Off a] + +-- | Wrap a gesture in a toggle iff the id does not already occur +around :: Ord a => a -> Gesture a -> Either (GestureError a) (Gesture a) +around x g@(Gesture seq) + | anyOf tags (== x) g = Left $ OnWithoutOff x + | otherwise = Right . Gesture $ (On x <| seq) |> Off x + +-- | Create a gesture from a list of toggles +fromList :: Ord a => [Toggle a] -> Either (GestureError a) (Gesture a) +fromList as = case (`runState` S.empty) . runExceptT . foldM f Q.empty $ as of + (Left e, _) -> Left e + (Right g, s) | S.null s -> Right $ Gesture g + | otherwise -> Left $ OnWithoutOff (head . S.elems $ s) + where + f s x = do + pressed <- get + case x of + On c | c `S.member` pressed -> throwError $ OnWithoutOff c + On c -> put (S.insert c pressed) >> pure (s |> On c) + Off c | not (c `S.member` pressed) -> throwError $ OffWithoutOn c + Off c -> put (S.delete c pressed) >> pure (s |> Off c) + +-------------------------------------------------------------------------------- + +type Gest = Q.Seq (Toggle Text) + +data GestureReadError + = GestureParseError ParseError + | GestureValidateError (GestureError Text) + deriving Eq + +instance Show GestureReadError where + show (GestureParseError e) = show e + show (GestureValidateError e) = show e + +instance Exception GestureReadError + +-- | Parse a Gesture straight from Text +prsGesture :: Text -> Either GestureReadError (Gesture Text) +prsGesture t = case runParser gest "" t of + Left e -> Left . GestureParseError . ParseError $ e + Right gs -> case fromList (toList gs) of + Left e -> Left . GestureValidateError $ e + Right g -> pure g + +-- | Characters that may not occur in tag-names +reserved :: [Char] +reserved = "()-~[]" + +-- | Parse a series of valid characters as a tag +tag_ :: Parser Text +tag_ = takeWhile1P (Just "tag-character") f + where f c = not $ isSpace c || c `elem` reserved + +-- | Parse a "S-" sequence as 1 tag around another +around_ :: Parser Gest +around_ = do + a <- tag_ + _ <- char '-' + b <- try around_ <|> subg <|> tap_ + pure $ (On a <| b) |> Off a + +-- | Parse a ")-X" as an OFF-toggle +closeTag :: Parser Gest +closeTag = do + _ <- string ")-" + a <- tag_ + pure . Q.singleton $ Off a + +-- | Parse a "X-(" as an ON-toggle +openTag :: Parser Gest +openTag = do + a <- tag_ + _ <- string "-(" + pure . Q.singleton $ On a + +-- | Parse only a tag as a tap of that element +tap_ :: Parser Gest +tap_ = do + a <- tag_ + pure . Q.fromList $ [On a, Off a] + +-- | Parse a [] delimited series as a nested gesture +subg :: Parser Gest +subg = do + _ <- char '[' + g <- gest + _ <- char ']' + pure g + +-- | Parse a full gesture +gest :: Parser Gest +gest = do + let one = lex . choice $ [subg, try openTag, try around_, try closeTag, tap_] + es <- some one + pure $ mconcat es diff --git a/src/KMonad/Keyboard.hs b/src/KMonad/Keyboard.hs --- a/src/KMonad/Keyboard.hs +++ b/src/KMonad/Keyboard.hs @@ -1,132 +1,21 @@ -{-# LANGUAGE DeriveAnyClass #-} {-| Module : KMonad.Keyboard Description : Basic keyboard types -Copyright : (c) David Janssen, 2019 +Copyright : (c) David Janssen, 2021 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". +Interface to the Keyboard module -} 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 + ( module X ) - 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 +import KMonad.Keyboard.IO as X +import KMonad.Keyboard.Keycode as X +import KMonad.Keyboard.Ops as X +import KMonad.Keyboard.Types as X diff --git a/src/KMonad/Keyboard/ComposeSeq.hs b/src/KMonad/Keyboard/ComposeSeq.hs --- a/src/KMonad/Keyboard/ComposeSeq.hs +++ b/src/KMonad/Keyboard/ComposeSeq.hs @@ -135,6 +135,8 @@ , ("` E" , 'È' , "Egrave") , ("' E" , 'É' , "Eacute") , ("^ E" , 'Ê' , "Ecircumflex") + , ("^ U" , 'Û' , "Ucircumflex") + , ("` U" , 'Ù' , "Ugrave") , ("\" E" , 'Ë' , "Ediaeresis") , ("` I" , 'Ì' , "Igrave") , ("' I" , 'Í' , "Iacute") @@ -147,6 +149,8 @@ , ("^ O" , 'Ô' , "Ocircumflex") , ("~ O" , 'Õ' , "Otilde") , ("\" O" , 'Ö' , "Odiaeresis") + , ("\" U" , 'Ü' , "Udiaeresis") + , ("' U" , 'Ú' , "Uacute") , ("x x" , '×' , "multiply") , ("/ O" , 'Ø' , "Oslash") , ("' Y" , 'Ý' , "Yacute") @@ -724,9 +728,11 @@ , ("_ '" , '⍘' , "U2358") , ("0 ~" , '⍬' , "U236c") , ("| ~" , '⍭' , "U236d") + , ("c /" , '¢' , "cent" ) + , ("< _" , '≤' , "U2264") + , ("> _" , '≥' , "U2265") -- 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 --- a/src/KMonad/Keyboard/IO.hs +++ b/src/KMonad/Keyboard/IO.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveAnyClass #-} {-| Module : KMonad.Keyboard.IO Description : The logic behind sending and receiving key events to the OS @@ -26,7 +25,7 @@ import KMonad.Prelude -import KMonad.Keyboard +import KMonad.Keyboard.Types import KMonad.Util import qualified RIO.Text as T @@ -66,9 +65,9 @@ -- | 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 src -- ^ Action to acquire the keysource + -> (src -> RIO e ()) -- ^ Action to close the keysource + -> (src -> RIO e KeyEvent) -- ^ Action to write with the keysource -> RIO e (Acquire KeySource) mkKeySource o c r = do u <- askUnliftIO diff --git a/src/KMonad/Keyboard/IO/Linux/DeviceSource.hs b/src/KMonad/Keyboard/IO/Linux/DeviceSource.hs --- a/src/KMonad/Keyboard/IO/Linux/DeviceSource.hs +++ b/src/KMonad/Keyboard/IO/Linux/DeviceSource.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-| Module : KMonad.Keyboard.IO.Linux.DeviceSource @@ -77,7 +78,7 @@ -- | The KeyEventParser that works on my 64-bit Linux environment decode64 :: B.ByteString -> Either String LinuxKeyEvent -decode64 bs = (linuxKeyEvent . fliptup) <$> result +decode64 bs = linuxKeyEvent . fliptup <$> result where result :: Either String (Int32, Word16, Word16, Word64, Word64) result = B.decode . B.reverse $ bs @@ -131,10 +132,14 @@ -> 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 + h <- liftIO $ openFd pt + ReadOnly +#if !MIN_VERSION_unix(2,8,0) + Nothing +#endif + defaultFileFlags hd <- liftIO $ fdToHandle h - logInfo $ "Initiating ioctl grab" + logInfo "Initiating ioctl grab" ioctl_keyboard h True `onErr` IOCtlGrabError pt return $ DeviceFile (DeviceSourceCfg pt pr) h hd @@ -143,7 +148,7 @@ -- 'IOCtlReleaseError' if the ioctl release could not be properly performed. lsClose :: (HasLogFunc e) => DeviceFile -> RIO e () lsClose src = do - logInfo $ "Releasing ioctl grab" + logInfo "Releasing ioctl grab" ioctl_keyboard (src^.fd) False `onErr` IOCtlReleaseError (src^.pth) liftIO . closeFd $ src^.fd @@ -153,7 +158,7 @@ lsRead :: (HasLogFunc e) => DeviceFile -> RIO e KeyEvent lsRead src = do bts <- B.hGet (src^.hdl) (src^.nbytes) - case (src^.prs $ bts) of + case src^.prs $ bts of Right p -> case fromLinuxKeyEvent p of Just e -> return e Nothing -> lsRead src diff --git a/src/KMonad/Keyboard/IO/Linux/Types.hs b/src/KMonad/Keyboard/IO/Linux/Types.hs --- a/src/KMonad/Keyboard/IO/Linux/Types.hs +++ b/src/KMonad/Keyboard/IO/Linux/Types.hs @@ -119,4 +119,4 @@ = LinuxKeyEvent (fi s, fi ns, 1, c, val) where c = fi . fromEnum $ e^.keycode - val = if (e^.switch == Press) then 1 else 0 + 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 --- a/src/KMonad/Keyboard/IO/Linux/UinputSink.hs +++ b/src/KMonad/Keyboard/IO/Linux/UinputSink.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} +{-# OPTIONS_GHC -Wno-dodgy-imports #-} {-| Module : KMonad.Keyboard.IO.Linux.UinputSink Description : Using Linux's uinput interface to emit events @@ -27,9 +29,9 @@ import Foreign.C.String import Foreign.C.Types -import System.Posix +import System.Posix hiding (sync) import UnliftIO.Async (async) -import UnliftIO.Process (callCommand) +import UnliftIO.Process (spawnCommand) import KMonad.Keyboard.IO.Linux.Types import KMonad.Util @@ -44,6 +46,7 @@ = UinputRegistrationError SinkId -- ^ Could not register device | UinputReleaseError SinkId -- ^ Could not release device | SinkEncodeError SinkId LinuxKeyEvent -- ^ Could not decode event + | EmptyNameError -- ^ Invalid name deriving Exception instance Show UinputSinkError where @@ -55,6 +58,7 @@ , "to bytes for writing to" , snk ] + show EmptyNameError = "Provided empty name for Uinput keyboard" makeClassyPrisms ''UinputSinkError @@ -129,7 +133,7 @@ -> 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') + liftIO (c_send_event h typ c val s' ns') `onErr` SinkEncodeError (u^.cfg.keyboardName) e @@ -138,13 +142,18 @@ -- | 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 + when (null $ c ^. keyboardName) $ throwM EmptyNameError + fd <- liftIO $ openFd "/dev/uinput" + WriteOnly +#if !MIN_VERSION_unix(2,8,0) + Nothing +#endif + defaultFileFlags 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 + void . async . spawnCommand $ cmd UinputSink c <$> newMVar fd -- | Close a 'UinputSink' @@ -152,18 +161,18 @@ usClose snk = withMVar (snk^.st) $ \h -> finally (release h) (close h) where release h = do - logInfo $ "Unregistering Uinput device" + logInfo "Unregistering Uinput device" release_uinput_keysink h `onErr` UinputReleaseError (snk^.cfg.keyboardName) close h = do - logInfo $ "Closing Uinput device file" + 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 + 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 --- a/src/KMonad/Keyboard/IO/Mac/IOKitSource.hs +++ b/src/KMonad/Keyboard/IO/Mac/IOKitSource.hs @@ -30,14 +30,14 @@ wait_key :: Ptr MacKeyEvent -> IO Word8 -data EvBuf = EvBuf - { _buffer :: !(Ptr MacKeyEvent) +newtype EvBuf = EvBuf + { _buffer :: Ptr MacKeyEvent } makeLenses ''EvBuf -- | Return a KeySource using the Mac IOKit approach iokitSource :: HasLogFunc e - => (Maybe String) + => Maybe String -> RIO e (Acquire KeySource) iokitSource name = mkKeySource (iokitOpen name) iokitClose iokitRead @@ -46,7 +46,7 @@ -- | Ask IOKit to open keyboards matching the specified name iokitOpen :: HasLogFunc e - => (Maybe String) + => Maybe String -> RIO e EvBuf iokitOpen m = do logInfo "Opening IOKit devices" @@ -78,4 +78,6 @@ we <- liftIO $ do _ <- wait_key $ b^.buffer peek $ b^.buffer - either throwIO pure $ fromMacKeyEvent we + case fromMacKeyEvent we of + Nothing -> iokitRead b + Just e -> either throwIO pure e diff --git a/src/KMonad/Keyboard/IO/Mac/KextSink.hs b/src/KMonad/Keyboard/IO/Mac/KextSink.hs --- a/src/KMonad/Keyboard/IO/Mac/KextSink.hs +++ b/src/KMonad/Keyboard/IO/Mac/KextSink.hs @@ -16,7 +16,7 @@ foreign import ccall "send_key" send_key :: Ptr MacKeyEvent -> IO () -data EvBuf = EvBuf +newtype EvBuf = EvBuf { _buffer :: Ptr MacKeyEvent -- ^ The pointer we write events to } makeClassy ''EvBuf diff --git a/src/KMonad/Keyboard/IO/Mac/Types.hs b/src/KMonad/Keyboard/IO/Mac/Types.hs --- a/src/KMonad/Keyboard/IO/Mac/Types.hs +++ b/src/KMonad/Keyboard/IO/Mac/Types.hs @@ -1,7 +1,6 @@ module KMonad.Keyboard.IO.Mac.Types ( MacError(..) , MacKeyEvent - , mkMacKeyEvent , toMacKeyEvent , fromMacKeyEvent ) @@ -23,18 +22,21 @@ data MacError = NoMacKeycodeTo Keycode -- ^ Error translating to 'MacKeycode' | NoMacKeycodeFrom MacKeycode -- ^ Error translating from 'MacKeycode' + | BadMacSwitch MacSwitch -- ^ Error interpreting 'MacSwitch' 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 + BadMacSwitch s -> "Cannot interpret mac switch: " <> show s +instance Exception [MacError] -------------------------------------------------------------------------------- -- $typ -type MacSwitch = Word8 -- ^ Type alias for the switch value -type MacKeycode = Word32 -- ^ Type alias for the Mac keycode +type MacSwitch = Word64 -- ^ Type alias for the switch value +type MacKeycode = (Word32, Word32) -- ^ Type alias for the Mac keycode -- | 'MacKeyEvent' is the C-representation of a a 'KeyEvent' for our Mac API. -- @@ -50,33 +52,30 @@ -- | 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 + alignment _ = 4 + sizeOf _ = 16 peek ptr = do s <- peekByteOff ptr 0 - c <- peekByteOff ptr 4 - return $ MacKeyEvent (s, c) - poke ptr (MacKeyEvent (s, c)) = do + p <- peekByteOff ptr 8 + u <- peekByteOff ptr 12 + return $ MacKeyEvent (s, (p, u)) + poke ptr (MacKeyEvent (s, (p, u))) = do pokeByteOff ptr 0 s - pokeByteOff ptr 4 c - -mkMacKeyEvent :: MacSwitch -> MacKeycode -> MacKeyEvent -mkMacKeyEvent s e = MacKeyEvent (s, e) + pokeByteOff ptr 8 p + pokeByteOff ptr 12 u -------------------------------------------------------------------------------- -- $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 +fromMacSwitch :: MacSwitch -> Maybe Switch +fromMacSwitch s = case s of + 1 -> Just Press + 0 -> Just Release + _ -> Nothing +toMacSwitch :: Switch -> MacSwitch +toMacSwitch s = if s == Press then 1 else 0 + -- | Lookup the corresponding 'Keycode' for this 'MacKeycode' fromMacKeycode :: MacKeycode -> Maybe Keycode fromMacKeycode = flip M.lookup kcMap @@ -84,7 +83,7 @@ -- | 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 + where revMap = M.fromList $ M.toList kcMap ^.. folded . swapped -- | Convert a 'KeyEvent' to a 'MacKeyEvent' -- @@ -94,17 +93,21 @@ -- 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) + Just c -> Right $ MacKeyEvent (toMacSwitch (e^.switch), 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 - +fromMacKeyEvent :: MacKeyEvent -> Maybe (Either [MacError] KeyEvent) +fromMacKeyEvent (MacKeyEvent (s, (p, u))) + | p == 7 && u <= 0x3 = Nothing + | p == 7 && u >= 0xFFFF = Nothing + | otherwise = case (fromMacKeycode (p, u), fromMacSwitch s) of + (Just c', Just s') -> Just (Right $ mkKeyEvent s' c') + (Just _, Nothing) -> Just (Left [BadMacSwitch s]) + (Nothing, Just _) -> Just (Left [NoMacKeycodeFrom (p,u)]) + (Nothing, Nothing) -> Just (Left [BadMacSwitch s, NoMacKeycodeFrom (p,u)]) -------------------------------------------------------------------------------- -- $kc @@ -114,193 +117,188 @@ -- 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) +kcMap = M.fromList + [ ((0x7,0x4), KeyA) + , ((0x7,0x5), KeyB) + , ((0x7,0x6), KeyC) + , ((0x7,0x7), KeyD) + , ((0x7,0x8), KeyE) + , ((0x7,0x9), KeyF) + , ((0x7,0xA), KeyG) + , ((0x7,0xB), KeyH) + , ((0x7,0xC), KeyI) + , ((0x7,0xD), KeyJ) + , ((0x7,0xE), KeyK) + , ((0x7,0xF), KeyL) + , ((0x7,0x10), KeyM) + , ((0x7,0x11), KeyN) + , ((0x7,0x12), KeyO) + , ((0x7,0x13), KeyP) + , ((0x7,0x14), KeyQ) + , ((0x7,0x15), KeyR) + , ((0x7,0x16), KeyS) + , ((0x7,0x17), KeyT) + , ((0x7,0x18), KeyU) + , ((0x7,0x19), KeyV) + , ((0x7,0x1A), KeyW) + , ((0x7,0x1B), KeyX) + , ((0x7,0x1C), KeyY) + , ((0x7,0x1D), KeyZ) + , ((0x7,0x1E), Key1) + , ((0x7,0x1F), Key2) + , ((0x7,0x20), Key3) + , ((0x7,0x21), Key4) + , ((0x7,0x22), Key5) + , ((0x7,0x23), Key6) + , ((0x7,0x24), Key7) + , ((0x7,0x25), Key8) + , ((0x7,0x26), Key9) + , ((0x7,0x27), Key0) + , ((0x7,0x28), KeyEnter) + , ((0x7,0x29), KeyEsc) + , ((0x7,0x2A), KeyBackspace) + , ((0x7,0x2B), KeyTab) + , ((0x7,0x2C), KeySpace) + , ((0x7,0x2D), KeyMinus) + , ((0x7,0x2E), KeyEqual) + , ((0x7,0x2F), KeyLeftBrace) + , ((0x7,0x30), KeyRightBrace) + , ((0x7,0x31), KeyBackslash) + -- , ((0x7,0x32), KeyNonUSPound) + , ((0x7,0x33), KeySemicolon) + , ((0x7,0x34), KeyApostrophe) + , ((0x7,0x35), KeyGrave) + , ((0x7,0x36), KeyComma) + , ((0x7,0x37), KeyDot) + , ((0x7,0x38), KeySlash) + , ((0x7,0x39), KeyCapsLock) + , ((0x7,0x3A), KeyF1) + , ((0x7,0x3B), KeyF2) + , ((0x7,0x3C), KeyF3) + , ((0x7,0x3D), KeyF4) + , ((0x7,0x3E), KeyF5) + , ((0x7,0x3F), KeyF6) + , ((0x7,0x40), KeyF7) + , ((0x7,0x41), KeyF8) + , ((0x7,0x42), KeyF9) + , ((0x7,0x43), KeyF10) + , ((0x7,0x44), KeyF11) + , ((0x7,0x45), KeyF12) + , ((0x7,0x46), KeyPrint) + , ((0x7,0x47), KeyScrollLock) + , ((0x7,0x48), KeyPause) + , ((0x7,0x49), KeyInsert) + , ((0x7,0x4A), KeyHome) + , ((0x7,0x4B), KeyPageUp) + , ((0x7,0x4C), KeyDelete) + , ((0x7,0x4D), KeyEnd) + , ((0x7,0x4E), KeyPageDown) + , ((0x7,0x4F), KeyRight) + , ((0x7,0x50), KeyLeft) + , ((0x7,0x51), KeyDown) + , ((0x7,0x52), KeyUp) + , ((0x7,0x53), KeyNumLock) + , ((0x7,0x54), KeyKpSlash) + , ((0x7,0x55), KeyKpAsterisk) + , ((0x7,0x56), KeyKpMinus) + , ((0x7,0x57), KeyKpPlus) + , ((0x7,0x58), KeyKpEnter) + , ((0x7,0x59), KeyKp1) + , ((0x7,0x5A), KeyKp2) + , ((0x7,0x5B), KeyKp3) + , ((0x7,0x5C), KeyKp4) + , ((0x7,0x5D), KeyKp5) + , ((0x7,0x5E), KeyKp6) + , ((0x7,0x5F), KeyKp7) + , ((0x7,0x60), KeyKp8) + , ((0x7,0x61), KeyKp9) + , ((0x7,0x62), KeyKp0) + , ((0x7,0x63), KeyKpDot) + -- , ((0x7,0x64), KeyNonUSBackslash) + -- , ((0x7,0x65), KeyApplication) + , ((0x7,0x66), KeyPower) + , ((0x7,0x67), KeyKpEqual) + , ((0x7,0x68), KeyF13) + , ((0x7,0x69), KeyF14) + , ((0x7,0x6A), KeyF15) + , ((0x7,0x6B), KeyF16) + , ((0x7,0x6C), KeyF17) + , ((0x7,0x6D), KeyF18) + , ((0x7,0x6E), KeyF19) + , ((0x7,0x6F), KeyF20) + , ((0x7,0x70), KeyF21) + , ((0x7,0x71), KeyF22) + , ((0x7,0x72), KeyF23) + , ((0x7,0x73), KeyF24) + -- , ((0x7,0x74), KeyExecute) + , ((0x7,0x75), KeyHelp) + , ((0x7,0x76), KeyMenu) + -- , ((0x7,0x77), KeySelect) + , ((0x7,0x78), KeyStop) + , ((0x7,0x79), KeyAgain) + , ((0x7,0x7A), KeyUndo) + , ((0x7,0x7B), KeyCut) + , ((0x7,0x7C), KeyCopy) + , ((0x7,0x7D), KeyPaste) + , ((0x7,0x7E), KeyFind) + , ((0x7,0x7F), KeyMute) + , ((0x7,0x80), KeyVolumeUp) + , ((0x7,0x81), KeyVolumeDown) + -- , ((0x7,0x82), KeyLockingCapsLock) + -- , ((0x7,0x83), KeyLockingNumLock) + -- , ((0x7,0x84), KeyLockingScrollLock) + , ((0x7,0x85), KeyKpComma) + -- , ((0x7,0x86), KeyKpEqualSignAS400) + -- , ((0x7,0x87), KeyInternational1) + -- , ((0x7,0x88), KeyInternational2) + -- , ((0x7,0x89), KeyInternational3) + -- , ((0x7,0x8A), KeyInternational4) + -- , ((0x7,0x8B), KeyInternational5) + -- , ((0x7,0x8C), KeyInternational6) + -- , ((0x7,0x8D), KeyInternational7) + -- , ((0x7,0x8E), KeyInternational8) + -- , ((0x7,0x8F), KeyInternational9) + -- , ((0x7,0x90), KeyLANG1) + -- , ((0x7,0x91), KeyLANG2) + -- , ((0x7,0x92), KeyLANG3) + -- , ((0x7,0x93), KeyLANG4) + -- , ((0x7,0x94), KeyLANG5) + -- , ((0x7,0x95), KeyLANG6) + -- , ((0x7,0x96), KeyLANG7) + -- , ((0x7,0x97), KeyLANG8) + -- , ((0x7,0x98), KeyLANG9) + -- , ((0x7,0x99), KeyAlternateErase) + -- , ((0x7,0x9A), KeySysReqOrAttention) + , ((0x7,0x9B), KeyCancel) + -- , ((0x7,0x9C), KeyClear) + -- , ((0x7,0x9D), KeyPrior) + -- , ((0x7,0x9E), KeyReturn) + -- , ((0x7,0x9F), KeySeparator) + -- , ((0x7,0xA0), KeyOut) + -- , ((0x7,0xA1), KeyOper) + -- , ((0x7,0xA2), KeyClearOrAgain) + -- , ((0x7,0xA3), KeyCrSelOrProps) + -- , ((0x7,0xA4), KeyExSel) + -- (0x7,0xA5) - (0x7,0xDF) Reserved + , ((0x7,0xE0), KeyLeftCtrl) + , ((0x7,0xE1), KeyLeftShift) + , ((0x7,0xE2), KeyLeftAlt) + , ((0x7,0xE3), KeyLeftMeta) + , ((0x7,0xE4), KeyRightCtrl) + , ((0x7,0xE5), KeyRightShift) + , ((0x7,0xE6), KeyRightAlt) + , ((0x7,0xE7), KeyRightMeta) + -- (0x7,0xE8) - (0x7,0xFFFF) Reserved + , ((0xC,0xB5), KeyNextSong) + , ((0xC,0xB6), KeyPreviousSong) + , ((0xC,0xCD), KeyPlayPause) + , ((0xC,0xCF), KeyDictation) + , ((0xFF,0x3), KeyFn) + , ((0xFF,0x4), KeyBrightnessUp) + , ((0xFF,0x5), KeyBrightnessDown) + , ((0xFF,0x8), KeyKbdIllumUp) + , ((0xFF,0x9), KeyKbdIllumDown) + , ((0xFF01,0x1), KeySpotlight) + , ((0xFF01,0x4), KeyLaunchpad) + , ((0xFF01,0x10), KeyMissionCtrl) ] diff --git a/src/KMonad/Keyboard/IO/Windows/SendEventSink.hs b/src/KMonad/Keyboard/IO/Windows/SendEventSink.hs --- a/src/KMonad/Keyboard/IO/Windows/SendEventSink.hs +++ b/src/KMonad/Keyboard/IO/Windows/SendEventSink.hs @@ -29,36 +29,73 @@ -------------------------------------------------------------------------------- -foreign import ccall "sendKey" - sendKey :: Ptr WinKeyEvent -> IO () +foreign import ccall "sendKey" sendKey :: Ptr WinKeyEvent -> IO () + + + -- | The SKSink environment data SKSink = SKSink - { _buffer :: Ptr WinKeyEvent -- ^ The pointer we write events to + { _buffer :: MVar (Ptr WinKeyEvent) -- ^ The pointer we write events to + , _keyrep :: MVar (Maybe (Keycode, Async ())) + , _delay :: Int -- ^ How long to wait before starting key repeat in ms + , _rate :: Int -- ^ How long to wait between key repeats in ms } makeClassy ''SKSink -- | Return a 'KeySink' using Window's @sendEvent@ functionality. -sendEventKeySink :: HasLogFunc e => RIO e (Acquire KeySink) -sendEventKeySink = mkKeySink skOpen skClose skSend +sendEventKeySink :: HasLogFunc e => Maybe (Int, Int) -> RIO e (Acquire KeySink) +sendEventKeySink di = mkKeySink (skOpen (fromMaybe (300, 100) di)) skClose skSend -- | Create the 'SKSink' environment -skOpen :: HasLogFunc e => RIO e SKSink -skOpen = do +skOpen :: HasLogFunc e => (Int, Int) -> RIO e SKSink +skOpen (d, i) = do logInfo "Initializing Windows key sink" - liftIO $ SKSink <$> mallocBytes (sizeOf (undefined :: WinKeyEvent)) + bv <- liftIO $ mallocBytes (sizeOf (undefined :: WinKeyEvent)) + bm <- newMVar bv + r <- newMVar Nothing + pure $ SKSink bm r d i -- | Close the 'SKSink' environment skClose :: HasLogFunc e => SKSink -> RIO e () -skClose sk = do +skClose s = do logInfo "Closing Windows key sink" - liftIO . free $ sk^.buffer + withMVar (s^.keyrep) $ \r -> maybe (pure ()) cancel (r^?_Just._2) + withMVar (s^.buffer) (liftIO . free) +-- | Send 1 key event to Windows +emit :: MonadUnliftIO m => SKSink -> WinKeyEvent -> m () +emit s w = withMVar (s^.buffer) $ \b -> liftIO $ poke b w >> sendKey b + -- | 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 +skSend s e = do + + w <- either throwIO pure $ toWinKeyEvent e -- the event for windows + r <- takeMVar $ s^.keyrep -- the keyrep token + + -- Whether this keycode is currently active in key-repeat + let beingRepped = Just (e^.keycode) == (r^?_Just._1) + + -- When we're going to emit a press we are not already repeating + let handleNewPress = do + maybe (pure ()) cancel (r^?_Just._2) + emit s w + a <- async $ do + threadDelay (1000 * s^.delay) + forever $ emit s w >> threadDelay (1000 * s^.rate) + pure $ Just (e^.keycode, a) + + -- When the event is a release + let handleRelease = do + when beingRepped $ maybe (pure ()) cancel (r^?_Just._2) + emit s w + pure $ if beingRepped then Nothing else r + + -- Perform the correct action and store the rep-env + newRep <- if | isPress e && not beingRepped -> handleNewPress + | isRelease e -> handleRelease + | otherwise -> pure r + putMVar (s^.keyrep) newRep diff --git a/src/KMonad/Keyboard/IO/Windows/Types.hs b/src/KMonad/Keyboard/IO/Windows/Types.hs --- a/src/KMonad/Keyboard/IO/Windows/Types.hs +++ b/src/KMonad/Keyboard/IO/Windows/Types.hs @@ -90,12 +90,11 @@ -- | Lookup the corresponding 'Keycode' for this 'WinKeycode' fromWinKeycode :: WinKeycode -> Maybe Keycode -fromWinKeycode = flip M.lookup kcMap +fromWinKeycode = flip M.lookup winCodeToKeyCode -- | 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 +toWinKeycode = flip M.lookup keyCodeToWinCode -- | Convert a 'KeyEvent' to a 'WinKeyEvent' -- @@ -120,16 +119,22 @@ -------------------------------------------------------------------------------- -- $kc --- | Windows does not use the same keycodes as Linux, so we need to translate. +-- | Translate a virtual-key code from Windows into a suitable KMonad KeyCode -- -- 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 $ +winCodeToKeyCode :: M.HashMap WinKeycode Keycode +winCodeToKeyCode = M.fromList [ (0x00, Missing254) -- Not documented, but happens often. Why?? + -- , (0x01, ???) -- Defined as VK_LBUTTON + -- , (0x02, ???) -- Defined as VK_RBUTTON + , (0x03, KeyCancel) + -- , (0x04, ???) -- Defined as VK_MBUTTON + -- , (0x05, ???) -- Defined as VK_XBUTTON1 + -- , (0x06, ???) -- Defined as VK_XBUTTON2 , (0x08, KeyBackspace) , (0x09, KeyTab) - , (0x0C, KeyKp5) -- VK_CLEAR: NumPad 5 when numlock is not engaged + , (0x0C, KeyDelete) -- Defined as VK_CLEAR , (0x0D, KeyEnter) , (0x10, KeyLeftShift) -- No 'sidedness'?? , (0x11, KeyLeftCtrl) -- No 'sidedness'?? @@ -137,12 +142,14 @@ , (0x13, KeyPause) , (0x14, KeyCapsLock) , (0x15, KeyKatakana) -- Also: KeyHangul + -- , (0x16, ???) -- Defined as VK_IME_ON -- , (0x17, ???) -- Defined as VK_JUNJA - -- , (0x18, ???) -- Defined as VK_HANJA - -- , (0x19, ???) -- Defined as VK_KANJI + -- , (0x18, ???) -- Defined as VK_FINAL + , (0x19, KeyHanja) + -- , (0x1A, ???) -- Defined as VK_IME_OFF , (0x1B, KeyEsc) - -- , (0x1C, ???) -- Defined as VK_CONVERT - -- , (0x1D, ???) -- Defined as VK_NONCONVERT + , (0x1C, KeyHenkan) -- Defined as VK_CONVERT + , (0x1D, KeyMuhenkan) -- Defined as VK_NONCONVERT -- , (0x1E, ???) -- Defined as VK_ACCEPT -- , (0x1F, ???) -- Defined as VK_MODECHANGE , (0x20, KeySpace) @@ -155,9 +162,9 @@ , (0x27, KeyRight) , (0x28, KeyDown) -- , (0x29, ???) -- Defined as VK_SELECT - , (0x2A, KeyPrint) + -- , (0x2A, ???) -- Defined as VK_PRINT (legacy PrintScreen) -- , (0x2B, ???) -- Defined as VK_EXECUTE - , (0x2C, KeyPrint) -- Defined as VK_PRINT_SCREEN + , (0x2C, KeyPrint) -- Defined as VK_PRINT_SCREEN / VK_SNAPSHOT , (0x2D, KeyInsert) , (0x2E, KeyDelete) , (0x2F, KeyHelp) @@ -249,13 +256,13 @@ , (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 + , (0xA6, KeyBack) + , (0xA7, KeyForward) + , (0xA8, KeyRefresh) + , (0xA9, KeyStop) + , (0xAA, KeySearch) -- , (0xAB, ???) -- Defined as VK_BROWSER_FAVORITES - -- , (0xAC, ???) -- Defined as VK_BROWSER_HOME + , (0xAC, KeyHomepage) , (0xAD, KeyMute) , (0xAE, KeyVolumeDown) , (0xAF, KeyVolumeUp) @@ -265,8 +272,8 @@ , (0xB3, KeyPlayPause) , (0xB4, KeyMail) , (0xB5, KeyMedia) - -- , (0xB6, ???) -- Defined as VK_LAUNCH_APP1 - -- , (0xB7, ???) -- Defined as VK_LAUNCH_APP2 + , (0xB6, KeyProg1) -- Defined as VK_LAUNCH_APP1 + , (0xB7, KeyProg2) -- 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 @@ -274,6 +281,7 @@ , (0xBE, KeyDot) -- Defined as VK_OEM_PERIOD , (0xBF, KeySlash) -- Defined as VK_OEM_2 , (0xC0, KeyGrave) -- Defined as VK_OEM_3 + , (0xC1, KeyRo) , (0xDB, KeyLeftBrace) -- Defined as VK_OEM_4 , (0xDC, KeyBackslash) -- Defined as VK_OEM_5 , (0xDD, KeyRightBrace) -- Defined as VK_OEM_6 @@ -283,7 +291,7 @@ , (0xE2, Key102nd) -- , (0xE3, ???) -- Defined as `OEM specific` -- , (0xE4, ???) -- Defined as `OEM specific` - -- , (0xE5, ???) -- Defined as OEM PROCESS key + -- , (0xE5, ???) -- Defined as VK_PROCESSKEY -- , (0xE6, ???) -- Defined as `OEM specific` -- , (0xE7, ???) -- Defined as VK_PACKET -- , (0xE9, ???) -- Defined as `OEM specific` @@ -307,6 +315,270 @@ -- , (0xFB, ???) -- Defined as VK_ZOOM -- , (0xFC, ???) -- Defined as VK_NONAME -- , (0xFD, ???) -- Defined as VK_PA1 - -- , (0xFE, ???) -- Defined as VK_CLEAR + -- , (0xFE, KeyDelete) -- Defined as VK_OEM_CLEAR ] +-- | Translate a KMonad KeyCode to the corresponding Windows virtual-key code +-- +-- We cannot simply reverse the above map for the opposite direction, because +-- there will be duplicates where more than one virtual-key code produces the +-- same KMonad KeyCode. See https://github.com/kmonad/kmonad/issues/326 +keyCodeToWinCode :: M.HashMap Keycode WinKeycode +keyCodeToWinCode = M.fromList + [ -- (KeyReserved, ???) + (KeyEsc, 0x1B) + , (Key1, 0x31) + , (Key2, 0x32) + , (Key3, 0x33) + , (Key4, 0x34) + , (Key5, 0x35) + , (Key6, 0x36) + , (Key7, 0x37) + , (Key8, 0x38) + , (Key9, 0x39) + , (Key0, 0x30) + , (KeyMinus, 0xBD) + , (KeyEqual, 0xBB) + , (KeyBackspace, 0x08) + , (KeyTab, 0x09) + , (KeyQ, 0x51) + , (KeyW, 0x57) + , (KeyE, 0x45) + , (KeyR, 0x52) + , (KeyT, 0x54) + , (KeyY, 0x59) + , (KeyU, 0x55) + , (KeyI, 0x49) + , (KeyO, 0x4F) + , (KeyP, 0x50) + , (KeyLeftBrace, 0xDB) + , (KeyRightBrace, 0xDD) + , (KeyEnter, 0x0D) + , (KeyLeftCtrl, 0xA2) + , (KeyA, 0x41) + , (KeyS, 0x53) + , (KeyD, 0x44) + , (KeyF, 0x46) + , (KeyG, 0x47) + , (KeyH, 0x48) + , (KeyJ, 0x4A) + , (KeyK, 0x4B) + , (KeyL, 0x4C) + , (KeySemicolon, 0xBA) + , (KeyApostrophe, 0xDE) + , (KeyGrave, 0xC0) + , (KeyLeftShift, 0xA0) + , (KeyBackslash, 0xDC) + , (KeyZ, 0x5A) + , (KeyX, 0x58) + , (KeyC, 0x43) + , (KeyV, 0x56) + , (KeyB, 0x42) + , (KeyN, 0x4E) + , (KeyM, 0x4D) + , (KeyComma, 0xBC) + , (KeyDot, 0xBE) + , (KeySlash, 0xBF) + , (KeyRightShift, 0xA1) + , (KeyKpAsterisk, 0x6A) + , (KeyLeftAlt, 0xA4) + , (KeySpace, 0x20) + , (KeyCapsLock, 0x14) + , (KeyF1, 0x70) + , (KeyF2, 0x71) + , (KeyF3, 0x72) + , (KeyF4, 0x73) + , (KeyF5, 0x74) + , (KeyF6, 0x75) + , (KeyF7, 0x76) + , (KeyF8, 0x77) + , (KeyF9, 0x78) + , (KeyF10, 0x79) + , (KeyNumLock, 0x90) + , (KeyScrollLock, 0x91) + , (KeyKp7, 0x67) + , (KeyKp8, 0x68) + , (KeyKp9, 0x69) + , (KeyKpMinus, 0x6D) + , (KeyKp4, 0x64) + , (KeyKp5, 0x65) + , (KeyKp6, 0x66) + , (KeyKpPlus, 0x6B) + , (KeyKp1, 0x61) + , (KeyKp2, 0x62) + , (KeyKp3, 0x63) + , (KeyKp0, 0x60) + , (KeyKpDot, 0x6E) + -- , (Missing84, ???) + -- , (KeyZenkakuHankaku, ???) + , (Key102nd, 0xE2) + , (KeyF11, 0x7A) + , (KeyF12, 0x7B) + , (KeyRo, 0xC1) + , (KeyKatakana, 0x15) + -- , (KeyHiragana, ???) + , (KeyHenkan, 0x1C) + , (KeyKatakanaHiragana, 0x15) + , (KeyMuhenkan, 0x1D) + -- , (KeyKpjpcomma, ???) + , (KeyKpEnter, 0x0D) + , (KeyRightCtrl, 0xA3) + , (KeyKpSlash, 0x6F) + -- , (KeySysRq, ???) + , (KeyRightAlt, 0xA5) + -- , (KeyLinefeed, ???) + , (KeyHome, 0x24) + , (KeyUp, 0x26) + , (KeyPageUp, 0x21) + , (KeyLeft, 0x25) + , (KeyRight, 0x27) + , (KeyEnd, 0x23) + , (KeyDown, 0x28) + , (KeyPageDown, 0x22) + , (KeyInsert, 0x2D) + , (KeyDelete, 0x2E) + -- , (KeyMacro, ???) + , (KeyMute, 0xAD) + , (KeyVolumeDown, 0xAE) + , (KeyVolumeUp, 0xAF) + -- , (KeyPower, ???) + -- , (KeyKpEqual, ???) + -- , (KeyKpPlusMinus, ???) + , (KeyPause, 0x13) + -- , (KeyScale, ???) + -- , (KeyKpComma, ???) + , (KeyHangeul, 0x15) + , (KeyHanja, 0x19) + -- , (KeyYen, ???) + , (KeyLeftMeta, 0x5B) + , (KeyRightMeta, 0x5C) + , (KeyCompose, 0x5D) + , (KeyStop, 0xA9) + -- , (KeyAgain, ???) + -- , (KeyProps, ???) + -- , (KeyUndo, ???) + -- , (KeyFront, ???) + -- , (KeyCopy, ???) + -- , (KeyOpen, ???) + -- , (KeyPaste, ???) + -- , (KeyFind, ???) + -- , (KeyCut, ???) + , (KeyHelp, 0x2F) + , (KeyMenu, 0x5D) + -- , (KeyCalc, ???) + -- , (KeySetup, ???) + , (KeySleep, 0x5F) + -- , (KeyWakeUp, ???) + -- , (KeyFile, ???) + -- , (KeySendFile, ???) + -- , (KeyDeleteFile, ???) + -- , (KeyXfer, ???) + -- , (KeyProg1, ???) + -- , (KeyProg2, ???) + -- , (KeyWww, ???) + -- , (KeyMsDos, ???) + -- , (KeyCoffee, ???) + -- , (KeyDirection, ???) + -- , (KeyCycleWindows, ???) + , (KeyMail, 0xB4) + -- , (KeyBookmarks, ???) + -- , (KeyComputer, ???) + , (KeyBack, 0xA6) + , (KeyForward, 0xA7) + -- , (KeyCloseCd, ???) + -- , (KeyEjectCd, ???) + -- , (KeyEjectCloseCd, ???) + , (KeyNextSong, 0xB0) + , (KeyPlayPause, 0xB3) + , (KeyPreviousSong, 0xB1) + , (KeyStopCd, 0xB2) + -- , (KeyRecord, ???) + -- , (KeyRewind, ???) + -- , (KeyPhone, ???) + -- , (KeyIso, ???) + -- , (KeyConfig, ???) + , (KeyHomepage, 0xAC) + , (KeyRefresh, 0xA8) + -- , (KeyExit, ???) + -- , (KeyMove, ???) + -- , (KeyEdit, ???) + -- , (KeyScrollUp, ???) + -- , (KeyScrollDown, ???) + -- , (KeyKpLeftParen, ???) + -- , (KeyKpRightParen, ???) + -- , (KeyNew, ???) + -- , (KeyRedo, ???) + , (KeyF13, 0x7C) + , (KeyF14, 0x7D) + , (KeyF15, 0x7E) + , (KeyF16, 0x7F) + , (KeyF17, 0x80) + , (KeyF18, 0x81) + , (KeyF19, 0x82) + , (KeyF20, 0x83) + , (KeyF21, 0x84) + , (KeyF22, 0x85) + , (KeyF23, 0x86) + , (KeyF24, 0x87) + -- , (Missing195, ???) + -- , (Missing196, ???) + -- , (Missing197, ???) + -- , (Missing198, ???) + -- , (Missing199, ???) + -- , (KeyPlayCd, ???) + -- , (KeyPauseCd, ???) + -- , (KeyProg3, ???) + -- , (KeyProg4, ???) + -- , (KeyDashboard, ???) + -- , (KeySuspend, ???) + -- , (KeyClose, ???) + , (KeyPlay, 0xFA) + --, (KeyFastForward, ???) + --, (KeyBassBoost, ???) + , (KeyPrint, 0x2C) + -- , (KeyHp, ???) + -- , (KeyCamera, ???) + -- , (KeySound, ???) + -- , (KeyQuestion, ???) + , (KeyEmail, 0xB4) + -- , (KeyChat, ???) + , (KeySearch, 0xAA) + -- , (KeyConnect, ???) + -- , (KeyFinance, ???) + -- , (KeySport, ???) + -- , (KeyShop, ???) + -- , (KeyAlterase, ???) + , (KeyCancel, 0x03) + -- , (KeyBrightnessDown, ???) + -- , (KeyBrightnessUp, ???) + , (KeyMedia, 0xB5) + -- , (KeySwitchVideoMode, ???) + -- , (KeyKbdIllumToggle, ???) + -- , (KeyKbdIllumDown, ???) + -- , (KeyKbdIllumUp, ???) + -- , (KeySend, ???) + -- , (KeyReply, ???) + -- , (KeyForwardMail, ???) + -- , (KeySave, ???) + -- , (KeyDocuments, ???) + -- , (KeyBattery, ???) + -- , (KeyBluetooth, ???) + -- , (KeyWlan, ???) + -- , (KeyUwb, ???) + -- , (KeyUnknown, ???) + , (KeyVideoNext, 0xB0) + , (KeyVideoPrev, 0xB1) + -- , (KeyBrightnessCycle, ???) + -- , (KeyBrightnessZero, ???) + -- , (KeyDisplayOff, ???) + -- , (KeyWimax, ???) + -- , (Missing247, ???) + -- , (Missing248, ???) + -- , (Missing249, ???) + -- , (Missing250, ???) + -- , (Missing251, ???) + -- , (Missing252, ???) + -- , (Missing253, ???) + -- , (Missing254, ???) + -- , (Missing255, ???) + ] diff --git a/src/KMonad/Keyboard/Keycode.hs b/src/KMonad/Keyboard/Keycode.hs --- a/src/KMonad/Keyboard/Keycode.hs +++ b/src/KMonad/Keyboard/Keycode.hs @@ -25,7 +25,7 @@ import KMonad.Prelude -import qualified Data.MultiMap as Q +import qualified KMonad.Util.MultiMap as Q import qualified RIO.HashSet as S import qualified RIO.Text as T import qualified RIO.Text.Partial as T (head) @@ -305,9 +305,8 @@ | KeyFn | KeyLaunchpad | KeyMissionCtrl - | KeyBacklightDown - | KeyBacklightUp - | KeyError + | KeySpotlight + | KeyDictation #endif deriving (Eq, Show, Bounded, Enum, Ord, Generic, Hashable) @@ -326,7 +325,7 @@ -- | The set of all existing 'Keycode' kcAll :: S.HashSet Keycode -kcAll = S.fromList $ [minBound .. maxBound] +kcAll = S.fromList [minBound .. maxBound] -- | The set of all 'Keycode' that are not of the MissingXX pattern kcNotMissing :: S.HashSet Keycode @@ -378,10 +377,11 @@ , (KeyRightMeta, ["rmeta", "rmet"]) , (KeyBackspace, ["bks", "bspc"]) , (KeyCapsLock, ["caps"]) - , (KeyGrave, ["grv"]) - , (Key102nd, ["102d"]) + , (Key102nd, ["102d", "lsgt", "nubs"]) , (KeyForward, ["fwd"]) , (KeyScrollLock, ["scrlck", "slck"]) + , (KeyScrollUp, ["scrup", "sup"]) + , (KeyScrollDown, ["scrdn", "sdwn", "sdn"]) , (KeyPrint, ["prnt"]) , (KeyWakeUp, ["wkup"]) , (KeyLeft, ["lft"]) @@ -389,7 +389,7 @@ , (KeyLeftBrace, ["lbrc", "["]) , (KeyRightBrace, ["rbrc", "]"]) , (KeySemicolon, ["scln", ";"]) - , (KeyApostrophe, ["apos", "'"]) + , (KeyApostrophe, ["apos", "'", "apo"]) , (KeyGrave, ["grv", "`"]) , (KeyBackslash, ["bksl", "\\"]) -- NOTE: "\\" here is a 1char string, the first \ is consumed by Haskell as an escape character , (KeyComma, ["comm", ","]) @@ -403,10 +403,15 @@ , (KeyKpMinus, ["kp-"]) , (KeyKpDot, ["kp."]) , (KeySysRq, ["ssrq", "sys"]) + , (KeyKbdIllumDown, ["bldn"]) + , (KeyKbdIllumUp, ["blup"]) + , (KeyNextSong, ["next"]) + , (KeyPlayPause, ["pp"]) + , (KeyPreviousSong, ["prev"]) #ifdef darwin_HOST_OS , (KeyLaunchpad, ["lp"]) , (KeyMissionCtrl, ["mctl"]) - , (KeyBacklightDown, ["bldn"]) - , (KeyBacklightUp, ["blup"]) + , (KeySpotlight, ["spot"]) + , (KeyDictation, ["dict"]) #endif ] diff --git a/src/KMonad/Keyboard/Ops.hs b/src/KMonad/Keyboard/Ops.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/Keyboard/Ops.hs @@ -0,0 +1,49 @@ +module KMonad.Keyboard.Ops + ( switch + , keycode + , mkKeyEvent + , mkPress + , mkRelease + + -- * Predicates + , isPress + , isRelease + , isKeycode + , isPressOf + , isReleaseOf + ) +where + +import KMonad.Prelude +import KMonad.Keyboard.Types +import KMonad.Keyboard.Keycode + + + +-- | Create a 'KeyEvent' that represents pressing a key +mkPress :: Keycode -> KeyEvent +mkPress = mkKeyEvent Press + +-- | Create a 'KeyEvent' that represents releaseing a key +mkRelease :: Keycode -> KeyEvent +mkRelease = mkKeyEvent Release + +-- | 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 diff --git a/src/KMonad/Keyboard/Types.hs b/src/KMonad/Keyboard/Types.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/Keyboard/Types.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE DeriveAnyClass #-} +module KMonad.Keyboard.Types + ( + Switch(..) + , KeyEvent + , mkKeyEvent + , HasKeyEvent(..) + , KeyPred + , LayerTag + , LMap + ) +where + +import KMonad.Prelude +import KMonad.Keyboard.Keycode + +import qualified KMonad.Util.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) +makeClassy ''KeyEvent + +-- | Create a new 'KeyEvent' from a 'Switch' and a 'Keycode' +mkKeyEvent :: Switch -> Keycode -> KeyEvent +mkKeyEvent = 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 + + +-- | Predicate on KeyEvent's +type KeyPred = KeyEvent -> Bool + +-------------------------------------------------------------------------------- +-- $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/Model.hs b/src/KMonad/Model.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/Model.hs @@ -0,0 +1,7 @@ +module KMonad.Model + ( module X ) +where + +import KMonad.Model.Action as X +import KMonad.Model.Button as X +import KMonad.Model.BEnv as X diff --git a/src/KMonad/Model/Action.hs b/src/KMonad/Model/Action.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/Model/Action.hs @@ -0,0 +1,243 @@ +{-| +Module : KMonad.Model.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.Model.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.Model.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 $> 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 $> 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 $> 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/Model/BEnv.hs b/src/KMonad/Model/BEnv.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/Model/BEnv.hs @@ -0,0 +1,63 @@ +{-| +Module : KMonad.Model.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.Model.BEnv + ( BEnv(..) + , HasBEnv(..) + , initBEnv + , runBEnv + ) +where + +import KMonad.Prelude + +import KMonad.Model.Action +import KMonad.Model.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/Model/Button.hs b/src/KMonad/Model/Button.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/Model/Button.hs @@ -0,0 +1,497 @@ +{-| +Module : KMonad.Model.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.Model.Button + ( -- * Button basics + -- $but + Button + , HasButton(..) + , onPress + , onRelease + , mkButton + , around + , tapOn + + -- * Simple buttons + -- $simple + , emitB + , pressOnly + , releaseOnly + , modded + , layerToggle + , layerSwitch + , layerAdd + , layerRem + , pass + , cmdButton + + -- * Button combinators + -- $combinators + , aroundNext + , aroundNextTimeout + , aroundNextSingle + , beforeAfterNext + , layerDelay + , layerNext + , tapHold + , multiTap + , tapNext + , tapHoldNext + , tapNextRelease + , tapHoldNextRelease + , tapNextPress + , tapMacro + , tapMacroRelease + , stickyKey + ) +where + +import KMonad.Prelude + +import KMonad.Model.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 () + +onRelease :: AnyK () -> Button +onRelease = mkButton (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) + +-- | A button that emits only a Press of a keycode. +pressOnly :: Keycode -> Button +pressOnly c = onPress $ emit $ mkPress c + +-- | A button that emits only a Release of a keycode. +releaseOnly :: Keycode -> Button +releaseOnly c = onPress $ 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 and possibly on +-- release +cmdButton :: Text -> Maybe Text -> Button +cmdButton pr mbR = mkButton (shellCmd pr) (maybe (pure ()) shellCmd mbR) + +-------------------------------------------------------------------------------- +-- $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 + +-- | A 'Button' that, once pressed, will surround the next button within some timeout with another. +-- +-- If some other key is not pressed within an interval another button will be triggered as a tap. +aroundNextTimeout :: + Milliseconds -- ^ How long before we tap + -> Button -- ^ The 'Button' to use to surround next + -> Button -- ^ The 'Button' to tap on timeout + -> Button -- ^ The resulting button +aroundNextTimeout d b t = onPress $ within d (pure isPress) (tap t) $ \trig -> do + runAction $ b^.pressAction + await (isReleaseOf $ trig^.event.keycode) $ \_ -> do + runAction $ b^.releaseAction + pure NoCatch + pure NoCatch + +-- | 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-. +-- +-- This differs from 'aroundNext' in that it explicitly releases the modifier +-- immediately after the first event, where `aroundSingle` waits around for the +-- original key that was modified to be released itself. +aroundNextSingle :: + Button -- ^ The outer 'Button' + -> Button -- ^ The resulting 'Button' +aroundNextSingle b = onPress $ await isPress $ \_ -> do + runAction $ b^.pressAction + -- Wait for the next *event*, regardless of what it is + await (pure True) $ \_ -> 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 $> 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 $> Catch + else press h $> NoCatch + +-- | Like 'tapNext', except that after some interval it switches anyways +tapHoldNext :: Milliseconds -> Button -> Button -> Maybe Button -> Button +tapHoldNext ms t h mtb = onPress $ within ms (pure $ const True) onTimeout $ \tr -> do + p <- matchMy Release + if p $ tr^.event + then tap t $> Catch + else press h $> NoCatch + where + onTimeout :: MonadK m => m () + onTimeout = press $ fromMaybe h mtb + +-- | Surround some future button with a before and after tap +beforeAfterNext :: Button -> Button -> Button +beforeAfterNext b a = onPress $ do + tap b + await isPress $ \e -> do + await (isReleaseOf $ e^.keycode) $ \_ -> do + tap a + pure NoCatch + 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) $> NoCatch + -- Else, if it is a release of some button held before me, just ignore + | otherwise -> go ks $> NoCatch + + -- Behave like a tap is simple: tap the button `t` and release processing + doTap :: MonadK m => m Catch + doTap = tap t *> hold False $> 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 $> 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 the +-- specified timeout button, or to the hold button if none is specified. +-- +-- 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 -> Maybe Button -> Button +tapHoldNextRelease ms t h mtb = 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) $> NoCatch + -- If the next event is a release of some button pressed before me, recurse + | otherwise -> go (ms' - r^.elapsed) ks $> NoCatch + + onTimeout :: MonadK m => m () + onTimeout = press (fromMaybe h mtb) *> hold False + + onRelSelf :: MonadK m => m Catch + onRelSelf = tap t *> hold False $> Catch + + onRelOther :: MonadK m => KeyEvent -> m Catch + onRelOther e = press h *> hold False *> inject e $> Catch + +-- | Create a button just like tap-release, but also trigger a hold on presses: +-- 1. It is the release of this button: We are tapping +-- 2. It is the press of some other button, we hold +-- 3. It is the release of some other button, ignore. +tapNextPress :: Button -> Button -> Button +tapNextPress t h = onPress go + where + go :: MonadK m => m () + go = hookF InputHook $ \e -> do + p <- matchMy Release + if + -- If the next event is my own release: we act as if we were tapped + | p e -> doTap + -- If the next event is a press: we act as if we were held + | isPress e -> doHold e + -- Else, if it is a release of some other button, just ignore + | otherwise -> go $> NoCatch + + -- Behave like a tap + doTap :: MonadK m => m Catch + doTap = tap t $> Catch + + -- Behave like a hold: + -- We catch the event of ButtonX that triggered this action, and then + -- we rethrow this event after holding. + doHold :: MonadK m => KeyEvent -> m Catch + doHold e = press h *> inject e $> 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 an event + -- 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 of the key that triggered this action, + -- we must now keep waiting to detect another press. + -- 2C. If we detect another (unrelated) press event we cancel the + -- remaining of the multi-tap sequence and trigger a tap on the + -- current button of the sequence. + -- 3A. After 2B, if we do not detect a press before the interval is up, + -- we know a tap occurred, so we tap the current button and we are + -- done. + -- 3B. If we detect another press of the same key, then the user is + -- descending into the buttons tied to this multi-tap, so we recurse + -- on the remaining buttons. + -- 3C. If we detect any other (unrelated) press event, then the multi-tap + -- sequence is cancelled like in 2C. We trigger a tap of the current + -- button of the sequence. + let doNext pred onTimeout next ms = tHookF InputHook ms onTimeout $ \t -> do + pr <- pred + if | pr (t^.event) -> next (ms - t^.elapsed) $> Catch + | isPress (t^.event) -> tap b $> NoCatch + | otherwise -> pure NoCatch + doNext (matchMy Release) + (press b) + (doNext (matchMy Press) (tap b) (\_ -> go bs')) + ms + +-- | 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 + +-- | Create a 'Button' that performs a series of taps on press, +-- except for the last Button, which is tapped on release. +tapMacroRelease :: [Button] -> Button +tapMacroRelease bs = onPress $ go bs + where + go [] = pure () + go [b] = awaitMy Release $ tap b >> pure Catch + 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) $> NoCatch) + +-- | Make a button into a sticky-key, i.e. a key that acts like it is +-- pressed for the button after it if that button was pressed in the +-- given timeframe. +stickyKey :: Milliseconds -> Button -> Button +stickyKey ms b = onPress go + where + go :: MonadK m => m () + go = hookF InputHook $ \e -> do + p <- matchMy Release + if | p e -> doTap $> Catch + -- My own release; we act as if we were tapped + | not (isRelease e) -> doHold e $> Catch + -- The press of another button; act like we are held down + | otherwise -> go $> NoCatch + -- The release of some other button; ignore these + + doHold :: MonadK m => KeyEvent -> m () + doHold e = press b *> inject e + + doTap :: MonadK m => m () + doTap = + within ms + (pure isPress) -- presses definitely happen after us + (pure ()) + (\t -> runAction (b^.pressAction) + *> inject (t^.event) + *> after 3 (runAction $ b^.releaseAction) + $> Catch) diff --git a/src/KMonad/Model/Dispatch.hs b/src/KMonad/Model/Dispatch.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/Model/Dispatch.hs @@ -0,0 +1,114 @@ +{- +Module : KMonad.Model.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.Model.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 <- newEmptyTMVarIO + rrb <- newTVarIO 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/Model/Hooks.hs b/src/KMonad/Model/Hooks.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/Model/Hooks.hs @@ -0,0 +1,199 @@ +{-| +Module : KMonad.Model.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.Model.Hooks + ( Hooks + , mkHooks + , pull + , register + ) +where + +import KMonad.Prelude + +import Data.Time.Clock.System +import Data.Unique + +import KMonad.Model.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 <- newEmptyTMVarIO + hks <- newTVarIO 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/Model/Keymap.hs b/src/KMonad/Model/Keymap.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/Model/Keymap.hs @@ -0,0 +1,124 @@ +{-| +Module : KMonad.Model.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.Model.Keymap + ( Keymap + , mkKeymap + , layerOp + , lookupKey + ) +where + + +import KMonad.Prelude + +import KMonad.Model.Action hiding (layerOp) +import KMonad.Model.Button +import KMonad.Keyboard +import KMonad.Model.BEnv + +import qualified KMonad.Util.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 + (readIORef km <&> Ls.pushLayer n) >>= \case + Left e -> throwIO e + Right m' -> writeIORef km m' + debugReport h $ "Pushed layer to stack: " <> display n + + (PopLayer n) -> do + (readIORef km <&> Ls.popLayer n) >>= \case + Left (Ls.LayerNotOnStack _) -> do + debugReport h $ "WARNING: Tried popping layer that was not on stack " <> display n + Left e -> throwIO e + Right m' -> do + writeIORef km m' + debugReport h $ "Popped layer from stack: " <> display n + + (SetBaseLayer n) -> do + (readIORef km <&> (view Ls.maps >>> (n `elem`))) >>= \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/Model/Sluice.hs b/src/KMonad/Model/Sluice.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/Model/Sluice.hs @@ -0,0 +1,119 @@ +{-| +Module : KMonad.Model.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.Model.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.Model.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/Parsing.hs b/src/KMonad/Parsing.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/Parsing.hs @@ -0,0 +1,57 @@ +-- | A collection of general parsing definitions + +module KMonad.Parsing + ( Parser + , ParserT + , ParseError(..) + + , sc + , hsc + , lex + , hlex + + , module Text.Megaparsec + , module Text.Megaparsec.Char + ) + +where + +import KMonad.Prelude + +import Text.Megaparsec hiding (ParseError) +import Text.Megaparsec.Char +import qualified Text.Megaparsec.Char.Lexer as X + + +-------------------------------------------------------------------------------- + +-- | Parsec type specified down to Void Text +type Parser a = Parsec Void Text a +type ParserT m a = ParsecT Void Text m a + +-- | Parsec parse errors under Void Text with an Exception instance +newtype ParseError = ParseError { _parseError :: ParseErrorBundle Text Void} + deriving Eq + +instance Show ParseError where + show (ParseError e) = "Parse error at " <> errorBundlePretty e + +instance Exception ParseError + +-------------------------------------------------------------------------------- + +-- | Horizontal space consumption +hsc :: Parser () +hsc = X.space space1 empty empty + +-- | Horizontal space lexeme +hlex :: Parser a -> Parser a +hlex = X.lexeme hsc + +-- | Full space consumption +sc :: Parser () +sc = X.space space1 (X.skipLineComment ";;") (X.skipBlockComment "#|" "|#") + +-- | Full space lexeme +lex :: Parser a -> Parser a +lex = X.lexeme sc diff --git a/src/KMonad/Prelude.hs b/src/KMonad/Prelude.hs --- a/src/KMonad/Prelude.hs +++ b/src/KMonad/Prelude.hs @@ -1,37 +1,6 @@ -{-# 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 - ) +import KMonad.Prelude.Imports as X +import KMonad.Prelude.Definitions as X diff --git a/src/KMonad/Prelude/Definitions.hs b/src/KMonad/Prelude/Definitions.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/Prelude/Definitions.hs @@ -0,0 +1,7 @@ +-- | + +module KMonad.Prelude.Definitions + ( ) +where + +import KMonad.Prelude.Imports diff --git a/src/KMonad/Prelude/Imports.hs b/src/KMonad/Prelude/Imports.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/Prelude/Imports.hs @@ -0,0 +1,27 @@ +{-# OPTIONS_GHC -Wno-dodgy-imports #-} + +module KMonad.Prelude.Imports + ( 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, unpack, pack) + +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 --- a/src/KMonad/Util.hs +++ b/src/KMonad/Util.hs @@ -15,6 +15,7 @@ ( -- * Time units and utils -- $time Milliseconds + , unMS , tDiff -- * Random utility helpers that have no better home @@ -41,7 +42,7 @@ -- -- | Newtype wrapper around 'Int' to add type safety to our time values -newtype Milliseconds = Milliseconds Int +newtype Milliseconds = Milliseconds { unMS :: Int } deriving (Eq, Ord, Num, Real, Enum, Integral, Show, Read, Generic, Display) -- | Calculate how much time has elapsed between 2 time points @@ -72,7 +73,7 @@ -- | 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) +using dat = ContT (\next -> with dat $ \a -> next a) -- | Log an error message and then rethrow the error @@ -94,7 +95,7 @@ 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 + -> (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 diff --git a/src/KMonad/Util/LayerStack.hs b/src/KMonad/Util/LayerStack.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/Util/LayerStack.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-| +Module : KMonad.Util.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 KMonad.Util.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 = maybe [] 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/KMonad/Util/MultiMap.hs b/src/KMonad/Util/MultiMap.hs new file mode 100644 --- /dev/null +++ b/src/KMonad/Util/MultiMap.hs @@ -0,0 +1,85 @@ +{-| +Module : KMonad.Util.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 KMonad.Util.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/test/KMonad/GestureSpec.hs b/test/KMonad/GestureSpec.hs new file mode 100644 --- /dev/null +++ b/test/KMonad/GestureSpec.hs @@ -0,0 +1,41 @@ +module KMonad.GestureSpec ( spec ) where + +import KMonad.Prelude +import KMonad.Gesture + +import Data.Either (fromRight) + +import Test.Hspec hiding (around) + +r :: Either a b -> b +r = fromRight undefined + +spec :: Spec +spec = do + + let abc = tap "a" <> tap "b" <> tap "c" + let sa = r $ around "S" (tap "a") + let csa = r $ around "C" sa + let c = tap "C" + let sabc = r $ around "S" abc + let xx = r $ around "C" (sa <> tap "b") + + describe "gesture" $ do + + it "parses \"a b c\" as series of taps" $ do + prsGesture "a b c" `shouldBe` Right abc + + it "parses \"S-a\" as S held around tap of a" $ do + prsGesture "S-a" `shouldBe` Right sa + + it "parses \"C-S-a\" as C around S around a" $ do + prsGesture "C-S-a" `shouldBe` Right csa + + it "parses \"C-( )-C\" as the press and release of C" $ do + prsGesture "C-( )-C" `shouldBe` Right c + + it "parser \"C-(S-a b)-C\" as C around shifted-a b" $ do + prsGesture "C-(S-a b)-C" `shouldBe` Right xx + + it "parses \"S-[a b c]\" as S around taps of a b c" $ do + prsGesture "S-[a b c]" `shouldBe` Right sabc diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}