kmonad 0.4.1 → 0.4.2

raw patch · 56 files changed

+3695/−2677 lines, 56 filesdep +hspecdep +template-haskelldep ~Win32dep ~basedep ~cerealnew-uploaderPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: hspec, template-haskell

Dependency ranges changed: Win32, base, cereal, lens, megaparsec, mtl, optparse-applicative, resourcet, rio, time, unix, unliftio

API changes (from Hackage documentation)

Files

• app/Main.hs +2/−2
• c_src/mac/dext.cpp +96/−0
• c_src/mac/kext.cpp +117/−0
• c_src/mac/keyio_mac.cpp +0/−354
• changelog.md +43/−2
• kmonad.cabal +75/−28
• src/Data/LayerStack.hs +0/−155
• src/Data/MultiMap.hs +0/−85
• src/KMonad/Action.hs +0/−243
• src/KMonad/App.hs +3/−233
• src/KMonad/App/BEnv.hs +0/−63
• src/KMonad/App/Dispatch.hs +0/−114
• src/KMonad/App/Hooks.hs +0/−199
• src/KMonad/App/Keymap.hs +0/−121
• src/KMonad/App/Main.hs +175/−0
• src/KMonad/App/Sluice.hs +0/−119
• src/KMonad/App/Types.hs +149/−0
• src/KMonad/Args.hs +46/−26
• src/KMonad/Args/Cmd.hs +116/−10
• src/KMonad/Args/Joiner.hs +47/−26
• src/KMonad/Args/Parser.hs +111/−61
• src/KMonad/Args/TH.hs +30/−0
• src/KMonad/Args/Types.hs +36/−34
• src/KMonad/Button.hs +0/−355
• src/KMonad/Gesture.hs +154/−0
• src/KMonad/Keyboard.hs +7/−118
• src/KMonad/Keyboard/ComposeSeq.hs +7/−1
• src/KMonad/Keyboard/IO.hs +4/−5
• src/KMonad/Keyboard/IO/Linux/DeviceSource.hs +11/−6
• src/KMonad/Keyboard/IO/Linux/Types.hs +1/−1
• src/KMonad/Keyboard/IO/Linux/UinputSink.hs +18/−9
• src/KMonad/Keyboard/IO/Mac/IOKitSource.hs +7/−5
• src/KMonad/Keyboard/IO/Mac/KextSink.hs +1/−1
• src/KMonad/Keyboard/IO/Mac/Types.hs +216/−218
• src/KMonad/Keyboard/IO/Windows/SendEventSink.hs +51/−14
• src/KMonad/Keyboard/IO/Windows/Types.hs +295/−23
• src/KMonad/Keyboard/Keycode.hs +15/−10
• src/KMonad/Keyboard/Ops.hs +49/−0
• src/KMonad/Keyboard/Types.hs +68/−0
• src/KMonad/Model.hs +7/−0
• src/KMonad/Model/Action.hs +243/−0
• src/KMonad/Model/BEnv.hs +63/−0
• src/KMonad/Model/Button.hs +497/−0
• src/KMonad/Model/Dispatch.hs +114/−0
• src/KMonad/Model/Hooks.hs +199/−0
• src/KMonad/Model/Keymap.hs +124/−0
• src/KMonad/Model/Sluice.hs +119/−0
• src/KMonad/Parsing.hs +57/−0
• src/KMonad/Prelude.hs +2/−33
• src/KMonad/Prelude/Definitions.hs +7/−0
• src/KMonad/Prelude/Imports.hs +27/−0
• src/KMonad/Util.hs +4/−3
• src/KMonad/Util/LayerStack.hs +155/−0
• src/KMonad/Util/MultiMap.hs +85/−0
• test/KMonad/GestureSpec.hs +41/−0
• test/Spec.hs +1/−0

@@ -15,7 +15,7 @@   ) where -import KMonad.Args (run)+import qualified KMonad.App as KMonad (main)  main :: IO ()-main = run+main = KMonad.main

@@ -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<bool> 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<bool> 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<typename T>+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;+}

@@ -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<typename T>+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;+}

@@ -1,354 +0,0 @@-#include <IOKit/hid/IOHIDLib.h>-#include <IOKit/hidsystem/IOHIDShared.h>-#include <unistd.h>-#include <errno.h>-#include <thread>-#include <map>-#include <iostream>--#include "karabiner_virtual_hid_device_methods.hpp"--/*- * Key event information that's shared between C++ and Haskell.- *- * type: represents key up or key down- *- * keycode: 16 uppermost bits represent IOKit usage page- *          16 lowermost bits represent IOKit usage- */-struct KeyEvent {-    uint8_t type;-    uint32_t keycode;-};--/*- * Resources needed to post altered key events back to the OS. They- * are global so that they can be kept track of in the C++ code rather- * than in the Haskell.- */-static mach_port_t connect;-static io_service_t service;-static pqrs::karabiner_virtual_hid_device::hid_report::keyboard_input keyboard;-static pqrs::karabiner_virtual_hid_device::hid_report::apple_vendor_top_case_input top_case;-static pqrs::karabiner_virtual_hid_device::hid_report::apple_vendor_keyboard_input apple_keyboard;-static pqrs::karabiner_virtual_hid_device::hid_report::consumer_input consumer;--/*- * These are needed to receive unaltered key events from the OS.- */-static std::thread thread;-static CFRunLoopRef listener_loop;-static std::map<io_service_t,IOHIDDeviceRef> source_device;-static int fd[2];-static char *prod = nullptr;--/*- * We'll register this callback to run whenever an IOHIDDevice- * (representing a keyboard) sends input from the user.- *- * It passes the relevant information into a pipe that will be read- * from with wait_key.- */-void input_callback(void *context, IOReturn result, void *sender, IOHIDValueRef value) {-    struct KeyEvent e;-    CFIndex integer_value = IOHIDValueGetIntegerValue(value);-    IOHIDElementRef element = IOHIDValueGetElement(value);-    uint16_t usage_page = IOHIDElementGetUsagePage(element);-    uint16_t usage = IOHIDElementGetUsage(element);-    e.type = !integer_value;-    e.keycode = (usage_page << 16) | usage;-    write(fd[1], &e, sizeof(struct KeyEvent));-}--void open_matching_devices(char *product, io_iterator_t iter) {-    io_name_t name;-    kern_return_t kr;-    CFStringRef cfproduct = NULL;-    if(product) {-        cfproduct = CFStringCreateWithCString(kCFAllocatorDefault, product, CFStringGetSystemEncoding());-        if(cfproduct == NULL) {-            std::cerr << "CFStringCreateWithCString error" << std::endl;-            return;-        }-    }-    CFStringRef cfkarabiner = CFStringCreateWithCString(kCFAllocatorDefault, "Karabiner VirtualHIDKeyboard", CFStringGetSystemEncoding());-    if(cfkarabiner == NULL) {-        std::cerr << "CFStringCreateWithCString error" << std::endl;-        if(product) {-            CFRelease(cfproduct);-        }-        return;-    }-    for(mach_port_t curr = IOIteratorNext(iter); curr; curr = IOIteratorNext(iter)) {-        CFStringRef cfcurr = (CFStringRef)IORegistryEntryCreateCFProperty(curr, CFSTR(kIOHIDProductKey), kCFAllocatorDefault, kIOHIDOptionsTypeNone);-        if(cfcurr == NULL) {-            std::cerr << "IORegistryEntryCreateCFProperty error" << std::endl;-            CFRelease(cfcurr);-            continue;-        }-        bool match = (CFStringCompare(cfcurr, cfkarabiner, 0) != kCFCompareEqualTo);-        if(product) {-            match = match && (CFStringCompare(cfcurr, cfproduct, 0) == kCFCompareEqualTo);-        }-        CFRelease(cfcurr);-        if(!match) continue;-        IOHIDDeviceRef dev = IOHIDDeviceCreate(kCFAllocatorDefault, curr);-        source_device[curr] = dev;-        IOHIDDeviceRegisterInputValueCallback(dev, input_callback, NULL);-        kr = IOHIDDeviceOpen(dev, kIOHIDOptionsTypeSeizeDevice);-        if(kr != kIOReturnSuccess) {-            std::cerr << "IOHIDDeviceOpen error: " << std::hex << kr << std::endl;-            if(kr == kIOReturnNotPrivileged) {-                std::cerr << "IOHIDDeviceOpen requires root privileges when called with kIOHIDOptionsTypeSeizeDevice" << std::endl;-            }-        }-        IOHIDDeviceScheduleWithRunLoop(dev, listener_loop, kCFRunLoopDefaultMode);-    }-    if(product) {-        CFRelease(cfproduct);-    }-    CFRelease(cfkarabiner);-}--/*- * We'll register this callback to run whenever an IOHIDDevice- * (representing a keyboard) is connected to the OS- *- */-void matched_callback(void *context, io_iterator_t iter) {-    char *product = (char *)context;-    open_matching_devices(product, iter);-}--/*- * We'll register this callback to run whenever an IOHIDDevice- * (representing a keyboard) is disconnected from the OS- *- */-void terminated_callback(void *context, io_iterator_t iter) {-    for(mach_port_t curr = IOIteratorNext(iter); curr; curr = IOIteratorNext(iter)) {-        source_device.erase(curr);-    }-}--/*- * This gets us some code reuse (see the send_key overload below)- */-template<typename T>-int send_key(T &keyboard, struct KeyEvent *e) {-    if(e->type == 0) keyboard.keys.insert((uint16_t)e->keycode);-    else if (e->type == 1) keyboard.keys.erase((uint16_t)e->keycode);-    return pqrs::karabiner_virtual_hid_device_methods::post_keyboard_input_report(connect, keyboard);-}--/*- * Haskell calls this with a new key event to send back to the OS. It- * posts the information to the karabiner kernel extension (which- * represents a virtual keyboard).- */-extern "C" int send_key(struct KeyEvent *e) {-    pqrs::karabiner_virtual_hid_device::usage_page usage_page = pqrs::karabiner_virtual_hid_device::usage_page(e->keycode >> 16);-    if(usage_page == pqrs::karabiner_virtual_hid_device::usage_page::keyboard_or_keypad)-        return send_key(keyboard, e);-    else if(usage_page == pqrs::karabiner_virtual_hid_device::usage_page::apple_vendor_top_case)-        return send_key(top_case, e);-    else if(usage_page == pqrs::karabiner_virtual_hid_device::usage_page::apple_vendor_keyboard)-        return send_key(apple_keyboard, e);-    else if(usage_page == pqrs::karabiner_virtual_hid_device::usage_page::consumer)-        return send_key(consumer, e);-    else-        return 1;-}--/*- * Reads a new key event from the pipe, blocking until a new event is- * ready.- */-extern "C" int wait_key(struct KeyEvent *e) {-    return read(fd[0], e, sizeof(struct KeyEvent)) == sizeof(struct KeyEvent);-}--/*- * For each keyboard, registers an asynchronous callback to run when- * new input from the user is available from that keyboard. Then- * sleeps indefinitely, ready to received asynchronous callbacks.- */-void monitor_kb(char *product) {-    kern_return_t kr;-    CFMutableDictionaryRef matching_dictionary = IOServiceMatching(kIOHIDDeviceKey);-    if(!matching_dictionary) {-        std::cerr << "IOServiceMatching error" << std::endl;-        return;-    }-    UInt32 value;-    CFNumberRef cfValue;-    value = kHIDPage_GenericDesktop;-    cfValue = CFNumberCreate( kCFAllocatorDefault, kCFNumberSInt32Type, &value );-    CFDictionarySetValue(matching_dictionary, CFSTR(kIOHIDDeviceUsagePageKey), cfValue);-    CFRelease(cfValue);-    value = kHIDUsage_GD_Keyboard;-    cfValue = CFNumberCreate( kCFAllocatorDefault, kCFNumberSInt32Type, &value );-    CFDictionarySetValue(matching_dictionary,CFSTR(kIOHIDDeviceUsageKey),cfValue);-    CFRelease(cfValue);-    io_iterator_t iter = IO_OBJECT_NULL;-    CFRetain(matching_dictionary);-    kr = IOServiceGetMatchingServices(kIOMasterPortDefault,-                                      matching_dictionary,-                                      &iter);-    if(kr != KERN_SUCCESS) {-        std::cerr << "IOServiceGetMatchingServices error: " << std::hex << kr << std::endl;-        return;-    }-    listener_loop = CFRunLoopGetCurrent();-    open_matching_devices(product, iter);-    IONotificationPortRef notification_port = IONotificationPortCreate(kIOMasterPortDefault);-    CFRunLoopSourceRef notification_source = IONotificationPortGetRunLoopSource(notification_port);-    CFRunLoopAddSource(listener_loop, notification_source, kCFRunLoopDefaultMode);-    CFRetain(matching_dictionary);-    kr = IOServiceAddMatchingNotification(notification_port,-                                          kIOMatchedNotification,-                                          matching_dictionary,-                                          matched_callback,-                                          product,-                                          &iter);-    if(kr != KERN_SUCCESS) {-        std::cerr << "IOServiceAddMatchingNotification error: " << std::hex << kr << std::endl;-        return;-    }-    for(mach_port_t curr = IOIteratorNext(iter); curr; curr = IOIteratorNext(iter)) {}-    kr = IOServiceAddMatchingNotification(notification_port,-                                          kIOTerminatedNotification,-                                          matching_dictionary,-                                          terminated_callback,-                                          NULL,-                                          &iter);-    if(kr != KERN_SUCCESS) {-        std::cerr << "IOServiceAddMatchingNotification error: " << std::hex << kr << std::endl;-        return;-    }-    for(mach_port_t curr = IOIteratorNext(iter); curr; curr = IOIteratorNext(iter)) {}-    CFRunLoopRun();-    for(std::pair<const io_service_t,IOHIDDeviceRef> p: source_device) {-        kr = IOHIDDeviceClose(p.second,kIOHIDOptionsTypeSeizeDevice);-        if(kr != KERN_SUCCESS) {-            std::cerr << "IOHIDDeviceClose error: " << std::hex << kr << std::endl;-        }-    }-}--/*- * Opens and seizes input from each keyboard device whose product name- * matches the parameter (if NULL is received, then it opens all- * keyboard devices). Spawns a thread to receive asynchronous input- * and opens a pipe for this thread to send key event data to the main- * thread.- *- * Loads a the karabiner kernel extension that will send key events- * back to the OS.- */-extern "C" int grab_kb(char *product) {-    // Source-    if (pipe(fd) == -1) {-        std::cerr << "pipe error: " << errno << std::endl;-        return errno;-    }-    if(product) {-        prod = (char *)malloc(strlen(product) + 1);-        strcpy(prod, product);-    }-    thread = std::thread{monitor_kb, prod};-    // Sink-    kern_return_t kr;-    connect = IO_OBJECT_NULL;-    service = IOServiceGetMatchingService(kIOMasterPortDefault, IOServiceNameMatching(pqrs::karabiner_virtual_hid_device::get_virtual_hid_root_name()));-    if (!service) {-        std::cerr << "IOServiceGetMatchingService error" << std::endl;-        return 1;-    }-    kr = IOServiceOpen(service, mach_task_self(), kIOHIDServerConnectType, &connect);-    if (kr != KERN_SUCCESS) {-        std::cerr << "IOServiceOpen error: " << std::hex << kr << std::endl;-        return kr;-    }-    //std::this_thread::sleep_for(std::chrono::milliseconds(10000));-    //setuid(501);-    {-        pqrs::karabiner_virtual_hid_device::properties::keyboard_initialization properties;-        kr = pqrs::karabiner_virtual_hid_device_methods::initialize_virtual_hid_keyboard(connect, properties);-        if (kr != KERN_SUCCESS) {-            std::cerr << "initialize_virtual_hid_keyboard error: " << std::hex << kr << std::endl;-            return 1;-        }-        while (true) {-            bool ready;-            kr = pqrs::karabiner_virtual_hid_device_methods::is_virtual_hid_keyboard_ready(connect, ready);-            if (kr != KERN_SUCCESS) {-                std::cerr << "is_virtual_hid_keyboard_ready error: " << std::hex << kr << std::endl;-                return kr;-            } else {-                if (ready) {-                    break;-                }-            }-            std::this_thread::sleep_for(std::chrono::milliseconds(100));-        }-    }-    {-        pqrs::karabiner_virtual_hid_device::properties::keyboard_initialization properties;-        properties.country_code = 33;-        kr = pqrs::karabiner_virtual_hid_device_methods::initialize_virtual_hid_keyboard(connect, properties);-        if (kr != KERN_SUCCESS) {-            std::cerr << "initialize_virtual_hid_keyboard error: " << std::hex << kr << std::endl;-            return kr;-        }-    }-    return 0;-}--/*- * Releases the resources needed to receive key events from and send- * key events to the OS.- */-extern "C" int release_kb() {-    int retval = 0;-    kern_return_t kr;-    // Source-    if(thread.joinable()) {-        CFRunLoopStop(listener_loop);-        thread.join();-    } else {-        std::cerr << "no thread was running!" << std::endl;-    }-    if(prod) {-        free(prod);-    }-    if (close(fd[0]) == -1) {-        std::cerr << "close error: " << errno << std::endl;-        retval = 1;-    }-    if (close(fd[1]) == -1) {-        std::cerr << "close error: " << errno << std::endl;-        retval = 1;-    }-    // Sink-    kr = pqrs::karabiner_virtual_hid_device_methods::reset_virtual_hid_keyboard(connect);-    if (kr != KERN_SUCCESS) {-        std::cerr << "reset_virtual_hid_keyboard error: " << std::hex << kr << std::endl;-        retval = 1;-    }-    if (connect) {-        kr = IOServiceClose(connect);-        if(kr != KERN_SUCCESS) {-            std::cerr << "IOServiceClose error: " << std::hex << kr << std::endl;-            retval = 1;-        }-    }-    if (service) {-        kr = IOObjectRelease(service);-        if(kr != KERN_SUCCESS) {-            std::cerr << "IOObjectRelease error: " << std::hex << kr << std::endl;-            retval = 1;-        }-    }-    return retval;-}

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

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

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

@@ -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 (:[]))

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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