From 628174c992a5a740feb4dc119adf8dfb1f89f992 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Thu, 1 Jan 2026 18:04:40 -0700 Subject: Have Meson orchestrate the whole build rather than stack. As a part of this, I changed the file layout to: rt/ - the Montis runtime plug/ - the Montis plugin wlroots/ - wlroots --- Setup.hs | 69 -- harness/CMakeLists.txt | 84 -- harness/include/foreign_intf.h | 33 - harness/include/plugin.h | 190 ---- harness/include/plugin_types.h | 9 - harness/include/wl.h | 116 --- harness/src/plugin.c | 266 ------ harness/src/wl.c | 1066 ----------------------- harness/tools/genbuild.pl | 48 - harness/tools/genintf.pl | 42 - package.yaml | 95 -- plug/README.md | 1 + plug/package.yaml | 86 ++ plug/plug.stamp | 0 plug/src/Config.hs | 88 ++ plug/src/Lib.hs | 6 + plug/src/Wetterhorn/Constraints.hs | 13 + plug/src/Wetterhorn/Core.hs | 152 ++++ plug/src/Wetterhorn/Core/ButtonEvent.hs | 15 + plug/src/Wetterhorn/Core/KeyEvent.hs | 22 + plug/src/Wetterhorn/Core/Keys.hs | 239 +++++ plug/src/Wetterhorn/Core/SurfaceEvent.hs | 16 + plug/src/Wetterhorn/Core/W.hs | 379 ++++++++ plug/src/Wetterhorn/Dsl/Bind.hs | 128 +++ plug/src/Wetterhorn/Dsl/Buttons.hsc | 229 +++++ plug/src/Wetterhorn/Dsl/Input.hs | 286 ++++++ plug/src/Wetterhorn/Foreign.hs | 18 + plug/src/Wetterhorn/Foreign/Export.hs | 208 +++++ plug/src/Wetterhorn/Foreign/ForeignInterface.hs | 81 ++ plug/src/Wetterhorn/Foreign/WlRoots.hs | 67 ++ plug/src/Wetterhorn/Keys/Macros.hs | 145 +++ plug/src/Wetterhorn/Keys/MagicModifierKey.hs | 50 ++ plug/src/Wetterhorn/Layout/Combine.hs | 48 + plug/src/Wetterhorn/Layout/Full.hs | 23 + plug/src/Wetterhorn/StackSet.hs | 210 +++++ plug/src/harness_adapter.c | 81 ++ plug/stack.yaml | 67 ++ plug/test/Spec.hs | 2 + rt/CMakeLists.txt | 84 ++ rt/include/foreign_intf.h | 33 + rt/include/plugin.h | 190 ++++ rt/include/plugin_types.h | 9 + rt/include/wl.h | 116 +++ rt/src/plugin.c | 266 ++++++ rt/src/wl.c | 1066 +++++++++++++++++++++++ rt/tools/genbuild.pl | 48 + rt/tools/genintf.pl | 42 + src/Config.hs | 88 -- src/Lib.hs | 6 - src/Wetterhorn/Constraints.hs | 13 - src/Wetterhorn/Core.hs | 152 ---- src/Wetterhorn/Core/ButtonEvent.hs | 15 - src/Wetterhorn/Core/KeyEvent.hs | 22 - src/Wetterhorn/Core/Keys.hs | 239 ----- src/Wetterhorn/Core/SurfaceEvent.hs | 16 - src/Wetterhorn/Core/W.hs | 379 -------- src/Wetterhorn/Dsl/Bind.hs | 128 --- src/Wetterhorn/Dsl/Buttons.hsc | 229 ----- src/Wetterhorn/Dsl/Input.hs | 286 ------ src/Wetterhorn/Foreign.hs | 18 - src/Wetterhorn/Foreign/Export.hs | 208 ----- src/Wetterhorn/Foreign/ForeignInterface.hs | 81 -- src/Wetterhorn/Foreign/WlRoots.hs | 67 -- src/Wetterhorn/Keys/Macros.hs | 145 --- src/Wetterhorn/Keys/MagicModifierKey.hs | 50 -- src/Wetterhorn/Layout/Combine.hs | 48 - src/Wetterhorn/Layout/Full.hs | 23 - src/Wetterhorn/StackSet.hs | 210 ----- src/harness_adapter.c | 81 -- stack.yaml | 67 -- test/Spec.hs | 2 - 71 files changed, 4514 insertions(+), 4591 deletions(-) delete mode 100644 Setup.hs delete mode 100644 harness/CMakeLists.txt delete mode 100644 harness/include/foreign_intf.h delete mode 100644 harness/include/plugin.h delete mode 100644 harness/include/plugin_types.h delete mode 100644 harness/include/wl.h delete mode 100644 harness/src/plugin.c delete mode 100644 harness/src/wl.c delete mode 100644 harness/tools/genbuild.pl delete mode 100644 harness/tools/genintf.pl delete mode 100644 package.yaml create mode 100644 plug/README.md create mode 100644 plug/package.yaml create mode 100644 plug/plug.stamp create mode 100644 plug/src/Config.hs create mode 100644 plug/src/Lib.hs create mode 100644 plug/src/Wetterhorn/Constraints.hs create mode 100644 plug/src/Wetterhorn/Core.hs create mode 100644 plug/src/Wetterhorn/Core/ButtonEvent.hs create mode 100644 plug/src/Wetterhorn/Core/KeyEvent.hs create mode 100644 plug/src/Wetterhorn/Core/Keys.hs create mode 100644 plug/src/Wetterhorn/Core/SurfaceEvent.hs create mode 100644 plug/src/Wetterhorn/Core/W.hs create mode 100644 plug/src/Wetterhorn/Dsl/Bind.hs create mode 100644 plug/src/Wetterhorn/Dsl/Buttons.hsc create mode 100644 plug/src/Wetterhorn/Dsl/Input.hs create mode 100644 plug/src/Wetterhorn/Foreign.hs create mode 100644 plug/src/Wetterhorn/Foreign/Export.hs create mode 100644 plug/src/Wetterhorn/Foreign/ForeignInterface.hs create mode 100644 plug/src/Wetterhorn/Foreign/WlRoots.hs create mode 100644 plug/src/Wetterhorn/Keys/Macros.hs create mode 100644 plug/src/Wetterhorn/Keys/MagicModifierKey.hs create mode 100644 plug/src/Wetterhorn/Layout/Combine.hs create mode 100644 plug/src/Wetterhorn/Layout/Full.hs create mode 100644 plug/src/Wetterhorn/StackSet.hs create mode 100644 plug/src/harness_adapter.c create mode 100644 plug/stack.yaml create mode 100644 plug/test/Spec.hs create mode 100644 rt/CMakeLists.txt create mode 100644 rt/include/foreign_intf.h create mode 100644 rt/include/plugin.h create mode 100644 rt/include/plugin_types.h create mode 100644 rt/include/wl.h create mode 100644 rt/src/plugin.c create mode 100644 rt/src/wl.c create mode 100644 rt/tools/genbuild.pl create mode 100644 rt/tools/genintf.pl delete mode 100644 src/Config.hs delete mode 100644 src/Lib.hs delete mode 100644 src/Wetterhorn/Constraints.hs delete mode 100644 src/Wetterhorn/Core.hs delete mode 100644 src/Wetterhorn/Core/ButtonEvent.hs delete mode 100644 src/Wetterhorn/Core/KeyEvent.hs delete mode 100644 src/Wetterhorn/Core/Keys.hs delete mode 100644 src/Wetterhorn/Core/SurfaceEvent.hs delete mode 100644 src/Wetterhorn/Core/W.hs delete mode 100644 src/Wetterhorn/Dsl/Bind.hs delete mode 100644 src/Wetterhorn/Dsl/Buttons.hsc delete mode 100644 src/Wetterhorn/Dsl/Input.hs delete mode 100644 src/Wetterhorn/Foreign.hs delete mode 100644 src/Wetterhorn/Foreign/Export.hs delete mode 100644 src/Wetterhorn/Foreign/ForeignInterface.hs delete mode 100644 src/Wetterhorn/Foreign/WlRoots.hs delete mode 100644 src/Wetterhorn/Keys/Macros.hs delete mode 100644 src/Wetterhorn/Keys/MagicModifierKey.hs delete mode 100644 src/Wetterhorn/Layout/Combine.hs delete mode 100644 src/Wetterhorn/Layout/Full.hs delete mode 100644 src/Wetterhorn/StackSet.hs delete mode 100644 src/harness_adapter.c delete mode 100644 stack.yaml delete mode 100644 test/Spec.hs diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 index e8a6b6b..0000000 --- a/Setup.hs +++ /dev/null @@ -1,69 +0,0 @@ -import Control.Exception -import Control.Monad (forM_, when) -import Data.Maybe (fromJust) -import Distribution.Simple -import Distribution.Simple.Setup -import Distribution.Types.HookedBuildInfo -import System.Directory -import System.Environment (getArgs) -import System.FilePath -import System.Posix.Files -import System.Process -import Text.Printf - -main = do - putStrLn "Running Setup.hs" - - defaultMainWithHooks $ - simpleUserHooks - { preConf = \_ conf -> do - let buildPath = fromJust (flagToMaybe $ configDistPref conf) - - callCommand $ - printf "cd wlroots && meson setup %s -Dexamples=false -Dbackends=x11,drm,libinput --reconfigure" (wlrootsDir buildPath) - - callCommand $ - printf "cmake -B %s -S harness" (harnessDir buildPath) - - lnF ("../" ++ harnessDir buildPath) "harness/build" - - return emptyHookedBuildInfo, - preBuild = \_ conf -> do - let path = fromJust (flagToMaybe $ buildDistPref conf) - - callCommand $ printf "cd wlroots && ninja -C %s" (wlrootsDir path) - - callCommand $ - printf "make -C %s" (harnessDir path) - - lnF (printf "%s/wtr_harness" (harnessDir path)) "wtr_harness" - - return emptyHookedBuildInfo, - postCopy = \a f pd _ -> do - forM_ (flagToMaybe (copyDistPref f)) $ \copyDest -> do - let pluginFile = copyDest "build" "wtr.so" "wtr.so" - lnF pluginFile "wtr.so" - } - where - wlrootsDir :: String -> String - wlrootsDir = printf "../%s/build/wlroots" - - harnessDir :: String -> String - harnessDir = printf "%s/build/wtr_harness" - - lnF from to = do - printf "%s -> %s\n" from to - flip - when - ( do - printf "Removing %s." to - removeLink to - ) - =<< doesExist to - createSymbolicLink from to - - doesExist f = do - b1 <- doesFileExist f - b2 <- doesDirectoryExist f - b3 <- catch (pathIsSymbolicLink f) (\(e :: SomeException) -> return False) - return (b1 || b2 || b3) diff --git a/harness/CMakeLists.txt b/harness/CMakeLists.txt deleted file mode 100644 index a7a0a77..0000000 --- a/harness/CMakeLists.txt +++ /dev/null @@ -1,84 +0,0 @@ -cmake_minimum_required(VERSION 3.10) -project ( - wtr_harness - VERSION 0.1 - LANGUAGES C) - -set(CMAKE_VERBOSE_MAKEFILE ON) -set(CMAKE_BUILD_TYPE Debug) - -include_directories(include/ ../wlroots/include /usr/include/pixman-1 - ${CMAKE_CURRENT_BINARY_DIR}/ - ${CMAKE_CURRENT_BINARY_DIR}/../wlroots/include - ${CMAKE_CURRENT_BINARY_DIR}/../wlroots/protocol -) - -add_definitions(-DWLR_USE_UNSTABLE) - -execute_process( - COMMAND pkg-config --variable=pkgdatadir wayland-protocols - OUTPUT_VARIABLE WAYLAND_PROTOCOLS - RESULT_VARIABLE ec - OUTPUT_STRIP_TRAILING_WHITESPACE -) -if(${ec} EQUAL 0) -else() - message(FATAL_ERROR "Failed to execute pkg-config") -endif() - -execute_process( - COMMAND pkg-config --variable=wayland_scanner wayland-scanner - OUTPUT_VARIABLE WAYLAND_SCANNER - RESULT_VARIABLE ec - OUTPUT_STRIP_TRAILING_WHITESPACE -) -if(${ec} EQUAL 0) -else() - message(FATAL_ERROR "Failed to execute pkg-config") -endif() - -set(PLUGIN_INTF ${CMAKE_BINARY_DIR}/plugin_interface.h) -add_custom_command( - OUTPUT ${PLUGIN_INTF} - COMMAND perl ${PROJECT_SOURCE_DIR}/tools/genintf.pl < - ${PROJECT_SOURCE_DIR}/include/plugin.h > ${PLUGIN_INTF} - DEPENDS ${PROJECT_SOURCE_DIR}/include/plugin.h - DEPENDS ${PROJECT_SOURCE_DIR}/tools/genintf.pl -) - -set(PLUGIN_LOAD ${CMAKE_BINARY_DIR}/gen_plugin_load.c) -add_custom_command( - OUTPUT ${PLUGIN_LOAD} - COMMAND perl ${PROJECT_SOURCE_DIR}/tools/genbuild.pl < - ${PROJECT_SOURCE_DIR}/include/plugin.h > ${PLUGIN_LOAD} - DEPENDS ${PROJECT_SOURCE_DIR}/include/plugin.h - DEPENDS ${PROJECT_SOURCE_DIR}/tools/genbuild.pl -) - -add_custom_command( - OUTPUT xdg-shell-protocol.h - COMMAND ${WAYLAND_SCANNER} server-header - ${WAYLAND_PROTOCOLS}/stable/xdg-shell/xdg-shell.xml - xdg-shell-protocol.h -) - -add_custom_command( - OUTPUT xdg-shell-protocol.c - COMMAND ${WAYLAND_SCANNER} private-code - ${WAYLAND_PROTOCOLS}/stable/xdg-shell/xdg-shell.xml - xdg-shell-protocol.c - DEPENDS xdg-shell-protocol.h -) - -file (GLOB_RECURSE SOURCES src/*.c) - -set(CMAKE_EXPORT_COMPILE_COMMANDS ON) - -add_executable (wtr_harness ${SOURCES} ${PLUGIN_LOAD} ${PLUGIN_INTF} - xdg-shell-protocol.c) - -target_link_libraries(wtr_harness dl) -target_link_directories(wtr_harness PUBLIC - "${CMAKE_CURRENT_BINARY_DIR}/../wlroots") -target_link_libraries(wtr_harness wlroots-0.18 wayland-server xkbcommon pthread) -target_link_options(wtr_harness PRIVATE -Wl,--wrap=pthread_create) diff --git a/harness/include/foreign_intf.h b/harness/include/foreign_intf.h deleted file mode 100644 index 6558fab..0000000 --- a/harness/include/foreign_intf.h +++ /dev/null @@ -1,33 +0,0 @@ -/* Contains a structure, which contains functions to back-call into - * the harness code. */ - -#ifndef __FOREIGN_INTERFACE -#define __FOREIGN_INTERFACE - -#define EXPORT(a) a - -typedef void *ctx_t; - -typedef struct FOREIGN_INTERFACE { - /* DO NOT ADD ANY UNEXPORTED VARIABLES HERE */ - - /* The context, which needs to be passed to each function. This context is - * opaque to the plugin and should not be changed. */ - EXPORT(ctx_t ctx); - - /* Requests the harness hot reload the current plugin. */ - EXPORT(void (*request_hot_reload)(ctx_t ctx)); - - /* Requests the harness hot reload the current plugin. */ - EXPORT(void (*do_log)(ctx_t ctx, const char *str)); - - /* Requestes that the whole system exit. Exits with the given return code. */ - EXPORT(void (*request_exit)(ctx_t ctx, int rc)); - - /* Returns the seat associated with the server. */ - EXPORT(void *(*get_seat)(ctx_t ctx)); -} foreign_interface_t; - -#undef EXPORT - -#endif /* __FOREIGN_INTERFACE */ diff --git a/harness/include/plugin.h b/harness/include/plugin.h deleted file mode 100644 index 4d69d76..0000000 --- a/harness/include/plugin.h +++ /dev/null @@ -1,190 +0,0 @@ -#ifndef _PLUGIN_H_ -#define _PLUGIN_H_ - -#include -#include -#include -#include -#include -#include -#include -#include - -#include "plugin_types.h" -#include - -/* - * Marker macro to define what functions should be exported. This generates the - * interface which the plugin needs to implement. - */ -#define EXPORT(a) a - -#define EXPORT_INCLUDE(a) - -// clang-format off -EXPORT_INCLUDE() -EXPORT_INCLUDE() -EXPORT_INCLUDE() -EXPORT_INCLUDE() -// clang-format on - -#define MAX_QUEUED_ACTIONS 8 - -typedef void *dlhandle_t; - -/* Opaque state for a plugin. Not to be touched by the harness (not that it - * really can be.) */ - -struct PLUGIN; -/* This structure represents an action requested by the plugin for the harness. - */ -typedef struct { - int (*action)(struct PLUGIN *requester, void *arg); - void (*arg_dtor)(void *arg); - union { - void *ptr_arg; - int int_arg; - char *str_arg; - }; -} requested_action_t; - -/* - * Structure for the plugin. - */ -typedef struct PLUGIN { - /* The argc this plugin is loaded with. Typically the argc from main(). */ - int argc; - - /* The argv this plugin is loaded with. Typically the argv from main(). */ - char **argv; - - /* Filename the plugin is loaded from. */ - char filename[PATH_MAX]; - - /* Interface to the harness that this plugin can use. */ - foreign_interface_t foreign_intf; - - /* Opaque state of this plugin. The state is usually some kind of pointer to - * the plugin state, but all the harness knows is the opaque state is a - * pointer-sized piece of data. - * - * This opaque state is used in a linear pattern where the handlers take the - * opaque state, maybe operate on it, and return a new opaque state, which is - * then passed to the next handler, etc. It is on the plugin to properly - * manager the memory for this state and to destroy it upon teardown. - * - * It's guaranteed that this state is used linearly, meaning the harness gives - * up all ownership to it once passed into a handler. */ - opqst_t state; - - /* This plugin's lock. This avoids potential issues with multiple threads - * trying to change the opaque state at once which can lead to undesireable - * outcomes. */ - pthread_mutex_t lock; - - /** Set to not-zero if this plugin is initialized, otherwise set to zero. */ - int initialized; - - /* The handle to the shared library. */ - dlhandle_t library_handle; - - /* Pointer to the plugin name. This is in the shared library and a - * null-terminated string. If the library does not have a plugin name, this - * will be NULL. */ - const char *plugin_name; - - /** - * Initializes the plugin on the first time, and only the first time, it is - * loaded. This is used to do things like setup a runtime that cannot be - * reliably torn down. It is up to the plugin to ensure this won't interfere - * with hot-reloading. - */ - EXPORT(void (*plugin_metaload)(int argc, char **argv)); - - /** Intializes the plugin with the given argc/argv. This is the first thing - * called on the plugin and is called immediately after the library is loaded. - */ - EXPORT(void (*plugin_load)(int argc, char **argv, foreign_interface_t *intf)); - - /* Start the plugin with the marshalled state from the previous plugin. - * - * This should return the opaque state from the mashalled_state. - * - * This function should not fail if the state cannot be demarshalled, rather a - * default state should be returned. This is because changing the plugin and - * hot-reloading can produce incompatibilities between the old state and the - * new state, and this should not cause a failure. - */ - EXPORT(opqst_t (*plugin_hot_start)(uint8_t *mashalled_state, uint32_t n)); - - /* - * Starts the plugin without a marshalled state. Happens during the first boot - * when there is not state. - */ - EXPORT(opqst_t (*plugin_cold_start)()); - - /* - * Marshals the state to a bytestring. The returned pointer should be malloc'd - * on the heap. The harness takes ownership of the malloc'd pointer. - * - * This is usually called in preparation for a teardown followed by a - * hot-start. - */ - EXPORT(uint8_t *(*plugin_marshal_state)(opqst_t st, uint32_t *szout)); - - /* - * Teardown the plugin in preperation for the library's imminent unloading. - */ - EXPORT(void (*plugin_teardown)(opqst_t)); - - /* - * Handles a keybinding. - */ - EXPORT(opqst_t (*plugin_handle_keybinding)( - struct wlr_keyboard *keyboard, struct wlr_keyboard_key_event *event, - uint32_t modifiers, uint32_t keysym, uint32_t codepoint, int *out_handled, - opqst_t state)); - - EXPORT(opqst_t (*plugin_handle_button)(struct wlr_pointer_button_event *event, - uint32_t modifiers, opqst_t state)); - - /* - * Handles a surface being mapped, unmapped or destroyed. - */ - EXPORT(opqst_t (*plugin_handle_surface)(void *surface, surface_event_t event, - opqst_t)); - - /* List of requested actions by the plugin. Right now there is a maximum of 8 - * allowed at one time. That should be plenty. The actions should be flushed - * after each call to a handler anyway. */ - size_t n_requested_actions; - requested_action_t requested_actions[MAX_QUEUED_ACTIONS]; -} plugin_t; - -#undef EXPORT -#undef EXPORT_INCLUDE - -/* Reloads the plugin. This tears down the existing plugin, marshals the state - * for it and reloads it. - * - * This function will call dlclose on the plugin's library handle. - */ -int plugin_hot_reload(int argc, char **argv, const char *filepath, - plugin_t *plugin); - -/* - * Like hot-reload, but uses the same parameters the plugin was originally - * loaded with. - */ -int plugin_hot_reload_same_state(plugin_t *plugin); - -/* Starts a plugin in a cold state. Called after load_plugin_from_file. */ -void plugin_cold_start(plugin_t *plugin); - -/* Reads a plugin from a filename. */ -int load_plugin_from_file(int argc, char **argv, const char *filename, - plugin_t *plugin); - -void plugin_run_requested_actions(plugin_t *plugin); - -#endif /* _PLUGIN_H_ */ diff --git a/harness/include/plugin_types.h b/harness/include/plugin_types.h deleted file mode 100644 index df1eab5..0000000 --- a/harness/include/plugin_types.h +++ /dev/null @@ -1,9 +0,0 @@ -#pragma once - -typedef void *opqst_t; - -typedef enum { - SURFACE_MAP = 0, - SURFACE_UNMAP, - SURFACE_DELETE, -} surface_event_t; diff --git a/harness/include/wl.h b/harness/include/wl.h deleted file mode 100644 index dc7fe9f..0000000 --- a/harness/include/wl.h +++ /dev/null @@ -1,116 +0,0 @@ -#pragma once - -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include - -#include - -/* For brevity's sake, struct members are annotated where they are used. */ -enum montis_cursor_mode { - TINYWL_CURSOR_PASSTHROUGH, - TINYWL_CURSOR_MOVE, - TINYWL_CURSOR_RESIZE, -}; - -struct montis_server { - struct wl_display *wl_display; - struct wlr_backend *backend; - struct wlr_renderer *renderer; - struct wlr_allocator *allocator; - struct wlr_scene *scene; - struct wlr_scene_output_layout *scene_layout; - - struct wlr_xdg_shell *xdg_shell; - struct wl_listener new_xdg_toplevel; - struct wl_listener new_xdg_popup; - struct wl_list toplevels; - - struct wlr_cursor *cursor; - struct wlr_xcursor_manager *cursor_mgr; - struct wl_listener cursor_motion; - struct wl_listener cursor_motion_absolute; - struct wl_listener cursor_button; - struct wl_listener cursor_axis; - struct wl_listener cursor_frame; - - struct wlr_seat *seat; - struct wl_listener new_input; - struct wl_listener request_cursor; - struct wl_listener request_set_selection; - struct wl_list keyboards; - enum montis_cursor_mode cursor_mode; - struct montis_toplevel *grabbed_toplevel; - double grab_x, grab_y; - struct wlr_box grab_geobox; - uint32_t resize_edges; - - struct wlr_output_layout *output_layout; - struct wl_list outputs; - struct wl_listener new_output; - - struct wlr_session *session; - plugin_t plugin; -}; - -struct montis_output { - struct wl_list link; - struct montis_server *server; - struct wlr_output *wlr_output; - struct wl_listener frame; - struct wl_listener request_state; - struct wl_listener destroy; -}; - -struct montis_toplevel { - struct wl_list link; - struct montis_server *server; - struct wlr_xdg_toplevel *xdg_toplevel; - struct wlr_scene_tree *scene_tree; - struct wl_listener map; - struct wl_listener unmap; - struct wl_listener destroy; - struct wl_listener commit; - struct wl_listener request_move; - struct wl_listener request_resize; - struct wl_listener request_maximize; - struct wl_listener request_fullscreen; -}; - -struct montis_keyboard { - struct wl_list link; - struct montis_server *server; - struct wlr_keyboard *wlr_keyboard; - - struct wl_listener modifiers; - struct wl_listener key; - struct wl_listener destroy; -}; - -struct montis_popup { - struct wlr_xdg_popup *xdg_popup; - struct wl_listener commit; - struct wl_listener destroy; -}; - diff --git a/harness/src/plugin.c b/harness/src/plugin.c deleted file mode 100644 index 37a6dd3..0000000 --- a/harness/src/plugin.c +++ /dev/null @@ -1,266 +0,0 @@ -#include "plugin.h" -#include "foreign_intf.h" -#include "wl.h" - -#include -#include -#include -#include -#include -#include -#include -#include - -/* Utility function for showing the marshalled states as hex code */ -static void shx(uint8_t *state, uint32_t sz) -{ - uint32_t i = 0; - while (i < sz) { - for (int j = 0; j < 16; ++j) { - if (i < sz) { - printf("%02x ", (unsigned int)state[i]); - } - else { - printf(" "); - } - ++i; - } - - i -= 16; - - printf(" "); - - for (int j = 0; j < 16; ++j) { - if (i < sz) { - if (isprint(state[i]) && !isspace(state[i])) { - printf("%c", state[i]); - } - else { - printf("."); - } - } - else { - printf(" "); - } - ++i; - } - printf("\n"); - } -} - -int load_plugin_from_dl_(dlhandle_t dl, plugin_t *plug); - -static void lock(plugin_t *plugin) { pthread_mutex_lock(&plugin->lock); }; - -static void unlock(plugin_t *plugin) { pthread_mutex_unlock(&plugin->lock); }; - -static int plugin_hot_reload_same_state_action_(plugin_t *plugin, void *ignore) -{ - return plugin_hot_reload_same_state(plugin); -} - -void do_request_hot_reload(void *plugv) -{ - plugin_t *plugin = plugv; - - size_t n = plugin->n_requested_actions++; - if (n < 8) { - plugin->requested_actions[n].action = plugin_hot_reload_same_state_action_; - plugin->requested_actions[n].arg_dtor = NULL; - } -} - -static int plugin_do_log(plugin_t *plugin, void *chrs) -{ - char *str = chrs; - puts(str); - return 0; -} - -void do_request_log(void *plugv, const char *str) -{ - plugin_t *plugin = plugv; - - size_t n = plugin->n_requested_actions++; - if (n < 8) { - plugin->requested_actions[n].action = plugin_do_log; - plugin->requested_actions[n].str_arg = strdup(str); - plugin->requested_actions[n].arg_dtor = free; - } -} - -static int plugin_do_exit(void *plugv, int ec) -{ - exit(ec); - return 0; -} - -void do_request_exit(void *plugv, int ec) -{ - plugin_t *plugin = plugv; - - size_t n = plugin->n_requested_actions++; - if (n < 8) { - plugin->requested_actions[n].action = - (int (*)(plugin_t *, void *))plugin_do_exit; - plugin->requested_actions[n].int_arg = ec; - plugin->requested_actions[n].arg_dtor = NULL; - } -} - -static void* plugin_get_seat(void* ctx) { - struct montis_server* server = wl_container_of(ctx, server, plugin); - return server->seat; -} - -static int load_plugin_from_file_(int argc, char **argv, const char *filename, - plugin_t *plugin) -{ - dlhandle_t lib = dlopen(filename, RTLD_LAZY); - int ec = 0; - - if (!lib) { - fprintf(stderr, "Failed to open library: %s: %s\n", filename, dlerror()); - ec = 1; - goto end; - } - - printf("Loading file.\n"); - ec = load_plugin_from_dl_(lib, plugin); - - if (ec) { - goto end; - } - - strncpy(plugin->filename, filename, sizeof(plugin->filename)); - plugin->argc = argc; - plugin->argv = argv; - - plugin->foreign_intf.ctx = plugin; - plugin->foreign_intf.request_hot_reload = do_request_hot_reload; - plugin->foreign_intf.do_log = do_request_log; - plugin->foreign_intf.request_exit = do_request_exit; - plugin->foreign_intf.get_seat = plugin_get_seat; - - plugin->plugin_load(plugin->argc, plugin->argv, &plugin->foreign_intf); -end: - return ec; -} - -static void maybe_run_metaload(int argc, char **argv, plugin_t *plugin) -{ - static char *loaded_plugins[12]; - int i; - for (i = 0; i < 12 && loaded_plugins[i]; ++i) { - if (strcmp(loaded_plugins[i], plugin->plugin_name) == 0) { - return; // Plugin is already loaded - } - } - loaded_plugins[i] = strdup(plugin->plugin_name); - - printf("First time loading %s, running metaload.\n", plugin->plugin_name); - if (plugin->plugin_metaload) { - plugin->plugin_metaload(argc, argv); - } -} - -int load_plugin_from_file(int argc, char **argv, const char *filename, - plugin_t *plugin) -{ - memset(plugin, 0, sizeof(*plugin)); - - pthread_mutexattr_t attr; - if (pthread_mutexattr_init(&attr)) { - perror("pthread_mutexattr_init"); - return 1; - } - - if (pthread_mutexattr_settype(&attr, PTHREAD_MUTEX_RECURSIVE)) { - perror("pthread_mutexattr_settype"); - return 1; - } - - if (pthread_mutex_init(&plugin->lock, &attr)) { - pthread_mutexattr_destroy(&attr); - perror("pthread_mutexattr_init"); - return 1; - } - pthread_mutexattr_destroy(&attr); - int rc = load_plugin_from_file_(argc, argv, filename, plugin); - - if (rc == 0) { - maybe_run_metaload(argc, argv, plugin); - } - - return rc; -} - -int plugin_hot_reload_same_state(plugin_t *plugin) -{ - char filename_cpy[PATH_MAX]; - strncpy(filename_cpy, plugin->filename, sizeof(filename_cpy)); - return plugin_hot_reload(plugin->argc, plugin->argv, filename_cpy, plugin); -} - -int plugin_hot_reload(int argc, char **argv, const char *filepath, - plugin_t *plugin) -{ - int ec = 0; - uint32_t sz = 0; - uint8_t *marshalled_state = NULL; - - printf("Hot Reloading %s\n", plugin->plugin_name); - lock(plugin); - - printf("Marshalling state ...\n"); - marshalled_state = plugin->plugin_marshal_state(plugin->state, &sz); - - printf("Calling teardown ...\n"); - plugin->plugin_teardown(plugin->state); - - printf("State Marshalled:\n"); - shx(marshalled_state, sz); - - printf("Unloading old library handle.\n"); - if (dlclose(plugin->library_handle)) { - printf("Could not close library handle: %s\n", dlerror()); - } - - if ((ec = load_plugin_from_file_(argc, argv, filepath, plugin))) { - goto fail; - } - - printf("Hot starting plugin ...\n"); - plugin->state = plugin->plugin_hot_start(marshalled_state, sz); - -fail: - free(marshalled_state); - unlock(plugin); - return ec; -} - -void plugin_run_requested_actions(plugin_t *plugin) -{ - lock(plugin); - requested_action_t requested_actions[MAX_QUEUED_ACTIONS]; - size_t n_requested_actions = plugin->n_requested_actions; - memcpy(&requested_actions, plugin->requested_actions, - sizeof(requested_actions)); - plugin->n_requested_actions = 0; - unlock(plugin); - - size_t i; - for (i = 0; i < n_requested_actions; ++i) { - requested_actions[i].action(plugin, requested_actions[i].str_arg); - if (requested_actions[i].arg_dtor) { - requested_actions[i].arg_dtor(requested_actions[i].ptr_arg); - } - } -} - -void plugin_cold_start(plugin_t *plugin) -{ - lock(plugin); - plugin->state = plugin->plugin_cold_start(); - unlock(plugin); -} diff --git a/harness/src/wl.c b/harness/src/wl.c deleted file mode 100644 index 261e082..0000000 --- a/harness/src/wl.c +++ /dev/null @@ -1,1066 +0,0 @@ -#define _POSIX_C_SOURCE 200112L - -#include -#include -#include -#include - -#include - -#include "xdg-decoration-unstable-v1-client-protocol.h" - -// This macro is responsible for calling a handler on a plugin. This macro will -// acquire the plugin's lock, call the member with the arguments and update the -// state. -// -// This only works on function which have the format: -// -// opqst_t function(args ..., opqst_t state); -// -// Note that the state parameter is omitted from this macro. -#define plugin_call_update_state(plugin, member, ...) \ - do { \ - plugin_t *pl__ = &(plugin); \ - pthread_mutex_lock(&pl__->lock); \ - pl__->state = pl__->member(__VA_ARGS__, pl__->state); \ - pthread_mutex_unlock(&pl__->lock); \ - plugin_run_requested_actions(pl__); \ - } while (0) - -static void focus_toplevel(struct montis_toplevel *toplevel, - struct wlr_surface *surface) -{ - /* Note: this function only deals with keyboard focus. */ - if (toplevel == NULL) { - return; - } - struct montis_server *server = toplevel->server; - struct wlr_seat *seat = server->seat; - struct wlr_surface *prev_surface = seat->keyboard_state.focused_surface; - if (prev_surface == surface) { - /* Don't re-focus an already focused surface. */ - return; - } - if (prev_surface) { - /* - * Deactivate the previously focused surface. This lets the client know - * it no longer has focus and the client will repaint accordingly, e.g. - * stop displaying a caret. - */ - struct wlr_xdg_toplevel *prev_toplevel = - wlr_xdg_toplevel_try_from_wlr_surface(prev_surface); - if (prev_toplevel != NULL) { - wlr_xdg_toplevel_set_activated(prev_toplevel, false); - } - } - struct wlr_keyboard *keyboard = wlr_seat_get_keyboard(seat); - /* Move the toplevel to the front */ - wlr_scene_node_raise_to_top(&toplevel->scene_tree->node); - wl_list_remove(&toplevel->link); - wl_list_insert(&server->toplevels, &toplevel->link); - /* Activate the new surface */ - wlr_xdg_toplevel_set_activated(toplevel->xdg_toplevel, true); - /* - * Tell the seat to have the keyboard enter this surface. wlroots will keep - * track of this and automatically send key events to the appropriate - * clients without additional work on your part. - */ - if (keyboard != NULL) { - wlr_seat_keyboard_notify_enter(seat, toplevel->xdg_toplevel->base->surface, - keyboard->keycodes, keyboard->num_keycodes, - &keyboard->modifiers); - } -} - -static void keyboard_handle_modifiers(struct wl_listener *listener, void *data) -{ - /* This event is raised when a modifier key, such as shift or alt, is - * pressed. We simply communicate this to the client. */ - struct montis_keyboard *keyboard = - wl_container_of(listener, keyboard, modifiers); - /* - * A seat can only have one keyboard, but this is a limitation of the - * Wayland protocol - not wlroots. We assign all connected keyboards to the - * same seat. You can swap out the underlying wlr_keyboard like this and - * wlr_seat handles this transparently. - */ - wlr_seat_set_keyboard(keyboard->server->seat, keyboard->wlr_keyboard); - /* Send modifiers to the client. */ - wlr_seat_keyboard_notify_modifiers(keyboard->server->seat, - &keyboard->wlr_keyboard->modifiers); -} - -static void keyboard_handle_key(struct wl_listener *listener, void *data) -{ - /* This event is raised when a key is pressed or released. */ - struct montis_keyboard *keyboard = wl_container_of(listener, keyboard, key); - struct montis_server *server = keyboard->server; - struct wlr_keyboard_key_event *event = data; - struct wlr_seat *seat = server->seat; - - /* Translate libinput keycode -> xkbcommon */ - uint32_t keycode = event->keycode + 8; - /* Get a list of keysyms based on the keymap for this keyboard */ - const xkb_keysym_t *syms; - int nsyms = - xkb_state_key_get_syms(keyboard->wlr_keyboard->xkb_state, keycode, &syms); - - int handled = false; - uint32_t modifiers = wlr_keyboard_get_modifiers(keyboard->wlr_keyboard); - uint32_t codepoint; - int ec; - - if (nsyms > 0 && syms[0] >= XKB_KEY_XF86Switch_VT_1 && - syms[0] <= XKB_KEY_XF86Switch_VT_12) { - /* Escape-hatch to change sessions. These should always be available key - * bindings regardless of what the plugin dictates. This allows an escape - * hatch to edit the plugin in a different vterm and then use the escape - * hatch below to hot-restart the plugin if things get borked. */ - if (event->state == WL_KEYBOARD_KEY_STATE_PRESSED) { - wlr_session_change_vt(server->session, - syms[0] - XKB_KEY_XF86Switch_VT_1 + 1); - } - } - else if (modifiers == - (WLR_MODIFIER_SHIFT | WLR_MODIFIER_CTRL | WLR_MODIFIER_ALT) && - nsyms > 0 && syms[0] == XKB_KEY_Escape) { - /* Escape-hatch to hot-reload the plugin in case the plugin got borked and - * stops accepting keybindings. Ctrl+Shift+Alt+Escape will always reload the - * plugin.*/ - if (event->state == WL_KEYBOARD_KEY_STATE_PRESSED) { - if ((ec = plugin_hot_reload_same_state(&server->plugin)) != 0) { - fprintf(stderr, "Failed to hot reload plugin"); - exit(1); - } - } - } - else { - /* Pass the information along to the plugin for the plugin to handle. The - * plugin will return via 'handled' whether or not the key event was handled - * or not. */ - if (nsyms > 0) { - codepoint = - xkb_state_key_get_utf32(keyboard->wlr_keyboard->xkb_state, keycode); - plugin_call_update_state(server->plugin, plugin_handle_keybinding, - keyboard->wlr_keyboard, event, modifiers, - syms[0], codepoint, &handled); - } - } -} - -static void keyboard_handle_destroy(struct wl_listener *listener, void *data) -{ - /* This event is raised by the keyboard base wlr_input_device to signal - * the destruction of the wlr_keyboard. It will no longer receive events - * and should be destroyed. - */ - struct montis_keyboard *keyboard = - wl_container_of(listener, keyboard, destroy); - wl_list_remove(&keyboard->modifiers.link); - wl_list_remove(&keyboard->key.link); - wl_list_remove(&keyboard->destroy.link); - wl_list_remove(&keyboard->link); - free(keyboard); -} - -static void server_new_keyboard(struct montis_server *server, - struct wlr_input_device *device) -{ - struct wlr_keyboard *wlr_keyboard = wlr_keyboard_from_input_device(device); - - struct montis_keyboard *keyboard = calloc(1, sizeof(*keyboard)); - keyboard->server = server; - keyboard->wlr_keyboard = wlr_keyboard; - - struct xkb_rule_names names = (struct xkb_rule_names){0}; - names.layout = "jr"; - names.variant = "jdvprk"; - names.options = "numpad:mac"; - - /* We need to prepare an XKB keymap and assign it to the keyboard. This - * assumes the defaults (e.g. layout = "us"). */ - struct xkb_context *context = xkb_context_new(XKB_CONTEXT_NO_FLAGS); - struct xkb_keymap *keymap = - xkb_keymap_new_from_names(context, &names, XKB_KEYMAP_COMPILE_NO_FLAGS); - - if (!keymap) { - fprintf(stderr, "Unable to read keymap.\n"); - exit(1); - } - - wlr_keyboard_set_keymap(wlr_keyboard, keymap); - xkb_keymap_unref(keymap); - xkb_context_unref(context); - wlr_keyboard_set_repeat_info(wlr_keyboard, 25, 600); - - /* Here we set up listeners for keyboard events. */ - keyboard->modifiers.notify = keyboard_handle_modifiers; - wl_signal_add(&wlr_keyboard->events.modifiers, &keyboard->modifiers); - keyboard->key.notify = keyboard_handle_key; - wl_signal_add(&wlr_keyboard->events.key, &keyboard->key); - keyboard->destroy.notify = keyboard_handle_destroy; - wl_signal_add(&device->events.destroy, &keyboard->destroy); - - wlr_seat_set_keyboard(server->seat, keyboard->wlr_keyboard); - - /* And add the keyboard to our list of keyboards */ - wl_list_insert(&server->keyboards, &keyboard->link); -} - -static void server_new_pointer(struct montis_server *server, - struct wlr_input_device *device) -{ - /* We don't do anything special with pointers. All of our pointer handling - * is proxied through wlr_cursor. On another compositor, you might take this - * opportunity to do libinput configuration on the device to set - * acceleration, etc. */ - wlr_cursor_attach_input_device(server->cursor, device); -} - -static void server_new_input(struct wl_listener *listener, void *data) -{ - /* This event is raised by the backend when a new input device becomes - * available. */ - struct montis_server *server = wl_container_of(listener, server, new_input); - struct wlr_input_device *device = data; - switch (device->type) { - case WLR_INPUT_DEVICE_KEYBOARD: - server_new_keyboard(server, device); - break; - case WLR_INPUT_DEVICE_POINTER: - server_new_pointer(server, device); - break; - default: - break; - } - /* We need to let the wlr_seat know what our capabilities are, which is - * communiciated to the client. In TinyWL we always have a cursor, even if - * there are no pointer devices, so we always include that capability. */ - uint32_t caps = WL_SEAT_CAPABILITY_POINTER; - if (!wl_list_empty(&server->keyboards)) { - caps |= WL_SEAT_CAPABILITY_KEYBOARD; - } - wlr_seat_set_capabilities(server->seat, caps); -} - -static void seat_request_cursor(struct wl_listener *listener, void *data) -{ - struct montis_server *server = - wl_container_of(listener, server, request_cursor); - /* This event is raised by the seat when a client provides a cursor image */ - struct wlr_seat_pointer_request_set_cursor_event *event = data; - struct wlr_seat_client *focused_client = - server->seat->pointer_state.focused_client; - /* This can be sent by any client, so we check to make sure this one is - * actually has pointer focus first. */ - if (focused_client == event->seat_client) { - /* Once we've vetted the client, we can tell the cursor to use the - * provided surface as the cursor image. It will set the hardware cursor - * on the output that it's currently on and continue to do so as the - * cursor moves between outputs. */ - wlr_cursor_set_surface(server->cursor, event->surface, event->hotspot_x, - event->hotspot_y); - } -} - -static void seat_request_set_selection(struct wl_listener *listener, void *data) -{ - /* This event is raised by the seat when a client wants to set the selection, - * usually when the user copies something. wlroots allows compositors to - * ignore such requests if they so choose, but in montis we always honor - */ - struct montis_server *server = - wl_container_of(listener, server, request_set_selection); - struct wlr_seat_request_set_selection_event *event = data; - wlr_seat_set_selection(server->seat, event->source, event->serial); -} - -static struct montis_toplevel *desktop_toplevel_at(struct montis_server *server, - double lx, double ly, - struct wlr_surface **surface, - double *sx, double *sy) -{ - /* This returns the topmost node in the scene at the given layout coords. - * We only care about surface nodes as we are specifically looking for a - * surface in the surface tree of a montis_toplevel. */ - struct wlr_scene_node *node = - wlr_scene_node_at(&server->scene->tree.node, lx, ly, sx, sy); - if (node == NULL || node->type != WLR_SCENE_NODE_BUFFER) { - return NULL; - } - struct wlr_scene_buffer *scene_buffer = wlr_scene_buffer_from_node(node); - struct wlr_scene_surface *scene_surface = - wlr_scene_surface_try_from_buffer(scene_buffer); - if (!scene_surface) { - return NULL; - } - - *surface = scene_surface->surface; - /* Find the node corresponding to the montis_toplevel at the root of this - * surface tree, it is the only one for which we set the data field. */ - struct wlr_scene_tree *tree = node->parent; - while (tree != NULL && tree->node.data == NULL) { - tree = tree->node.parent; - } - return tree->node.data; -} - -static void reset_cursor_mode(struct montis_server *server) -{ - /* Reset the cursor mode to passthrough. */ - server->cursor_mode = TINYWL_CURSOR_PASSTHROUGH; - server->grabbed_toplevel = NULL; -} - -static void process_cursor_move(struct montis_server *server, uint32_t time) -{ - /* Move the grabbed toplevel to the new position. */ - struct montis_toplevel *toplevel = server->grabbed_toplevel; - wlr_scene_node_set_position(&toplevel->scene_tree->node, - server->cursor->x - server->grab_x, - server->cursor->y - server->grab_y); -} - -static void process_cursor_resize(struct montis_server *server, uint32_t time) -{ - /* - * Resizing the grabbed toplevel can be a little bit complicated, because we - * could be resizing from any corner or edge. This not only resizes the - * toplevel on one or two axes, but can also move the toplevel if you resize - * from the top or left edges (or top-left corner). - * - * Note that some shortcuts are taken here. In a more fleshed-out - * compositor, you'd wait for the client to prepare a buffer at the new - * size, then commit any movement that was prepared. - */ - struct montis_toplevel *toplevel = server->grabbed_toplevel; - double border_x = server->cursor->x - server->grab_x; - double border_y = server->cursor->y - server->grab_y; - int new_left = server->grab_geobox.x; - int new_right = server->grab_geobox.x + server->grab_geobox.width; - int new_top = server->grab_geobox.y; - int new_bottom = server->grab_geobox.y + server->grab_geobox.height; - - if (server->resize_edges & WLR_EDGE_TOP) { - new_top = border_y; - if (new_top >= new_bottom) { - new_top = new_bottom - 1; - } - } - else if (server->resize_edges & WLR_EDGE_BOTTOM) { - new_bottom = border_y; - if (new_bottom <= new_top) { - new_bottom = new_top + 1; - } - } - if (server->resize_edges & WLR_EDGE_LEFT) { - new_left = border_x; - if (new_left >= new_right) { - new_left = new_right - 1; - } - } - else if (server->resize_edges & WLR_EDGE_RIGHT) { - new_right = border_x; - if (new_right <= new_left) { - new_right = new_left + 1; - } - } - - struct wlr_box geo_box; - wlr_xdg_surface_get_geometry(toplevel->xdg_toplevel->base, &geo_box); - wlr_scene_node_set_position(&toplevel->scene_tree->node, new_left - geo_box.x, - new_top - geo_box.y); - - int new_width = new_right - new_left; - int new_height = new_bottom - new_top; - wlr_xdg_toplevel_set_size(toplevel->xdg_toplevel, new_width, new_height); -} - -static void process_cursor_motion(struct montis_server *server, uint32_t time) -{ - /* If the mode is non-passthrough, delegate to those functions. */ - if (server->cursor_mode == TINYWL_CURSOR_MOVE) { - process_cursor_move(server, time); - return; - } - else if (server->cursor_mode == TINYWL_CURSOR_RESIZE) { - process_cursor_resize(server, time); - return; - } - - /* Otherwise, find the toplevel under the pointer and send the event along. */ - double sx, sy; - struct wlr_seat *seat = server->seat; - struct wlr_surface *surface = NULL; - struct montis_toplevel *toplevel = desktop_toplevel_at( - server, server->cursor->x, server->cursor->y, &surface, &sx, &sy); - if (!toplevel) { - /* If there's no toplevel under the cursor, set the cursor image to a - * default. This is what makes the cursor image appear when you move it - * around the screen, not over any toplevels. */ - wlr_cursor_set_xcursor(server->cursor, server->cursor_mgr, "default"); - } - if (surface) { - /* - * Send pointer enter and motion events. - * - * The enter event gives the surface "pointer focus", which is distinct - * from keyboard focus. You get pointer focus by moving the pointer over - * a window. - * - * Note that wlroots will avoid sending duplicate enter/motion events if - * the surface has already has pointer focus or if the client is already - * aware of the coordinates passed. - */ - wlr_seat_pointer_notify_enter(seat, surface, sx, sy); - wlr_seat_pointer_notify_motion(seat, time, sx, sy); - } - else { - /* Clear pointer focus so future button events and such are not sent to - * the last client to have the cursor over it. */ - wlr_seat_pointer_clear_focus(seat); - } -} - -static void server_cursor_motion(struct wl_listener *listener, void *data) -{ - /* This event is forwarded by the cursor when a pointer emits a _relative_ - * pointer motion event (i.e. a delta) */ - struct montis_server *server = - wl_container_of(listener, server, cursor_motion); - struct wlr_pointer_motion_event *event = data; - /* The cursor doesn't move unless we tell it to. The cursor automatically - * handles constraining the motion to the output layout, as well as any - * special configuration applied for the specific input device which - * generated the event. You can pass NULL for the device if you want to move - * the cursor around without any input. */ - wlr_cursor_move(server->cursor, &event->pointer->base, event->delta_x, - event->delta_y); - process_cursor_motion(server, event->time_msec); -} - -static void server_cursor_motion_absolute(struct wl_listener *listener, - void *data) -{ - /* This event is forwarded by the cursor when a pointer emits an _absolute_ - * motion event, from 0..1 on each axis. This happens, for example, when - * wlroots is running under a Wayland window rather than KMS+DRM, and you - * move the mouse over the window. You could enter the window from any edge, - * so we have to warp the mouse there. There is also some hardware which - * emits these events. */ - struct montis_server *server = - wl_container_of(listener, server, cursor_motion_absolute); - struct wlr_pointer_motion_absolute_event *event = data; - wlr_cursor_warp_absolute(server->cursor, &event->pointer->base, event->x, - event->y); - process_cursor_motion(server, event->time_msec); -} - -static void server_cursor_button(struct wl_listener *listener, void *data) -{ - /* This event is forwarded by the cursor when a pointer emits a button - * event. */ - struct montis_server *server = - wl_container_of(listener, server, cursor_button); - struct wlr_pointer_button_event *event = data; - struct wlr_seat *seat = server->seat; - struct wlr_keyboard *keyboard = wlr_seat_get_keyboard(seat); - uint32_t modifiers = wlr_keyboard_get_modifiers(keyboard); - - plugin_call_update_state(server->plugin, plugin_handle_button, event, - modifiers); - - /* Notify the client with pointer focus that a button press has occurred */ - // wlr_seat_pointer_notify_button(server->seat, event->time_msec, - // event->button, - // event->state); - // double sx, sy; - // struct wlr_surface *surface = NULL; - // struct montis_toplevel *toplevel = desktop_toplevel_at( - // server, server->cursor->x, server->cursor->y, &surface, &sx, &sy); - // if (event->state == WLR_BUTTON_RELEASED) { - // /* If you released any buttons, we exit interactive move/resize mode. */ - // reset_cursor_mode(server); - // } - // else { - // /* Focus that client if the button was _pressed_ */ - // focus_toplevel(toplevel, surface); - // } -} - -static void server_cursor_axis(struct wl_listener *listener, void *data) -{ - /* This event is forwarded by the cursor when a pointer emits an axis event, - * for example when you move the scroll wheel. */ - struct montis_server *server = wl_container_of(listener, server, cursor_axis); - struct wlr_pointer_axis_event *event = data; - /* Notify the client with pointer focus of the axis event. */ - wlr_seat_pointer_notify_axis( - server->seat, event->time_msec, event->orientation, event->delta, - event->delta_discrete, event->source, event->relative_direction); -} - -static void server_cursor_frame(struct wl_listener *listener, void *data) -{ - /* This event is forwarded by the cursor when a pointer emits an frame - * event. Frame events are sent after regular pointer events to group - * multiple events together. For instance, two axis events may happen at the - * same time, in which case a frame event won't be sent in between. */ - struct montis_server *server = - wl_container_of(listener, server, cursor_frame); - /* Notify the client with pointer focus of the frame event. */ - wlr_seat_pointer_notify_frame(server->seat); -} - -static void output_frame(struct wl_listener *listener, void *data) -{ - /* This function is called every time an output is ready to display a frame, - * generally at the output's refresh rate (e.g. 60Hz). */ - struct montis_output *output = wl_container_of(listener, output, frame); - struct wlr_scene *scene = output->server->scene; - - struct wlr_scene_output *scene_output = - wlr_scene_get_scene_output(scene, output->wlr_output); - - /* Render the scene if needed and commit the output */ - wlr_scene_output_commit(scene_output, NULL); - - struct timespec now; - clock_gettime(CLOCK_MONOTONIC, &now); - wlr_scene_output_send_frame_done(scene_output, &now); -} - -static void output_request_state(struct wl_listener *listener, void *data) -{ - /* This function is called when the backend requests a new state for - * the output. For example, Wayland and X11 backends request a new mode - * when the output window is resized. */ - struct montis_output *output = - wl_container_of(listener, output, request_state); - const struct wlr_output_event_request_state *event = data; - wlr_output_commit_state(output->wlr_output, event->state); -} - -static void output_destroy(struct wl_listener *listener, void *data) -{ - struct montis_output *output = wl_container_of(listener, output, destroy); - - wl_list_remove(&output->frame.link); - wl_list_remove(&output->request_state.link); - wl_list_remove(&output->destroy.link); - wl_list_remove(&output->link); - free(output); -} - -static void server_new_output(struct wl_listener *listener, void *data) -{ - /* This event is raised by the backend when a new output (aka a display or - * monitor) becomes available. */ - struct montis_server *server = wl_container_of(listener, server, new_output); - struct wlr_output *wlr_output = data; - - /* Configures the output created by the backend to use our allocator - * and our renderer. Must be done once, before commiting the output */ - wlr_output_init_render(wlr_output, server->allocator, server->renderer); - - /* The output may be disabled, switch it on. */ - struct wlr_output_state state; - wlr_output_state_init(&state); - wlr_output_state_set_enabled(&state, true); - - /* Some backends don't have modes. DRM+KMS does, and we need to set a mode - * before we can use the output. The mode is a tuple of (width, height, - * refresh rate), and each monitor supports only a specific set of modes. We - * just pick the monitor's preferred mode, a more sophisticated compositor - * would let the user configure it. */ - struct wlr_output_mode *mode = wlr_output_preferred_mode(wlr_output); - if (mode != NULL) { - wlr_output_state_set_mode(&state, mode); - } - - /* Atomically applies the new output state. */ - wlr_output_commit_state(wlr_output, &state); - wlr_output_state_finish(&state); - - /* Allocates and configures our state for this output */ - struct montis_output *output = calloc(1, sizeof(*output)); - output->wlr_output = wlr_output; - output->server = server; - - /* Sets up a listener for the frame event. */ - output->frame.notify = output_frame; - wl_signal_add(&wlr_output->events.frame, &output->frame); - - /* Sets up a listener for the state request event. */ - output->request_state.notify = output_request_state; - wl_signal_add(&wlr_output->events.request_state, &output->request_state); - - /* Sets up a listener for the destroy event. */ - output->destroy.notify = output_destroy; - wl_signal_add(&wlr_output->events.destroy, &output->destroy); - - wl_list_insert(&server->outputs, &output->link); - - /* Adds this to the output layout. The add_auto function arranges outputs - * from left-to-right in the order they appear. A more sophisticated - * compositor would let the user configure the arrangement of outputs in the - * layout. - * - * The output layout utility automatically adds a wl_output global to the - * display, which Wayland clients can see to find out information about the - * output (such as DPI, scale factor, manufacturer, etc). - */ - struct wlr_output_layout_output *l_output = - wlr_output_layout_add_auto(server->output_layout, wlr_output); - struct wlr_scene_output *scene_output = - wlr_scene_output_create(server->scene, wlr_output); - wlr_scene_output_layout_add_output(server->scene_layout, l_output, - scene_output); -} - -static void xdg_toplevel_map(struct wl_listener *listener, void *data) -{ - /* Called when the surface is mapped, or ready to display on-screen. */ - struct montis_toplevel *toplevel = wl_container_of(listener, toplevel, map); - - wl_list_insert(&toplevel->server->toplevels, &toplevel->link); - - fprintf(stderr, "Surface map ...\n"); - plugin_call_update_state(toplevel->server->plugin, plugin_handle_surface, - toplevel, SURFACE_MAP); - fprintf(stderr, "/ Surface map ...\n"); - - focus_toplevel(toplevel, toplevel->xdg_toplevel->base->surface); -} - -static void xdg_toplevel_unmap(struct wl_listener *listener, void *data) -{ - /* Called when the surface is unmapped, and should no longer be shown. */ - struct montis_toplevel *toplevel = wl_container_of(listener, toplevel, unmap); - - /* Reset the cursor mode if the grabbed toplevel was unmapped. */ - if (toplevel == toplevel->server->grabbed_toplevel) { - reset_cursor_mode(toplevel->server); - } - - fprintf(stderr, "Surface unmap ...\n"); - plugin_call_update_state(toplevel->server->plugin, plugin_handle_surface, - toplevel, SURFACE_UNMAP); - fprintf(stderr, "/ Surface map ...\n"); - - wl_list_remove(&toplevel->link); -} - -static void xdg_toplevel_destroy(struct wl_listener *listener, void *data) -{ - /* Called when the xdg_toplevel is destroyed. */ - struct montis_toplevel *toplevel = - wl_container_of(listener, toplevel, destroy); - - wl_list_remove(&toplevel->map.link); - wl_list_remove(&toplevel->unmap.link); - wl_list_remove(&toplevel->destroy.link); - wl_list_remove(&toplevel->request_move.link); - wl_list_remove(&toplevel->request_resize.link); - wl_list_remove(&toplevel->request_maximize.link); - wl_list_remove(&toplevel->request_fullscreen.link); - - fprintf(stderr, "Surface destroy ...\n"); - plugin_call_update_state(toplevel->server->plugin, plugin_handle_surface, - toplevel, SURFACE_DELETE); - fprintf(stderr, "/ Surface destroy ...\n"); - - free(toplevel); -} - -static void begin_interactive(struct montis_toplevel *toplevel, - enum montis_cursor_mode mode, uint32_t edges) -{ - /* This function sets up an interactive move or resize operation, where the - * compositor stops propegating pointer events to clients and instead - * consumes them itself, to move or resize windows. */ - struct montis_server *server = toplevel->server; - struct wlr_surface *focused_surface = - server->seat->pointer_state.focused_surface; - if (toplevel->xdg_toplevel->base->surface != - wlr_surface_get_root_surface(focused_surface)) { - /* Deny move/resize requests from unfocused clients. */ - return; - } - server->grabbed_toplevel = toplevel; - server->cursor_mode = mode; - - if (mode == TINYWL_CURSOR_MOVE) { - server->grab_x = server->cursor->x - toplevel->scene_tree->node.x; - server->grab_y = server->cursor->y - toplevel->scene_tree->node.y; - } - else { - struct wlr_box geo_box; - wlr_xdg_surface_get_geometry(toplevel->xdg_toplevel->base, &geo_box); - - double border_x = (toplevel->scene_tree->node.x + geo_box.x) + - ((edges & WLR_EDGE_RIGHT) ? geo_box.width : 0); - double border_y = (toplevel->scene_tree->node.y + geo_box.y) + - ((edges & WLR_EDGE_BOTTOM) ? geo_box.height : 0); - server->grab_x = server->cursor->x - border_x; - server->grab_y = server->cursor->y - border_y; - - server->grab_geobox = geo_box; - server->grab_geobox.x += toplevel->scene_tree->node.x; - server->grab_geobox.y += toplevel->scene_tree->node.y; - - server->resize_edges = edges; - } -} - -static void xdg_toplevel_request_move(struct wl_listener *listener, void *data) -{ - /* This event is raised when a client would like to begin an interactive - * move, typically because the user clicked on their client-side - * decorations. Note that a more sophisticated compositor should check the - * provided serial against a list of button press serials sent to this - * client, to prevent the client from requesting this whenever they want. */ - struct montis_toplevel *toplevel = - wl_container_of(listener, toplevel, request_move); - begin_interactive(toplevel, TINYWL_CURSOR_MOVE, 0); -} - -static void xdg_toplevel_request_resize(struct wl_listener *listener, - void *data) -{ - /* This event is raised when a client would like to begin an interactive - * resize, typically because the user clicked on their client-side - * decorations. Note that a more sophisticated compositor should check the - * provided serial against a list of button press serials sent to this - * client, to prevent the client from requesting this whenever they want. */ - struct wlr_xdg_toplevel_resize_event *event = data; - struct montis_toplevel *toplevel = - wl_container_of(listener, toplevel, request_resize); - begin_interactive(toplevel, TINYWL_CURSOR_RESIZE, event->edges); -} - -static void xdg_toplevel_request_maximize(struct wl_listener *listener, - void *data) -{ - /* This event is raised when a client would like to maximize itself, - * typically because the user clicked on the maximize button on - * client-side decorations. montis doesn't support maximization, but - * to conform to xdg-shell protocol we still must send a configure. - * wlr_xdg_surface_schedule_configure() is used to send an empty reply. */ - struct montis_toplevel *toplevel = - wl_container_of(listener, toplevel, request_maximize); - wlr_xdg_surface_schedule_configure(toplevel->xdg_toplevel->base); -} - -static void xdg_toplevel_request_fullscreen(struct wl_listener *listener, - void *data) -{ - /* Just as with request_maximize, we must send a configure here. */ - struct montis_toplevel *toplevel = - wl_container_of(listener, toplevel, request_fullscreen); - wlr_xdg_surface_schedule_configure(toplevel->xdg_toplevel->base); -} - -static void xdg_popup_commit(struct wl_listener *listener, void *data) { - /* Called when a new surface state is committed. */ - struct montis_popup *popup = wl_container_of(listener, popup, commit); - - if (popup->xdg_popup->base->initial_commit) { - /* When an xdg_surface performs an initial commit, the compositor must - * reply with a configure so the client can map the surface. - * montis sends an empty configure. A more sophisticated compositor - * might change an xdg_popup's geometry to ensure it's not positioned - * off-screen, for example. */ - wlr_xdg_surface_schedule_configure(popup->xdg_popup->base); - } -} - -static void xdg_popup_destroy(struct wl_listener *listener, void *data) { - /* Called when the xdg_popup is destroyed. */ - struct montis_popup *popup = wl_container_of(listener, popup, destroy); - - wl_list_remove(&popup->commit.link); - wl_list_remove(&popup->destroy.link); - - free(popup); -} - -static void server_new_xdg_popup(struct wl_listener *listener, void *data) { - /* This event is raised when a client creates a new popup. */ - struct wlr_xdg_popup *xdg_popup = data; - - struct montis_popup *popup = calloc(1, sizeof(*popup)); - popup->xdg_popup = xdg_popup; - - /* We must add xdg popups to the scene graph so they get rendered. The - * wlroots scene graph provides a helper for this, but to use it we must - * provide the proper parent scene node of the xdg popup. To enable this, - * we always set the user data field of xdg_surfaces to the corresponding - * scene node. */ - struct wlr_xdg_surface *parent = wlr_xdg_surface_try_from_wlr_surface(xdg_popup->parent); - assert(parent != NULL); - struct wlr_scene_tree *parent_tree = parent->data; - xdg_popup->base->data = wlr_scene_xdg_surface_create(parent_tree, xdg_popup->base); - - popup->commit.notify = xdg_popup_commit; - wl_signal_add(&xdg_popup->base->surface->events.commit, &popup->commit); - - popup->destroy.notify = xdg_popup_destroy; - wl_signal_add(&xdg_popup->events.destroy, &popup->destroy); -} - -static void xdg_toplevel_commit(struct wl_listener *listener, void *data) { - /* Called when a new surface state is committed. */ - struct montis_toplevel *toplevel = wl_container_of(listener, toplevel, commit); - - if (toplevel->xdg_toplevel->base->initial_commit) { - /* When an xdg_surface performs an initial commit, the compositor must - * reply with a configure so the client can map the surface. montis - * configures the xdg_toplevel with 0,0 size to let the client pick the - * dimensions itself. */ - wlr_xdg_toplevel_set_size(toplevel->xdg_toplevel, 0, 0); - } -} - -static void server_new_xdg_toplevel(struct wl_listener *listener, void *data) -{ - /* This event is raised when a client creates a new toplevel (application window). */ - struct montis_server *server = wl_container_of(listener, server, new_xdg_toplevel); - struct wlr_xdg_toplevel *xdg_toplevel = data; - - /* Allocate a montis_toplevel for this surface */ - struct montis_toplevel *toplevel = calloc(1, sizeof(*toplevel)); - toplevel->server = server; - toplevel->xdg_toplevel = xdg_toplevel; - toplevel->scene_tree = - wlr_scene_xdg_surface_create(&toplevel->server->scene->tree, xdg_toplevel->base); - toplevel->scene_tree->node.data = toplevel; - xdg_toplevel->base->data = toplevel->scene_tree; - - /* Listen to the various events it can emit */ - toplevel->map.notify = xdg_toplevel_map; - wl_signal_add(&xdg_toplevel->base->surface->events.map, &toplevel->map); - toplevel->unmap.notify = xdg_toplevel_unmap; - wl_signal_add(&xdg_toplevel->base->surface->events.unmap, &toplevel->unmap); - toplevel->commit.notify = xdg_toplevel_commit; - wl_signal_add(&xdg_toplevel->base->surface->events.commit, &toplevel->commit); - - toplevel->destroy.notify = xdg_toplevel_destroy; - wl_signal_add(&xdg_toplevel->events.destroy, &toplevel->destroy); - - /* cotd */ - toplevel->request_move.notify = xdg_toplevel_request_move; - wl_signal_add(&xdg_toplevel->events.request_move, &toplevel->request_move); - toplevel->request_resize.notify = xdg_toplevel_request_resize; - wl_signal_add(&xdg_toplevel->events.request_resize, &toplevel->request_resize); - toplevel->request_maximize.notify = xdg_toplevel_request_maximize; - wl_signal_add(&xdg_toplevel->events.request_maximize, &toplevel->request_maximize); - toplevel->request_fullscreen.notify = xdg_toplevel_request_fullscreen; - wl_signal_add(&xdg_toplevel->events.request_fullscreen, &toplevel->request_fullscreen); -} - -int main(int argc, char *argv[]) -{ - wlr_log_init(WLR_DEBUG, NULL); - char *startup_cmd = NULL; - char *plugin = NULL; - - int c; - while ((c = getopt(argc, argv, "s:p:h")) != -1) { - switch (c) { - case 's': - startup_cmd = optarg; - break; - case 'p': - plugin = optarg; - break; - default: - printf("Usage: %s -p [plugin] [-s startup command]\n", argv[0]); - return 0; - } - } - if (optind < argc || !plugin) { - printf("Usage: %s -p [plugin] [-s startup command]\n", argv[0]); - return 0; - } - - struct montis_server server = {0}; - - if (load_plugin_from_file(argc, argv, plugin, &server.plugin)) { - fprintf(stderr, "Failed to read plugin from file.\n"); - return 1; - } - - plugin_cold_start(&server.plugin); - - /* The Wayland display is managed by libwayland. It handles accepting - * clients from the Unix socket, manging Wayland globals, and so on. */ - server.wl_display = wl_display_create(); - /* The backend is a wlroots feature which abstracts the underlying input and - * output hardware. The autocreate option will choose the most suitable - * backend based on the current environment, such as opening an X11 window - * if an X11 server is running. */ - server.backend = wlr_backend_autocreate( - wl_display_get_event_loop(server.wl_display), &server.session); - if (server.backend == NULL) { - wlr_log(WLR_ERROR, "failed to create wlr_backend"); - return 1; - } - - /* Autocreates a renderer, either Pixman, GLES2 or Vulkan for us. The user - * can also specify a renderer using the WLR_RENDERER env var. - * The renderer is responsible for defining the various pixel formats it - * supports for shared memory, this configures that for clients. */ - server.renderer = wlr_renderer_autocreate(server.backend); - if (server.renderer == NULL) { - wlr_log(WLR_ERROR, "failed to create wlr_renderer"); - return 1; - } - - wlr_renderer_init_wl_display(server.renderer, server.wl_display); - - /* Autocreates an allocator for us. - * The allocator is the bridge between the renderer and the backend. It - * handles the buffer creation, allowing wlroots to render onto the - * screen */ - server.allocator = wlr_allocator_autocreate(server.backend, server.renderer); - if (server.allocator == NULL) { - wlr_log(WLR_ERROR, "failed to create wlr_allocator"); - return 1; - } - - /* This creates some hands-off wlroots interfaces. The compositor is - * necessary for clients to allocate surfaces, the subcompositor allows to - * assign the role of subsurfaces to surfaces and the data device manager - * handles the clipboard. Each of these wlroots interfaces has room for you - * to dig your fingers in and play with their behavior if you want. Note that - * the clients cannot set the selection directly without compositor approval, - * see the handling of the request_set_selection event below.*/ - wlr_compositor_create(server.wl_display, 5, server.renderer); - wlr_subcompositor_create(server.wl_display); - wlr_data_device_manager_create(server.wl_display); - - /* Creates an output layout, which a wlroots utility for working with an - * arrangement of screens in a physical layout. */ - server.output_layout = wlr_output_layout_create(server.wl_display); - - /* Configure a listener to be notified when new outputs are available on the - * backend. */ - wl_list_init(&server.outputs); - server.new_output.notify = server_new_output; - wl_signal_add(&server.backend->events.new_output, &server.new_output); - - /* Create a scene graph. This is a wlroots abstraction that handles all - * rendering and damage tracking. All the compositor author needs to do - * is add things that should be rendered to the scene graph at the proper - * positions and then call wlr_scene_output_commit() to render a frame if - * necessary. - */ - server.scene = wlr_scene_create(); - server.scene_layout = - wlr_scene_attach_output_layout(server.scene, server.output_layout); - - /* Set up xdg-shell version 3. The xdg-shell is a Wayland protocol which is - * used for application windows. For more detail on shells, refer to - * https://drewdevault.com/2018/07/29/Wayland-shells.html. - */ - wl_list_init(&server.toplevels); - server.xdg_shell = wlr_xdg_shell_create(server.wl_display, 3); - server.new_xdg_toplevel.notify = server_new_xdg_toplevel; - wl_signal_add(&server.xdg_shell->events.new_toplevel, - &server.new_xdg_toplevel); - server.new_xdg_popup.notify = server_new_xdg_popup; - wl_signal_add(&server.xdg_shell->events.new_popup, &server.new_xdg_popup); - - /* - * Creates a cursor, which is a wlroots utility for tracking the cursor - * image shown on screen. - */ - server.cursor = wlr_cursor_create(); - wlr_cursor_attach_output_layout(server.cursor, server.output_layout); - - /* Creates an xcursor manager, another wlroots utility which loads up - * Xcursor themes to source cursor images from and makes sure that cursor - * images are available at all scale factors on the screen (necessary for - * HiDPI support). */ - server.cursor_mgr = wlr_xcursor_manager_create(NULL, 24); - - /* - * wlr_cursor *only* displays an image on screen. It does not move around - * when the pointer moves. However, we can attach input devices to it, and - * it will generate aggregate events for all of them. In these events, we - * can choose how we want to process them, forwarding them to clients and - * moving the cursor around. More detail on this process is described in - * https://drewdevault.com/2018/07/17/Input-handling-in-wlroots.html. - * - * And more comments are sprinkled throughout the notify functions above. - */ - server.cursor_mode = TINYWL_CURSOR_PASSTHROUGH; - server.cursor_motion.notify = server_cursor_motion; - wl_signal_add(&server.cursor->events.motion, &server.cursor_motion); - server.cursor_motion_absolute.notify = server_cursor_motion_absolute; - wl_signal_add(&server.cursor->events.motion_absolute, - &server.cursor_motion_absolute); - server.cursor_button.notify = server_cursor_button; - wl_signal_add(&server.cursor->events.button, &server.cursor_button); - server.cursor_axis.notify = server_cursor_axis; - wl_signal_add(&server.cursor->events.axis, &server.cursor_axis); - server.cursor_frame.notify = server_cursor_frame; - wl_signal_add(&server.cursor->events.frame, &server.cursor_frame); - - /* - * Configures a seat, which is a single "seat" at which a user sits and - * operates the computer. This conceptually includes up to one keyboard, - * pointer, touch, and drawing tablet device. We also rig up a listener to - * let us know when new input devices are available on the backend. - */ - wl_list_init(&server.keyboards); - server.new_input.notify = server_new_input; - wl_signal_add(&server.backend->events.new_input, &server.new_input); - server.seat = wlr_seat_create(server.wl_display, "seat0"); - server.request_cursor.notify = seat_request_cursor; - wl_signal_add(&server.seat->events.request_set_cursor, - &server.request_cursor); - server.request_set_selection.notify = seat_request_set_selection; - wl_signal_add(&server.seat->events.request_set_selection, - &server.request_set_selection); - - /* Add a Unix socket to the Wayland display. */ - const char *socket = wl_display_add_socket_auto(server.wl_display); - if (!socket) { - wlr_backend_destroy(server.backend); - return 1; - } - - /* Start the backend. This will enumerate outputs and inputs, become the DRM - * master, etc */ - if (!wlr_backend_start(server.backend)) { - wlr_backend_destroy(server.backend); - wl_display_destroy(server.wl_display); - return 1; - } - - /* Set the WAYLAND_DISPLAY environment variable to our socket and run the - * startup command if requested. */ - setenv("WAYLAND_DISPLAY", socket, true); - if (startup_cmd) { - if (fork() == 0) { - execl("/bin/sh", "/bin/sh", "-c", startup_cmd, (void *)NULL); - } - } - /* Run the Wayland event loop. This does not return until you exit the - * compositor. Starting the backend rigged up all of the necessary event - * loop configuration to listen to libinput events, DRM events, generate - * frame events at the refresh rate, and so on. */ - wlr_log(WLR_INFO, "Running Wayland compositor on WAYLAND_DISPLAY=%s", socket); - wl_display_run(server.wl_display); - - /* Once wl_display_run returns, we destroy all clients then shut down the - * server. */ - wl_display_destroy_clients(server.wl_display); - wlr_scene_node_destroy(&server.scene->tree.node); - wlr_xcursor_manager_destroy(server.cursor_mgr); - wlr_output_layout_destroy(server.output_layout); - wl_display_destroy(server.wl_display); - return 0; -} diff --git a/harness/tools/genbuild.pl b/harness/tools/genbuild.pl deleted file mode 100644 index 1acabc0..0000000 --- a/harness/tools/genbuild.pl +++ /dev/null @@ -1,48 +0,0 @@ -#!/usr/bin/env perl - -$comment=""; - -print "#include \n"; -print "#include \n"; -print "#include \n"; -print "#include \n"; -print "#include \"plugin.h\"\n\n"; - -print "int load_plugin_from_dl_(dlhandle_t dl, plugin_t* plug)\n"; -print "{\n"; -print " void* ptr;\n"; -print " int ret = 0;\n"; -print "\n"; -print " const char** name = dlsym(dl, \"plugin_name\");\n"; -print " memset(plug, 0, sizeof(*plug));\n"; -print " if (name) {\n"; -print " plug->plugin_name = *name;\n"; -print " } else {\n"; -print " plug->plugin_name = NULL;\n"; -print " }\n"; -print " plug->state = NULL;\n"; -print " plug->library_handle = dl;\n"; -print "\n"; -while (<>) { - if (/^\s*EXPORT/) { - my $line = "$_"; - while (not ($line =~ /;$/)) { - my $nextline = ; - last unless defined $nextline; - - $line="$line$nextline"; - } - if ($line =~ /^\s*EXPORT\(\s*((?:\w|\s*\*\s*)+)\s*\(\*(\w+)\)\s*\((.*)\)\);/s) { - print "\n"; - print " ptr = dlsym(dl, \"$2\");\n"; - print " if (!ptr) {\n"; - print " fprintf(stderr, \"Plugin missing %s\\n\", \"$2\");\n"; - print " ret |= 1;\n"; - print " }\n"; - print " plug->$2 = ptr;\n"; - $comment=""; - } - } -} -print "\n return ret;\n"; -print "}\n"; diff --git a/harness/tools/genintf.pl b/harness/tools/genintf.pl deleted file mode 100644 index 794f966..0000000 --- a/harness/tools/genintf.pl +++ /dev/null @@ -1,42 +0,0 @@ -#!/usr/bin/env perl - -$comment=""; - -print "#ifndef _PLUG_INTF\n"; -print "#define _PLUG_INTF\n"; -print "\n#include \n"; -print "\n#include \n"; - -while () { - if (/^\s*\/\*/) { - $_ =~ s/^\s*//; - $comment="$_"; - next; - } - - if (/^\s*\*/) { - $_ =~ s/^\s*/ /; - $comment="$comment$_"; - next; - } - - if (/^\s*EXPORT_INCLUDE\((.*)\)/) { - print "#include $1\n"; - } elsif (/^\s*EXPORT/) { - my $line = "$_"; - while (not ($line =~ /;$/)) { - my $nextline = ; - last unless defined $nextline; - - $line="$line$nextline"; - } - if ($line =~ /^\s*EXPORT\(\s*((?:\w|\s*\*\s*)+)\s*\(\*(\w+)\)\s*\((.*)\)\);/s) { - print "$comment"; - print "$1 $2($3);\n\n"; - $comment=""; - } elsif ($line =~ /^\s*EXPORT\((.*)\);/s) { - print "$1\n"; - } - } -} -print "#endif /* _PLUG_INTF */\n"; diff --git a/package.yaml b/package.yaml deleted file mode 100644 index d9e4add..0000000 --- a/package.yaml +++ /dev/null @@ -1,95 +0,0 @@ -name: wetterhorn - -github: "githubuser/wetterhorn" -license: BSD-3-Clause -author: "Author name here" -maintainer: "example@example.com" -copyright: "2024 Author name here" - -extra-source-files: -- README.md - -# Metadata used when publishing your package -# synopsis: Short description of your package -# category: Web - -# To avoid duplicated efforts in documentation and dealing with the -# complications of embedding Haddock markup inside cabal files, it is -# common to point users to the README.md file. -description: Please see the README on GitHub at - - -custom-setup: - dependencies: - - base - - Cabal - - process - - filepath - - unix - - directory - -dependencies: -- base >= 4.7 && < 5 -- mtl -- bytestring -- containers -- data-default-class -- transformers -- monad-loops -- singletons - - -ghc-options: -- -Wall -- -Wcompat -- -Widentities -- -Wincomplete-record-updates -- -Wincomplete-uni-patterns -- -Wmissing-export-lists -- -Wmissing-home-modules -- -Wpartial-fields -- -Wredundant-constraints -- -XGHC2021 -- -XTypeFamilies -- -XUndecidableInstances -- -XGADTs -- -XFunctionalDependencies -- -XUndecidableSuperClasses -- -XDefaultSignatures -- -XViewPatterns -- -XDerivingVia -- -XDisambiguateRecordFields -- -XLambdaCase -- -XDataKinds -- -fPIC - -executables: - wtr.so: - main: Config.hs - source-dirs: src - c-sources: src/harness_adapter.c - ghc-options: - - -shared - - -dynamic - - -no-hs-main - - -lHSrts-1.0.2-ghc9.6.4 - - -O3 - cc-options: - - -g3 - - -O2 - - -shared - - -Iharness/build/ - - -Iharness/include/ - - -Iwlroots/include - - -DWLR_USE_UNSTABLE - -tests: - wetterhorn-test: - main: Spec.hs - source-dirs: test - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - dependencies: - - wetterhorn diff --git a/plug/README.md b/plug/README.md new file mode 100644 index 0000000..5592f08 --- /dev/null +++ b/plug/README.md @@ -0,0 +1 @@ +The Plugin for the Montis Runtime. diff --git a/plug/package.yaml b/plug/package.yaml new file mode 100644 index 0000000..a9f29ae --- /dev/null +++ b/plug/package.yaml @@ -0,0 +1,86 @@ +name: montis + +github: "jrahm/montis" +license: BSD-3-Clause +author: "Author name here" +maintainer: "example@example.com" +copyright: "2024 Author name here" + +extra-source-files: +- README.md + +# Metadata used when publishing your package +# synopsis: Short description of your package +# category: Web + +# To avoid duplicated efforts in documentation and dealing with the +# complications of embedding Haddock markup inside cabal files, it is +# common to point users to the README.md file. +description: Please see the README on GitHub at + + +dependencies: +- base >= 4.7 && < 5 +- mtl +- bytestring +- containers +- data-default-class +- transformers +- monad-loops +- singletons + + +ghc-options: +- -Wall +- -Wcompat +- -Widentities +- -Wincomplete-record-updates +- -Wincomplete-uni-patterns +- -Wmissing-export-lists +- -Wmissing-home-modules +- -Wpartial-fields +- -Wredundant-constraints +- -XGHC2021 +- -XTypeFamilies +- -XUndecidableInstances +- -XGADTs +- -XFunctionalDependencies +- -XUndecidableSuperClasses +- -XDefaultSignatures +- -XViewPatterns +- -XDerivingVia +- -XDisambiguateRecordFields +- -XLambdaCase +- -XDataKinds +- -fPIC + +executables: + montis.so: + main: Config.hs + source-dirs: src + c-sources: src/harness_adapter.c + ghc-options: + - -shared + - -dynamic + - -no-hs-main + - -lHSrts-1.0.2-ghc9.8.4 + - -O3 + cc-options: + - -g3 + - -O2 + - -shared + - -I../build/rt/ + - -I../rt/include/ + - -I../wlroots/include + - -DWLR_USE_UNSTABLE + +tests: + montis-test: + main: Spec.hs + source-dirs: test + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - montis diff --git a/plug/plug.stamp b/plug/plug.stamp new file mode 100644 index 0000000..e69de29 diff --git a/plug/src/Config.hs b/plug/src/Config.hs new file mode 100644 index 0000000..e76e6ea --- /dev/null +++ b/plug/src/Config.hs @@ -0,0 +1,88 @@ +module Config (config) where + +import Control.Monad (unless) +import Data.Bits +import Data.Data (Proxy (Proxy)) +import Wetterhorn.Core.ButtonEvent as ButtonEvent +import Wetterhorn.Core.KeyEvent as KeyEvent +import Wetterhorn.Core.W +import Wetterhorn.Dsl.Bind +import Wetterhorn.Dsl.Input +import Wetterhorn.Keys.Macros +import Wetterhorn.Keys.MagicModifierKey +import Wetterhorn.Layout.Full + +config :: Config WindowLayout +config = + defaultConfig + { hooks = + defaultHooks + { surfaceHook = do + handleSurface + }, + layout = WindowLayout Full, + resetHook = do + useInputHandler $ + withProxies inputProxies $ do + ev <- nextInputEvent + + bind ev (released btnLeft) $ + run $ + wio $ + putStrLn "Left Button Released!!" + + unless (isPressEvent ev) $ do + forwardEvent ev + continue + + bind ev (Shift .+ Mod1 .+ 'R') $ run requestHotReload + + bind ev (Mod1 .+ 't') $ run (shellExec "alacritty") + + bind ev (Mod1 .+ 'p') $ do + ev2 <- nextInputPressEvent + + bind ev2 (Mod1 .+ 'p') $ + run $ + wio $ + putStrLn "Test" + + bind ev (Mod1 .+ btnLeft) $ + run $ + wio $ + putStrLn "Left Button Press!!" + + bind ev (Mod1 .+ 'q') macroStartStopKeybind + + bind ev (weak $ Mod1 .+ '@') macroReplayKeybind + + bind ev (weak $ ModX 5 .+ btnLeft) $ + run $ + wio $ + putStrLn "Fake Modifier With Button!!!" + + bind ev (weak $ ModX 5 .+ 't') $ + run $ + wio $ + putStrLn "Fake Modifier!!" + + forwardEvent ev + } + where + inputProxies :: + Proxy + '[ MacroSupport, + MagicModifierProxy 59 SetXtra -- Only log keys when F1 (keycode 59 is pressed) + ] + inputProxies = Proxy + +data SetXtra + +instance InputProxy SetXtra where + onKeyEvent _ ie = + case ie of + (InputKeyEvent ke@(KeyEvent {KeyEvent.modifiers = modifiers})) -> + return $ InputKeyEvent ke {KeyEvent.modifiers = modifiers .|. modifierToMask (ModX 5)} + (InputButtonEvent be@(ButtonEvent {ButtonEvent.modifiers = modifiers})) -> + return $ InputButtonEvent be {ButtonEvent.modifiers = modifiers .|. modifierToMask (ModX 5)} + _ -> return ie diff --git a/plug/src/Lib.hs b/plug/src/Lib.hs new file mode 100644 index 0000000..d36ff27 --- /dev/null +++ b/plug/src/Lib.hs @@ -0,0 +1,6 @@ +module Lib + ( someFunc + ) where + +someFunc :: IO () +someFunc = putStrLn "someFunc" diff --git a/plug/src/Wetterhorn/Constraints.hs b/plug/src/Wetterhorn/Constraints.hs new file mode 100644 index 0000000..129fd6c --- /dev/null +++ b/plug/src/Wetterhorn/Constraints.hs @@ -0,0 +1,13 @@ +-- | Contains useful constraints and constraint combinators for type-level +-- metaprogramming. +module Wetterhorn.Constraints where + +-- | A null constraint. All types implement this. +class Unconstrained a + +instance Unconstrained a + +-- | Combines multiple constraints by 'And'ing them together. +class (c1 a, c2 a) => (&&&&) c1 c2 a + +instance (c1 a, c2 a) => (&&&&) c1 c2 a diff --git a/plug/src/Wetterhorn/Core.hs b/plug/src/Wetterhorn/Core.hs new file mode 100644 index 0000000..d853191 --- /dev/null +++ b/plug/src/Wetterhorn/Core.hs @@ -0,0 +1,152 @@ +{-# HLINT ignore "Use camelCase" #-} + +module Wetterhorn.Core +-- ( WState (..), +-- WConfig (..), +-- SurfaceState (..), +-- W, +-- getWConfig, +-- getWState, +-- runW, +-- Wetterhorn, +-- initWetterhorn, +-- wio, +-- incrementState, +-- readWState, +-- defaultConfig, +-- requestHotReload, +-- ctxConfig, +-- KeyEvent (..), +-- KeyState (..), +-- ) +where + +-- import Control.Arrow (first) +-- import Control.Exception +-- import Data.ByteString (ByteString) +-- import Data.Char (ord) +-- import Data.Map (Map) +-- import Foreign (Ptr, StablePtr, Word32, newStablePtr) +-- import Text.Printf +-- import Wetterhorn.Foreign.ForeignInterface (ForeignInterface) +-- import Wetterhorn.Foreign.WlRoots +-- import qualified Data.ByteString.Char8 as CH +-- import qualified Data.Map as Map +-- import qualified Wetterhorn.Foreign.ForeignInterface as ForeignInterface +-- +-- data WContext = WContext +-- { ctxForeignInterface :: ForeignInterface, +-- ctxConfig :: WConfig +-- } +-- +-- -- This is the OpaqueState passed to the harness. +-- type Wetterhorn = StablePtr (WContext, WState) +-- +-- requestHotReload :: W () +-- requestHotReload = do +-- fi <- ctxForeignInterface <$> getWContext +-- wio $ ForeignInterface.requestHotReload fi +-- +-- requestLog :: String -> W () +-- requestLog str = do +-- fi <- ctxForeignInterface <$> getWContext +-- wio $ ForeignInterface.requestLog fi str +-- +-- requestExit :: Int -> W () +-- requestExit ec = do +-- fi <- ctxForeignInterface <$> getWContext +-- wio $ ForeignInterface.requestExit fi ec +-- +-- initWetterhorn :: WConfig -> IO Wetterhorn +-- initWetterhorn conf = do +-- foreignInterface <- ForeignInterface.getForeignInterface +-- newStablePtr (WContext foreignInterface conf, WState "this is a string" 0) +-- +-- defaultBindings :: Map (KeyState, Word32, Word32) (W ()) +-- defaultBindings = +-- Map.fromList +-- [ ((KeyPressed, 0x9, sym 'Q'), requestHotReload), +-- ((KeyPressed, 0x8, sym 'r'), wio $ ForeignInterface.doShellExec "wofi --show run"), +-- ((KeyPressed, 0x8, sym 'l'), requestLog "This is a log statement!\n"), +-- ((KeyPressed, 0x8, sym 't'), wio $ ForeignInterface.doShellExec "alacritty"), +-- ((KeyPressed, 0x9, sym 'T'), wio $ ForeignInterface.doShellExec "gnome-terminal"), +-- ((KeyPressed, 0x8, sym 'c'), wio $ ForeignInterface.doShellExec "pavucontrol"), +-- ( (KeyPressed, 0x8, sym 'p'), +-- wio $ do +-- putStrLn "Maps:" +-- putStrLn =<< readFile "/proc/self/maps" +-- ), +-- ((KeyPressed, 0x8, sym 'q'), requestExit 0) +-- ] +-- where +-- sym = fromIntegral . ord +-- +-- defaultConfig :: WConfig +-- defaultConfig = +-- WConfig +-- { keybindingHandler = \keyEvent -> do +-- seatPtr <- (wio . ForeignInterface.getSeat . ctxForeignInterface) =<< getWContext +-- +-- maybe +-- ( wio $ do +-- wlrSeatSetKeyboard seatPtr (device keyEvent) +-- wlrSeatKeyboardNotifyKey +-- seatPtr +-- (timeMs keyEvent) +-- (keycode keyEvent) +-- ( case state keyEvent of +-- KeyReleased -> 0 +-- _ -> 1 +-- ) +-- +-- return True +-- ) +-- (fmap (const True)) +-- $ Map.lookup +-- (state keyEvent, modifiers keyEvent, keysym keyEvent) +-- defaultBindings, +-- surfaceHandler = \state surface -> wio (printf "Surface %s is %s\n" (show surface) (show state)) +-- } +-- +-- readWState :: ByteString -> IO WState +-- readWState bs = +-- catch +-- (return $ read (CH.unpack bs)) +-- ( \e -> +-- let _ = (e :: SomeException) in return (WState "" 0) +-- ) +-- +-- newtype W a = W ((WContext, WState) -> IO (a, WState)) +-- +-- instance Functor W where +-- fmap mfn (W fn) = W $ fmap (first mfn) <$> fn +-- +-- instance Applicative W where +-- pure a = W $ \(_, s) -> return (a, s) +-- mfn <*> ma = do +-- fn <- mfn +-- fn <$> ma +-- +-- instance Monad W where +-- (W fntoa) >>= fnmb = W $ \(config, state) -> do +-- (a, state') <- fntoa (config, state) +-- let W fntob = fnmb a +-- fntob (config, state') +-- +-- getWContext :: W WContext +-- getWContext = W pure +-- +-- getWConfig :: W WConfig +-- getWConfig = ctxConfig <$> getWContext +-- +-- getWState :: W WState +-- getWState = W $ \(_, s) -> pure (s, s) +-- +-- runW :: W a -> (WContext, WState) -> IO (a, WState) +-- runW (W fn) = fn +-- +-- incrementState :: W Int +-- incrementState = W $ \(_, WState s i) -> return (i, WState s (i + 1)) +-- +-- wio :: IO a -> W a +-- wio fn = W $ \(_, b) -> fn >>= \a -> return (a, b) diff --git a/plug/src/Wetterhorn/Core/ButtonEvent.hs b/plug/src/Wetterhorn/Core/ButtonEvent.hs new file mode 100644 index 0000000..cc3d905 --- /dev/null +++ b/plug/src/Wetterhorn/Core/ButtonEvent.hs @@ -0,0 +1,15 @@ +module Wetterhorn.Core.ButtonEvent where + +import Wetterhorn.Foreign.WlRoots +import Data.Word (Word32) +import Foreign (Ptr) + +data ButtonState = ButtonReleased | ButtonPressed deriving (Show, Read, Eq, Enum, Ord) + +data ButtonEvent = ButtonEvent { + pointer :: Ptr WlrPointer, + timeMs :: Word32, + button :: Word32, + modifiers :: Word32, + state :: ButtonState +} deriving (Eq, Show, Ord) diff --git a/plug/src/Wetterhorn/Core/KeyEvent.hs b/plug/src/Wetterhorn/Core/KeyEvent.hs new file mode 100644 index 0000000..77d273f --- /dev/null +++ b/plug/src/Wetterhorn/Core/KeyEvent.hs @@ -0,0 +1,22 @@ +module Wetterhorn.Core.KeyEvent + ( KeyEvent (..), + KeyState (..), + ) +where + +import Data.Word (Word32) +import Foreign (Ptr) +import Wetterhorn.Foreign.WlRoots + +data KeyState = KeyPressed | KeyReleased deriving (Show, Read, Eq, Enum, Ord) + +data KeyEvent = KeyEvent + { timeMs :: Word32, + keycode :: Word32, + state :: KeyState, + modifiers :: Word32, + keysym :: Word32, + codepoint :: Char, + device :: Ptr WlrInputDevice + } + deriving (Show, Ord, Eq) diff --git a/plug/src/Wetterhorn/Core/Keys.hs b/plug/src/Wetterhorn/Core/Keys.hs new file mode 100644 index 0000000..54d7125 --- /dev/null +++ b/plug/src/Wetterhorn/Core/Keys.hs @@ -0,0 +1,239 @@ +module Wetterhorn.Core.Keys where + +import Control.Monad (forever, void, when) +import Control.Monad.Cont.Class +import Control.Monad.IO.Class +import Control.Monad.State (MonadState (get, put), MonadTrans (lift), StateT, evalStateT, gets, modify) +import Control.Monad.Trans.Cont +import Data.Bits +import Data.Word +import Wetterhorn.Core.ButtonEvent (ButtonEvent) +import Wetterhorn.Core.KeyEvent +import qualified Wetterhorn.Core.KeyEvent as KeyEvent +import qualified Wetterhorn.Core.ButtonEvent as ButtonEvent +import Wetterhorn.Core.W +import Wetterhorn.Foreign.WlRoots (wlrSeatKeyboardNotifyKey, wlrSeatSetKeyboard) + +-- | Forwards the given key event to the focused window. +forwardKey :: KeyEvent -> W () +forwardKey keyEvent = do + seatPtr <- getSeat + wio $ do + wlrSeatSetKeyboard + seatPtr + (device keyEvent) + + wlrSeatKeyboardNotifyKey + seatPtr + (timeMs keyEvent) + (keycode keyEvent) + ( case state keyEvent of + KeyReleased -> 0 + _ -> 1 + ) + +-- | Forwards the current key event to the focused window. +forwardEvent :: KeyEvent -> KeysM () +forwardEvent = liftW . forwardKey + +-- | Enumeration of possible modifiers +data Modifier = Shift | Lock | Control | Mod1 | Mod2 | Mod3 | Mod4 | Mod5 + deriving (Eq, Ord, Show, Read, Enum, Bounded) + +-- | Converts a modifier to its associated mask. +modifierToMask :: Modifier -> Word32 +modifierToMask m = + 1 + `shiftL` case m of + Shift -> 0 + Lock -> 1 + Control -> 2 + Mod1 -> 3 + Mod2 -> 4 + Mod3 -> 5 + Mod4 -> 6 + Mod5 -> 7 + +data KeysState = KeysState + { -- | Reference to the top. Used for a continue statement. + keysTop :: KeysM (), + handleContinuation :: KeyContinuation -> W () + } + +-- | The Keys monad. This monad abstracts away control flow for handling key +-- bindings. This makes it easy to make key-sequence bindings. +-- newtype KeysM a = KeysM ((KeyEvent -> W ()) -> KeyEvent -> W (KeysMR a)) +newtype KeysM a = KeysM (ContT () (StateT KeysState W) a) + deriving (Monad, Functor, Applicative, MonadCont, MonadIO) + +-- | KeysM can be lifted from a W action. +instance Wlike KeysM where + liftW = KeysM . lift . lift + +type KeyContinuation = KeyEvent -> W () + +useKeysWithContinuation :: (KeyContinuation -> W ()) -> KeysM () -> W () +useKeysWithContinuation continuation (forever -> km@(KeysM c)) = + evalStateT (evalContT c) (KeysState km continuation) + +useKeys :: KeysM () -> W () +useKeys = useKeysWithContinuation putKeyHandler + +-- | Returns the next key event. +nextKeyEvent :: KeysM KeyEvent +nextKeyEvent = do + st <- KeysM $ lift get + KeysM $ + shiftT + ( \keyHandler -> + lift . lift $ + handleContinuation st (\kp -> evalStateT (keyHandler kp) st) + ) + +-- | Discards the rest of the continuation and starts again from the top. Useful +-- for keybinds where once the key is handled, there's nothing left to do. +continue :: KeysM () +continue = do + st <- KeysM $ lift get + let (KeysM topCont) = keysTop st + + -- This shift discards the rest of the computation and instead returns to the + -- top of the handler. + KeysM $ shiftT (\_ -> resetT topCont) + +-- | Returns the "top" continuation. +getTop :: KeysM (KeysM ()) +getTop = KeysM (gets keysTop) + +putKeyHandler :: KeyContinuation -> W () +putKeyHandler handler = do + s@State {currentHooks = hooks} <- get + put + s + { currentHooks = + hooks + { keyHook = void <$> handler + } + } + +nextButtonEvent :: KeysM ButtonEvent +nextButtonEvent = do + st <- KeysM get + KeysM $ + shiftT $ \h -> + lift $ lift $ putButtonHandler (\ev -> evalStateT (h ev) st) + where + putButtonHandler h = do + modify $ \st -> st {currentHooks = (currentHooks st) {buttonHook = h}} + +nextButtonOrKeyEvent :: KeysM (Either ButtonEvent KeyEvent) +nextButtonOrKeyEvent = do + st <- KeysM get + KeysM $ + shiftT $ \rest -> + lift $ lift $ do + putButtonHandler (\ev -> evalStateT (rest (Left ev)) st) + handleContinuation st (\ev -> evalStateT (rest (Right ev)) st) + + where + putButtonHandler h = do + modify $ \st -> st {currentHooks = (currentHooks st) {buttonHook = h}} + +nextButtonOrKeyPress :: KeysM (Either ButtonEvent KeyEvent) +nextButtonOrKeyPress = do + ev <- nextButtonOrKeyEvent + case ev of + Left bev | ButtonEvent.state bev == ButtonEvent.ButtonPressed -> return ev + Left bev -> forwardButtonEvent bev >> nextButtonOrKeyPress + Right kev | KeyEvent.state kev == KeyEvent.KeyPressed -> return ev + Right kev -> forwardEvent kev >> nextButtonOrKeyPress + + where + forwardButtonEvent _ = return () + + +-- | Returns the next KeyPressed event. This is likely what 90% of use cases +-- want rather than nextKeyEvent. +nextKeyPress :: KeysM KeyEvent +nextKeyPress = do + k <- nextKeyEvent + if KeyEvent.state k /= KeyPressed + then forwardEvent k >> nextKeyPress + else return k + +-- +-- binding EDSL used to expressively create key bindings and subbindings inside +-- a KeysM () context. +-- + +data KeyMatcher = KeyMatcher Word32 Char + deriving (Show) + +-- | Like a KeyMatcher, but allows additional modifiers to be pressed, not just +-- the exact ones given. +newtype WeakKeyMatcher = WeakKeyMatcher KeyMatcher + +-- | Converts a KeyMatcher to a weak key matcher. +weak :: KeyMatcher -> WeakKeyMatcher +weak = WeakKeyMatcher + +class KeyMatcherId r where + toKeyMatcher :: r -> KeyMatcher + +instance KeyMatcherId KeyMatcher where + toKeyMatcher = id + +instance KeyMatcherId Char where + toKeyMatcher = KeyMatcher 0 + +class KeyMatcherBuilder b where + (.+) :: (KeyMatcherId i) => b -> i -> KeyMatcher + +instance KeyMatcherBuilder Modifier where + (.+) m (toKeyMatcher -> (KeyMatcher mods ch)) = + KeyMatcher (mods .|. modifierToMask m) ch + +infixr 9 .+ + +class MatchKey m where + matchKey :: m -> KeyEvent -> Bool + +instance MatchKey (KeyEvent -> Bool) where + matchKey = ($) + +instance MatchKey Bool where + matchKey = const + +instance MatchKey Char where + matchKey ch ev = ch == KeyEvent.codepoint ev + +instance MatchKey KeyMatcher where + matchKey (KeyMatcher m ch) ev = + ch == KeyEvent.codepoint ev && m == KeyEvent.modifiers ev + +instance MatchKey WeakKeyMatcher where + matchKey (WeakKeyMatcher (KeyMatcher m ch)) ev = + ch == KeyEvent.codepoint ev && (m .|. ms) == ms + where + ms = KeyEvent.modifiers ev + +class IsKeysM m where + toKeysM :: m a -> KeysM a + +instance IsKeysM W where + toKeysM = liftW + +instance IsKeysM KeysM where + toKeysM = id + +bind :: (MatchKey m, IsKeysM k) => KeyEvent -> m -> k () -> KeysM () +bind ev m act = do + when (matchKey m ev) $ do + toKeysM act + continue + +ignoreReleaseEvents :: KeyEvent -> KeysM () +ignoreReleaseEvents ev = do + when (KeyEvent.state ev /= KeyEvent.KeyPressed) $ do + forwardEvent ev + continue diff --git a/plug/src/Wetterhorn/Core/SurfaceEvent.hs b/plug/src/Wetterhorn/Core/SurfaceEvent.hs new file mode 100644 index 0000000..3e7eaf3 --- /dev/null +++ b/plug/src/Wetterhorn/Core/SurfaceEvent.hs @@ -0,0 +1,16 @@ +module Wetterhorn.Core.SurfaceEvent + ( SurfaceEvent (..), + SurfaceState (..), + ) +where + +import Wetterhorn.Foreign.WlRoots + +data SurfaceState = Map | Unmap | Destroy + deriving (Eq, Ord, Show, Read, Enum) + +data SurfaceEvent = SurfaceEvent + { state :: SurfaceState, + surface :: Surface + } + deriving (Eq, Ord, Show) diff --git a/plug/src/Wetterhorn/Core/W.hs b/plug/src/Wetterhorn/Core/W.hs new file mode 100644 index 0000000..862f9fa --- /dev/null +++ b/plug/src/Wetterhorn/Core/W.hs @@ -0,0 +1,379 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +module Wetterhorn.Core.W where + +import Control.Arrow (Arrow (first)) +import Control.Monad ((<=<)) +import Control.Monad.RWS (MonadIO (liftIO), MonadReader (..), MonadState, modify) +import Control.Monad.Reader (ReaderT (runReaderT)) +import Control.Monad.State (StateT (runStateT), gets, modify') +import Control.Monad.Trans.Class +import Control.Monad.Trans.Maybe +import Data.Data (TypeRep, Typeable, cast, tyConModule, tyConName, tyConPackage) +import Data.Default.Class (Default, def) +import Data.Kind (Constraint, Type) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Proxy +import Data.Set (Set) +import qualified Data.Set as Set +import Foreign (Ptr, StablePtr, intPtrToPtr, ptrToIntPtr) +import Text.Printf (printf) +import Text.Read hiding (lift) +import Type.Reflection (someTypeRep, someTypeRepTyCon) +import Wetterhorn.Core.ButtonEvent (ButtonEvent) +import Wetterhorn.Core.KeyEvent +import Wetterhorn.Core.SurfaceEvent +import Wetterhorn.Foreign.ForeignInterface (ForeignInterface) +import qualified Wetterhorn.Foreign.ForeignInterface as ForeignInterface +import Wetterhorn.Foreign.WlRoots (Surface, WlrSeat) +import Wetterhorn.StackSet hiding (layout) +import qualified Wetterhorn.StackSet as StackSet + +data RationalRect = RationalRect Rational Rational Rational Rational + +-- | Wrapper for a message. Messages are sent to layout and layouts are supposed +-- to handle them. This hides a typeable parameter. +data Message where + Message :: (Typeable a) => a -> Message + +-- | casts a message to a type. +fromMessage :: (Typeable a) => Message -> Maybe a +fromMessage (Message t) = cast t + +-- | Wraps a type in a message. +toMessage :: (Typeable a) => a -> Message +toMessage = Message + +class (Typeable l) => HandleMessage l where + handleMessage :: Message -> l -> MaybeT W l + handleMessage _ = return + +newtype Window = Window + { surface :: Surface + } + deriving (Show, Ord, Eq, Read) + +-- | Types of this class "lay out" windows by assigning rectangles and handle +-- messages. +class (Typeable l, HandleMessage l) => LayoutClass l where + -- | Constraints on the type to lay out. Sometimes a layout requires the 'a' + -- type to be "Ord", other times "Eq", this is the mechanism by which this + -- constraint is expressed. + type LayoutConstraint l :: Type -> Constraint + + -- | Runs the layout in an impure way returning a modified layout and the list + -- of windows to their rectangles under a monad. + runLayout :: (LayoutConstraint l a) => Stack a -> l -> W (l, [(a, RationalRect)]) + + readLayout :: String -> Maybe l + default readLayout :: (Read l) => String -> Maybe l + readLayout = readMaybe + + serializeLayout :: l -> String + default serializeLayout :: (Show l) => l -> String + serializeLayout = show + + description :: l -> String + default description :: (Show l) => l -> String + description = show + {-# MINIMAL runLayout #-} + +-- | Lifts a pure-layout implementation to a signature that complies with +-- 'runLayout' +pureLayout :: + (Stack a -> l -> [(a, RationalRect)]) -> + Stack a -> + l -> + W (l, [(a, RationalRect)]) +pureLayout fn as l = return (l, fn as l) + +-- A Layout which hides the layout parameter under an existential type and +-- asserts the layout hidden can work with Window types. +data WindowLayout + = forall l a. + (LayoutClass l, LayoutConstraint l a, a ~ Window) => + WindowLayout l + +runWindowLayout :: Stack Window -> WindowLayout -> W (WindowLayout, [(Window, RationalRect)]) +runWindowLayout as (WindowLayout l) = first WindowLayout <$> runLayout as l + +handleWindowMessage :: Message -> WindowLayout -> MaybeT W WindowLayout +handleWindowMessage m (WindowLayout l) = WindowLayout <$> handleMessage m l + +-- | Using the 'Layout' as a witness, parse existentially wrapped windows +-- from a 'String'. +readWindowLayout :: WindowLayout -> String -> WindowLayout +readWindowLayout (WindowLayout l) s + | (Just x) <- readLayout s = + WindowLayout (asTypeOf x l) +readWindowLayout l _ = l + +-- | Serializes a window layout to a string. +serializeWindowLayout :: WindowLayout -> String +serializeWindowLayout (WindowLayout l) = serializeLayout l + +type ScreenId = () + +type ScreenDetail = () + +type Tag = String + +newtype ReadPtr a = ReadPtr (Ptr ()) + +instance Read (ReadPtr a) where + readPrec = fmap (ReadPtr . intPtrToPtr) readPrec + +instance Show (ReadPtr a) where + show (ReadPtr ptr) = show (ptrToIntPtr ptr) + +type Wetterhorn = StablePtr (Context, State) + +data Context = Context + { ctxForeignInterface :: ForeignInterface, + ctxConfig :: Config WindowLayout + } + +defaultHooks :: Hooks +defaultHooks = + Hooks + { keyHook = \_ -> return (), + surfaceHook = handleSurface, + buttonHook = \_ -> return () + } + +defaultConfig :: Config () +defaultConfig = + Config + { hooks = defaultHooks, + layout = (), + resetHook = return () + } + +data Hooks = Hooks + { keyHook :: KeyEvent -> W (), + surfaceHook :: SurfaceEvent -> W (), + buttonHook :: ButtonEvent -> W () + } + +data Config l = Config + { layout :: l, + hooks :: Hooks, + resetHook :: W () + } + +-- | Typeclass defining the set of types which can be used as state extensions +-- to the W monad. These state extensions may be persistent or not. +-- +-- There are default implementations for all methods if the type implements +-- Read, Show and Default, +class (Typeable a) => ExtensionClass a where + -- | The initial value used for the first time an extension is 'gotten' or + -- demarshalling fails. + initialValue :: a + + -- | Transforms a type into a string. If the type cannot be marshalled, this + -- function should return Nothing. + -- + -- If a type cannot be marshalled, it cannot persist across hot reloads. + marshalExtension :: a -> Maybe String + + -- | Reads an extension from a string. If this type is not marshallable or + -- reading fails, this function should return Nothing. + demarshalExtension :: String -> Maybe a + + -- | If the type implements Default, use the default implementation. + default initialValue :: (Default a) => a + initialValue = def + + -- | If the type implements Show, use show for the marshalling. + default marshalExtension :: (Show a) => a -> Maybe String + marshalExtension = Just . show + + -- | If the type implements Read, use read for the demarshalling. + default demarshalExtension :: (Read a) => String -> Maybe a + demarshalExtension = readMaybe + +data StateExtension where + StateExtension :: (ExtensionClass a) => a -> StateExtension + +-- | Puts a state extension. +xput :: forall a m. (ExtensionClass a, Wlike m) => a -> m () +xput val = liftW $ do + modify' $ \state@State {extensibleState = extensibleState} -> + state + { extensibleState = + M.insert + ( xRepr (Proxy :: Proxy a) + ) + (Right $ StateExtension val) + extensibleState + } + +-- | Modifies a state extension. +xmodify :: forall a m. (ExtensionClass a, Wlike m) => (a -> a) -> m () +xmodify fn = xput . fn =<< xget + +-- | Modifies a state extension in the monadic context. +xmodifyM :: forall a m. (ExtensionClass a, Wlike m) => (a -> m a) -> m () +xmodifyM fn = (xput <=< fn) =<< xget + +-- | Produces a string representation of a type used to key into the extensible +-- state map. +xRepr :: forall proxy a. (ExtensionClass a) => proxy a -> String +xRepr _ = tyconToStr $ someTypeRepTyCon (someTypeRep (Proxy :: Proxy a)) + where + tyconToStr tc = + printf "%s.%s.%s" (tyConPackage tc) (tyConModule tc) (tyConName tc) + +-- | Gets a state extension. +xget :: forall a m. (ExtensionClass a, Wlike m) => m a +xget = do + xs <- liftW $ gets extensibleState + case M.lookup (xRepr (Proxy :: Proxy a)) xs of + Just (Right (StateExtension a)) -> return (fromMaybe initialValue (cast a)) + Just (Left str) -> + let v = fromMaybe initialValue (demarshalExtension str) + in xput v >> return v + Nothing -> + xput (initialValue :: a) >> return initialValue + +xgets :: forall a b m. (ExtensionClass a, Wlike m) => (a -> b) -> m b +xgets fn = fn <$> xget + +-- State as it is marshalled. Used for derived instances of Show and Read. +data MarshalledState + = MarshalledState + (StackSet ScreenId ScreenDetail Tag String Window) + (Set Window) + [(String, String)] + deriving (Show, Read) + +data State = State + { -- The datastructure containing the state of the windows. + mapped :: StackSet ScreenId ScreenDetail Tag WindowLayout Window, + -- | All the windows wetterhorn knows about, even if they are not mapped. + allWindows :: Set Window, + -- | Current set of hooks. The initial hooks are provided by the + -- configuration, but the hooks can change during operation. This is how key + -- sequences can be mapped. + currentHooks :: Hooks, + -- | Map from the typerep string to the state extension. + extensibleState :: Map String (Either String StateExtension) + } + +-- | Initializes a "cold" state from a configuration. A cold state is the +-- initial state on startup. It is constrasted with a "hot" state, which is a +-- persisted state after a hot-reload. +initColdState :: Config WindowLayout -> IO State +initColdState Config {layout = layout, hooks = hooks} = + return $ + State + ( StackSet (Screen () () (Workspace "0" layout (Stack [] []))) [] [] + ) + mempty + hooks + mempty + +-- | Marshals the serializable parts of the state to a string. This happens +-- during a hot-reload where some state must be saved to persist across hot +-- reloads. +marshalState :: State -> String +marshalState + ( State + { mapped = mapped, + allWindows = allWindows, + extensibleState = xs + } + ) = + show $ + MarshalledState + (mapLayout serializeWindowLayout mapped) + allWindows + (mapMaybe (\(k, v) -> (k,) <$> doMarshalEx v) (M.toList xs)) + where + doMarshalEx (Left s) = Just s + doMarshalEx (Right (StateExtension a)) = marshalExtension a + +-- | Demarshals the string from "marshalState" into a state. Uses the provided +-- config to fill out non-persistent parts of the state. +demarshalState :: Config WindowLayout -> String -> State +demarshalState Config {hooks = hooks, layout = layout} str = + State mapped allWindows hooks xs + where + ( MarshalledState + (mapLayout (readWindowLayout layout) -> mapped) + allWindows + (fmap Left . M.fromList -> xs) + ) = read str + +-- | This is _the_ main monad used for Wetterhorn operations. Contains +-- everything required to operate. Contains the state, configuration and +-- interface to foreign code. +newtype W a = W (ReaderT Context (StateT State IO) a) + deriving (Functor, Applicative, Monad, MonadState State, MonadIO) + +-- | Let Config be the thing W is a reader for. There is already a way to get +-- the foreign interface in the context. +instance MonadReader (Config WindowLayout) W where + local fn (W r) = W $ local (\(Context fi conf) -> Context fi (fn conf)) r + ask = W $ ctxConfig <$> ask + +runW :: W a -> (Context, State) -> IO (a, State) +runW (W fn) (ctx, st) = runStateT (runReaderT fn ctx) st + +foreignInterface :: W ForeignInterface +foreignInterface = W $ ctxForeignInterface <$> ask + +getSeat :: W (Ptr WlrSeat) +getSeat = (wio . ForeignInterface.getSeat) =<< foreignInterface + +requestHotReload :: W () +requestHotReload = (wio . ForeignInterface.requestHotReload) =<< foreignInterface + +requestExit :: Int -> W () +requestExit ec = (wio . flip ForeignInterface.requestExit ec) =<< foreignInterface + +shellExec :: String -> W () +shellExec = wio . ForeignInterface.doShellExec + +wio :: IO a -> W a +wio = liftIO + +-- | Type class to lift an arbitrary 'W' computation into another monad. +class (Monad m) => Wlike m where + liftW :: W a -> m a + +-- | Trivial instance of W for Wlike. +instance Wlike W where + liftW = id + +-- Default implementations for common handlers. + +-- | handles a new surface event. This updates the state to reflect how it +-- should look in the harness. +handleSurface :: SurfaceEvent -> W () +handleSurface (SurfaceEvent state (Window -> win)) = + case state of + Destroy -> + modify $ + \st@State + { allWindows = allWindows, + mapped = mapped + } -> + st + { allWindows = Set.delete win allWindows, + mapped = StackSet.delete win mapped + } + Unmap -> modify $ + \st@State {mapped = mapped} -> + st + { mapped = StackSet.delete win mapped + } + Map -> modify $ + \st@State {mapped = mapped, allWindows = allWindows} -> + st + { mapped = StackSet.insertTiled win mapped, + allWindows = Set.insert win allWindows + } diff --git a/plug/src/Wetterhorn/Dsl/Bind.hs b/plug/src/Wetterhorn/Dsl/Bind.hs new file mode 100644 index 0000000..0b6adaf --- /dev/null +++ b/plug/src/Wetterhorn/Dsl/Bind.hs @@ -0,0 +1,128 @@ +-- | eDSL for the 'bind' function. The 'bind' function provides an easy way to +-- bind certain actions to other actions. +module Wetterhorn.Dsl.Bind + ( bind, + (.+), + MatchEvent (..), + Modifier (..), + released, + weak, + run, + modifierToMask, + module X, + ) +where + +import Control.Monad +import Control.Monad.Trans +import Data.Bits +import Data.Word +import Wetterhorn.Core.ButtonEvent (ButtonEvent(..)) +import qualified Wetterhorn.Core.ButtonEvent as ButtonEvent +import Wetterhorn.Core.KeyEvent (KeyEvent(..)) +import qualified Wetterhorn.Core.KeyEvent as KeyEvent +import Wetterhorn.Core.W +import Wetterhorn.Dsl.Buttons as X +import Wetterhorn.Dsl.Input + +class MatchEvent m where + matches :: m -> InputEvent -> W Bool + +instance MatchEvent (InputEvent -> W Bool) where + matches = ($) + +instance MatchEvent Char where + matches ch (InputKeyEvent ke) = return $ KeyEvent.codepoint ke == ch + matches _ _ = return False + +instance MatchEvent Button where + matches (Button b) (InputButtonEvent be) = + return $ ButtonEvent.button be == b + matches _ _ = return False + +-- | Enumeration of possible modifiers. +-- +-- ModX can be used for extra user-defined modifiers which are not standard xkb +-- modifiers. +data Modifier + = Shift + | Lock + | Control + | Mod1 + | Mod2 + | Mod3 + | Mod4 + | Mod5 + | ModX Int + deriving (Eq, Ord, Show, Read) + +-- | Converts a modifier to its associated mask. +modifierToMask :: Modifier -> Word32 +modifierToMask m = + 1 + `shiftL` case m of + Shift -> 0 + Lock -> 1 + Control -> 2 + Mod1 -> 3 + Mod2 -> 4 + Mod3 -> 5 + Mod4 -> 6 + Mod5 -> 7 + ModX b -> b + 8 + +released :: (MatchEvent m) => m -> InputEvent -> W Bool +released me ev | not (isPressEvent ev) = matches me ev +released _ _ = return False + +data MatchModifiers = MatchModifiers + { weakModifierMatch :: Bool, + modifierMask :: Word32, + baseMatch :: InputEvent -> W Bool + } + +instance MatchEvent MatchModifiers where + matches (MatchModifiers weak bits base) ev = do + mods <- getMods ev + b <- liftW $ base ev + + return $ + b + && ( (not weak && mods == bits) + || (weak && (bits .&. mods == bits)) + ) + where + getMods (InputButtonEvent (ButtonEvent {ButtonEvent.modifiers = mods})) = return mods + getMods (InputKeyEvent (KeyEvent {KeyEvent.modifiers = mods})) = return mods + getMods _ = getModifierState + +class LiftMatchModifiers a where + toModifiers :: a -> MatchModifiers + default toModifiers :: (MatchEvent a) => a -> MatchModifiers + toModifiers = MatchModifiers False 0 . matches + +instance LiftMatchModifiers MatchModifiers where + toModifiers = id + +instance LiftMatchModifiers Char + +instance LiftMatchModifiers Button + +-- toModifiers ch = MatchModifiers False 0 (matches ch) + +(.+) :: (LiftMatchModifiers mods) => Modifier -> mods -> MatchModifiers +(.+) modifier (toModifiers -> (MatchModifiers b mask base)) = + MatchModifiers b (mask .|. modifierToMask modifier) base + +infixr 9 .+ + +bind :: (MatchEvent match) => InputEvent -> match -> InputM spy () -> InputM spy () +bind ev match action = do + matches' <- liftW $ matches match ev + when matches' (action >> continue) + +weak :: MatchModifiers -> MatchModifiers +weak m = m {weakModifierMatch = True} + +run :: W () -> InputM spy () +run = liftW diff --git a/plug/src/Wetterhorn/Dsl/Buttons.hsc b/plug/src/Wetterhorn/Dsl/Buttons.hsc new file mode 100644 index 0000000..c3e049c --- /dev/null +++ b/plug/src/Wetterhorn/Dsl/Buttons.hsc @@ -0,0 +1,229 @@ +module Wetterhorn.Dsl.Buttons where + +import Data.Word + +#include + +data Button = Button Word32 + +btnMisc :: Button +btnMisc = Button #const BTN_MISC + +btn0 :: Button +btn0 = Button #const BTN_0 + +btn1 :: Button +btn1 = Button #const BTN_1 + +btn2 :: Button +btn2 = Button #const BTN_2 + +btn3 :: Button +btn3 = Button #const BTN_3 + +btn4 :: Button +btn4 = Button #const BTN_4 + +btn5 :: Button +btn5 = Button #const BTN_5 + +btn6 :: Button +btn6 = Button #const BTN_6 + +btn7 :: Button +btn7 = Button #const BTN_7 + +btn8 :: Button +btn8 = Button #const BTN_8 + +btn9 :: Button +btn9 = Button #const BTN_9 + +btnMouse :: Button +btnMouse = Button #const BTN_MOUSE + +btnLeft :: Button +btnLeft = Button #const BTN_LEFT + +btnRight :: Button +btnRight = Button #const BTN_RIGHT + +btnMiddle :: Button +btnMiddle = Button #const BTN_MIDDLE + +btnSide :: Button +btnSide = Button #const BTN_SIDE + +btnExtra :: Button +btnExtra = Button #const BTN_EXTRA + +btnForward :: Button +btnForward = Button #const BTN_FORWARD + +btnBack :: Button +btnBack = Button #const BTN_BACK + +btnTask :: Button +btnTask = Button #const BTN_TASK + +btnJoystick :: Button +btnJoystick = Button #const BTN_JOYSTICK + +btnTrigger :: Button +btnTrigger = Button #const BTN_TRIGGER + +btnThumb :: Button +btnThumb = Button #const BTN_THUMB + +btnThumb2 :: Button +btnThumb2 = Button #const BTN_THUMB2 + +btnTop :: Button +btnTop = Button #const BTN_TOP + +btnTop2 :: Button +btnTop2 = Button #const BTN_TOP2 + +btnPinkie :: Button +btnPinkie = Button #const BTN_PINKIE + +btnBase :: Button +btnBase = Button #const BTN_BASE + +btnBase2 :: Button +btnBase2 = Button #const BTN_BASE2 + +btnBase3 :: Button +btnBase3 = Button #const BTN_BASE3 + +btnBase4 :: Button +btnBase4 = Button #const BTN_BASE4 + +btnBase5 :: Button +btnBase5 = Button #const BTN_BASE5 + +btnBase6 :: Button +btnBase6 = Button #const BTN_BASE6 + +btnDead :: Button +btnDead = Button #const BTN_DEAD + +btnGamepad :: Button +btnGamepad = Button #const BTN_GAMEPAD + +btnSouth :: Button +btnSouth = Button #const BTN_SOUTH + +btnA :: Button +btnA = Button #const BTN_A + +btnEast :: Button +btnEast = Button #const BTN_EAST + +btnB :: Button +btnB = Button #const BTN_B + +btnC :: Button +btnC = Button #const BTN_C + +btnNorth :: Button +btnNorth = Button #const BTN_NORTH + +btnX :: Button +btnX = Button #const BTN_X + +btnWest :: Button +btnWest = Button #const BTN_WEST + +btnY :: Button +btnY = Button #const BTN_Y + +btnZ :: Button +btnZ = Button #const BTN_Z + +btnTl :: Button +btnTl = Button #const BTN_TL + +btnTr :: Button +btnTr = Button #const BTN_TR + +btnTl2 :: Button +btnTl2 = Button #const BTN_TL2 + +btnTr2 :: Button +btnTr2 = Button #const BTN_TR2 + +btnSelect :: Button +btnSelect = Button #const BTN_SELECT + +btnStart :: Button +btnStart = Button #const BTN_START + +btnMode :: Button +btnMode = Button #const BTN_MODE + +btnThumbl :: Button +btnThumbl = Button #const BTN_THUMBL + +btnThumbr :: Button +btnThumbr = Button #const BTN_THUMBR + +btnDigi :: Button +btnDigi = Button #const BTN_DIGI + +btnToolPen :: Button +btnToolPen = Button #const BTN_TOOL_PEN + +btnToolRubber :: Button +btnToolRubber = Button #const BTN_TOOL_RUBBER + +btnToolBrush :: Button +btnToolBrush = Button #const BTN_TOOL_BRUSH + +btnToolPencil :: Button +btnToolPencil = Button #const BTN_TOOL_PENCIL + +btnToolAirbrush :: Button +btnToolAirbrush = Button #const BTN_TOOL_AIRBRUSH + +btnToolFinger :: Button +btnToolFinger = Button #const BTN_TOOL_FINGER + +btnToolMouse :: Button +btnToolMouse = Button #const BTN_TOOL_MOUSE + +btnToolLens :: Button +btnToolLens = Button #const BTN_TOOL_LENS + +btnToolQuinttap :: Button +btnToolQuinttap = Button #const BTN_TOOL_QUINTTAP + +btnStylus3 :: Button +btnStylus3 = Button #const BTN_STYLUS3 + +btnTouch :: Button +btnTouch = Button #const BTN_TOUCH + +btnStylus :: Button +btnStylus = Button #const BTN_STYLUS + +btnStylus2 :: Button +btnStylus2 = Button #const BTN_STYLUS2 + +btnToolDoubletap :: Button +btnToolDoubletap = Button #const BTN_TOOL_DOUBLETAP + +btnToolTripletap :: Button +btnToolTripletap = Button #const BTN_TOOL_TRIPLETAP + +btnToolQuadtap :: Button +btnToolQuadtap = Button #const BTN_TOOL_QUADTAP + +btnWheel :: Button +btnWheel = Button #const BTN_WHEEL + +btnGearDown :: Button +btnGearDown = Button #const BTN_GEAR_DOWN + +btnGearUp :: Button +btnGearUp = Button #const BTN_GEAR_UP diff --git a/plug/src/Wetterhorn/Dsl/Input.hs b/plug/src/Wetterhorn/Dsl/Input.hs new file mode 100644 index 0000000..1a0c294 --- /dev/null +++ b/plug/src/Wetterhorn/Dsl/Input.hs @@ -0,0 +1,286 @@ +{-# LANGUAGE DataKinds #-} + +module Wetterhorn.Dsl.Input + ( InputM, + InputEvent (..), + InputProxy (..), + NoProxy, + withProxies, + forwardEvent, + forwardKey, + whenKeyEvent, + whenButtonEvent, + useInputHandler, + unwrap, + filterEvent, + isPressEvent, + nextInputEventThat, + replayEvents, + isKeyEvent, + nextInputPressEvent, + continue, + nextInputEvent, + getModifierState, + ) +where + +import Control.Concurrent (threadDelay) +import Control.Monad +import Control.Monad.Cont (MonadCont) +import Control.Monad.Loops (andM) +import Control.Monad.RWS + ( MonadIO (liftIO), + MonadReader (ask), + MonadState (get), + MonadTrans (lift), + RWST, + execRWST, + gets, + modify, + ) +import Control.Monad.Trans.Cont +import Control.Monad.Trans.Maybe (MaybeT (runMaybeT)) +import Data.IORef (newIORef, readIORef, writeIORef) +import Data.Proxy +import Data.Word (Word32) +import qualified Wetterhorn.Core.ButtonEvent as ButtonEvent +import qualified Wetterhorn.Core.KeyEvent as KeyEvent +import Wetterhorn.Core.W (W (..)) +import qualified Wetterhorn.Core.W as W +import Wetterhorn.Foreign.WlRoots (guardNull, wlrKeyboardGetModifiers, wlrSeatGetKeyboard, wlrSeatKeyboardNotifyKey, wlrSeatSetKeyboard) + +class InputProxy (spy :: k) where + onKeyEvent :: Proxy spy -> InputEvent -> MaybeT W InputEvent + +instance (InputProxy h, InputProxy t) => InputProxy (h ': t) where + onKeyEvent _ = onKeyEvent (Proxy :: Proxy h) <=< onKeyEvent (Proxy :: Proxy t) + +instance InputProxy '[] where + onKeyEvent _ = return + +data NoProxy + +instance InputProxy NoProxy where + onKeyEvent _ = return + +instance (InputProxy s1, InputProxy s2) => InputProxy (s1, s2) where + onKeyEvent proxy = onKeyEvent (fmap fst proxy) <=< onKeyEvent (fmap snd proxy) + +-- | Union of event types. +data InputEvent + = InputButtonEvent ButtonEvent.ButtonEvent + | InputKeyEvent KeyEvent.KeyEvent + +-- | Context for the input. +newtype InputContext spy = InputContext + { -- | Top of the input routine. Used in "continue" statement. + inputTop :: InputM spy () + } + +newtype InputState spy = InputState + { inputSource :: InputM spy InputEvent + } + +-- | Input monad for handling all kinds of input. +newtype InputM spy a = InputM (ContT () (RWST (InputContext spy) () (InputState spy) W) a) + deriving (Monad, Functor, Applicative, MonadCont, MonadIO) + +instance MonadFail (InputM spy) where + fail _ = continue + +-- | Lifts a W action to an InputM action. +instance W.Wlike (InputM spy) where + liftW = InputM . lift . lift + +-- | Resets the input handler to the top. +continue :: InputM spy a +continue = do + (InputContext {inputTop = (InputM top)}) <- InputM ask + InputM $ shiftT (\_ -> resetT top) + +-- | Forwards the given key event to the focused window. +forwardKey :: KeyEvent.KeyEvent -> W () +forwardKey keyEvent = do + seatPtr <- W.getSeat + W.wio $ do + wlrSeatSetKeyboard + seatPtr + (KeyEvent.device keyEvent) + + wlrSeatKeyboardNotifyKey + seatPtr + (KeyEvent.timeMs keyEvent) + (KeyEvent.keycode keyEvent) + ( case KeyEvent.state keyEvent of + KeyEvent.KeyReleased -> 0 + _ -> 1 + ) + +-- | Executes a function if the input event is a key event. If it is not a key +-- event, then nothing happens. +whenKeyEvent :: (Monad m) => InputEvent -> (KeyEvent.KeyEvent -> m ()) -> m () +whenKeyEvent (InputKeyEvent ke) = ($ ke) +whenKeyEvent _ = const (return ()) + +-- | Executes a function in the input event is a button event. If it is not a +-- button event, then nothing happens. +whenButtonEvent :: + (Monad m) => InputEvent -> (ButtonEvent.ButtonEvent -> m ()) -> m () +whenButtonEvent (InputButtonEvent be) = ($ be) +whenButtonEvent _ = const (return ()) + +-- | Forwards the given input event to focused window. +forwardEvent :: (W.Wlike m) => InputEvent -> m () +forwardEvent = \case + InputKeyEvent kv -> W.liftW $ forwardKey kv + InputButtonEvent _ -> return () + +-- | "Unwraps" a maybe. If the maybe is present, the handler proceeds. If the +-- maybe is not present, the handler restarts execution from the top. +unwrap :: Maybe a -> InputM spy a +unwrap (Just val) = return val +unwrap Nothing = continue + +-- | Runs the series of events from the top as if they were input. +replayEvents :: [InputEvent] -> InputM spy () +replayEvents events = do + ioref <- liftIO (newIORef events) + + (InputM oldInput) <- InputM $ gets inputSource + + let newInput = + InputM $ + shiftT + ( \thingToDo -> do + r <- liftIO (readIORef ioref) + case r of + [] -> do + modify $ \st -> st {inputSource = InputM oldInput} + a <- oldInput + lift (thingToDo a) + (a : as) -> do + liftIO (writeIORef ioref as) + lift (thingToDo a) + ) + + InputM $ modify $ \st -> st {inputSource = newInput} + where + delay to act = liftIO (threadDelay to) >> act + +-- | Call in the reset handler with the InputM handler you wolud like to use. +useInputHandler :: (InputProxy spy) => InputM spy () -> W () +useInputHandler (forever -> top@(InputM ctop)) = do + void $ execRWST (runContT ctop return) (InputContext top) (InputState useSeatEvents) + +-- | Returns the next input event that's either a kep press or a button press. +nextInputPressEvent :: InputM spy InputEvent +nextInputPressEvent = nextInputEventThat (andM [isPressEvent, not . modifierKey]) + +modifierKey :: InputEvent -> Bool +modifierKey (InputKeyEvent (KeyEvent.KeyEvent {codepoint = '\NUL'})) = True +modifierKey _ = False + +nextInputEventThat :: (InputEvent -> Bool) -> InputM spy InputEvent +nextInputEventThat fn = + nextInputEvent + >>= ( \ie -> + if fn ie + then return ie + else forwardEvent ie >> nextInputEventThat fn + ) + +isKeyEvent :: InputEvent -> Bool +isKeyEvent (InputKeyEvent _) = True +isKeyEvent _ = False + +isPressEvent :: InputEvent -> Bool +isPressEvent (InputButtonEvent be) + | ButtonEvent.state be == ButtonEvent.ButtonPressed = + True +isPressEvent (InputKeyEvent ke) + | KeyEvent.state ke == KeyEvent.KeyPressed = + True +isPressEvent _ = False + +-- | Returns the event only if it matches the filter. If it does not match the +-- filter, execution resets to the top. +filterEvent :: (InputEvent -> Bool) -> InputEvent -> InputM spy InputEvent +filterEvent fn ev | fn ev = return ev +filterEvent _ _ = continue + +getModifierState :: W Word32 +getModifierState = do + seat <- W.getSeat + keyboard <- W.wio $ wlrSeatGetKeyboard seat + maybe (return 0) (W.wio . wlrKeyboardGetModifiers) (guardNull keyboard) + +nextInputEvent :: InputM spy InputEvent +nextInputEvent = join $ InputM $ gets inputSource + +withProxies :: Proxy spy -> InputM spy a -> InputM spy a +withProxies _ = id + +-- | Gets the next input event. +useSeatEvents :: forall spy. (InputProxy spy) => InputM spy InputEvent +useSeatEvents = + InputM $ + shiftT + ( \thingToDo -> do + putButtonHandler $ \be -> do + runSpies thingToDo (InputButtonEvent be) + + putKeyHandler $ \ke -> do + runSpies thingToDo (InputKeyEvent ke) + ) + where + runSpies fn ev = do + evM <- lift $ runMaybeT (onKeyEvent (Proxy :: Proxy spy) ev) + mapM_ + ( \ev' -> do + clearButtonHandler + clearKeyHandler + fn ev' + ) + evM + + clearButtonHandler = + lift $ + modify $ \st -> + st + { W.currentHooks = + (W.currentHooks st) + { W.buttonHook = const (return ()) + } + } + + clearKeyHandler = + lift $ + modify $ \st -> + st + { W.currentHooks = + (W.currentHooks st) + { W.keyHook = const (return ()) + } + } + + putButtonHandler h = lift $ do + (r, s) <- (,) <$> ask <*> get + lift $ + modify $ \st -> + st + { W.currentHooks = + (W.currentHooks st) + { W.buttonHook = \be -> void (execRWST (h be) r s) + } + } + + putKeyHandler h = lift $ do + (r, s) <- (,) <$> ask <*> get + lift $ + modify $ \st -> + st + { W.currentHooks = + (W.currentHooks st) + { W.keyHook = \ke -> void (execRWST (h ke) r s) + } + } diff --git a/plug/src/Wetterhorn/Foreign.hs b/plug/src/Wetterhorn/Foreign.hs new file mode 100644 index 0000000..2d0a42c --- /dev/null +++ b/plug/src/Wetterhorn/Foreign.hs @@ -0,0 +1,18 @@ +module Wetterhorn.Foreign + ( TypedIntPtr (..), + toPtr, + fromPtr, + ) +where + +import Foreign (IntPtr, Ptr) +import qualified Foreign + +toPtr :: TypedIntPtr a -> Ptr a +toPtr (TypedIntPtr ip) = Foreign.intPtrToPtr ip + +fromPtr :: Ptr a -> TypedIntPtr a +fromPtr = TypedIntPtr . Foreign.ptrToIntPtr + +newtype TypedIntPtr a = TypedIntPtr IntPtr + deriving (Show, Read, Eq, Ord, Num) diff --git a/plug/src/Wetterhorn/Foreign/Export.hs b/plug/src/Wetterhorn/Foreign/Export.hs new file mode 100644 index 0000000..51bd72b --- /dev/null +++ b/plug/src/Wetterhorn/Foreign/Export.hs @@ -0,0 +1,208 @@ +-- | This module does not export anything. It exists simply to provide C-symbols +-- for the plugin. +module Wetterhorn.Foreign.Export () where + +import Config +import Control.Arrow (Arrow (first)) +import Control.Monad (forM_) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as CH +import Foreign + ( Ptr, + Storable (poke, pokeByteOff), + Word32, + Word8, + deRefStablePtr, + freeStablePtr, + mallocBytes, + newStablePtr, + ) +import Foreign.C (CChar, CInt (..)) +import Wetterhorn.Core.ButtonEvent (ButtonEvent (ButtonEvent), ButtonState (ButtonPressed, ButtonReleased)) +import Wetterhorn.Core.KeyEvent (KeyEvent (..), KeyState (..)) +import Wetterhorn.Core.SurfaceEvent (SurfaceEvent (SurfaceEvent)) +import Wetterhorn.Core.W (W, Wetterhorn) +import qualified Wetterhorn.Core.W as W +import Wetterhorn.Foreign.ForeignInterface +import Wetterhorn.Foreign.WlRoots + +type Wetter = (W.Config W.WindowLayout, W.State) + +toWetter :: (W.Context, W.State) -> (W.Config W.WindowLayout, W.State) +toWetter = first W.ctxConfig + +runForeign :: (Wetter -> W ()) -> Wetterhorn -> IO Wetterhorn +runForeign fn stblptr = do + w@(ctx, st) <- deRefStablePtr stblptr + freeStablePtr stblptr + (_, state') <- W.runW (fn $ toWetter w) (ctx, st) + newStablePtr (ctx, state') + +runForeignWithReturn :: + (Storable a) => (Wetter -> W a) -> Ptr a -> Wetterhorn -> IO Wetterhorn +runForeignWithReturn fn ptr stableptr = do + w@(ctx, st) <- deRefStablePtr stableptr + freeStablePtr stableptr + (val, state') <- W.runW (fn $ toWetter w) (ctx, st) + poke ptr val + newStablePtr (ctx, state') + +runForeignWithReturn2 :: + (Storable a, Storable b) => + (Wetter -> W (a, b)) -> + Ptr a -> + Ptr b -> + Wetterhorn -> + IO Wetterhorn +runForeignWithReturn2 fn ptrA ptrB stableptr = do + w@(ctx, st) <- deRefStablePtr stableptr + freeStablePtr stableptr + ((vA, vB), state') <- W.runW (fn $ toWetter w) (ctx, st) + poke ptrA vA + poke ptrB vB + newStablePtr (ctx, state') + +-- | This function is the implementation of the "hotstart" mechanism. It gives a +-- pointer to the previously marshalled state and the length of that array and +-- this function returns a Wetterhorn instance. +foreign export ccall "plugin_hot_start" + pluginHotStart :: + Ptr CChar -> Word32 -> IO Wetterhorn + +pluginHotStart :: Ptr CChar -> Word32 -> IO Wetterhorn +pluginHotStart chars len = do + bs <- BS.packCStringLen (chars, fromIntegral len) + foreignInterface <- getForeignInterface + wtr <- + newStablePtr + ( W.Context foreignInterface config, + W.demarshalState config (CH.unpack bs) + ) + runForeign (\(conf, _) -> W.resetHook conf) wtr + +-- | This function is called when a "coldstart" request is receieved. It just +-- calles the function "wetterhorn". This function should be defined in the main +-- code as it's sort-of the equivalent of XMonad's "main" function. +foreign export ccall "plugin_cold_start" + pluginColdStart :: IO Wetterhorn + +pluginColdStart :: IO Wetterhorn +pluginColdStart = do + foreignInterface <- getForeignInterface + state <- W.initColdState config + wtr <- newStablePtr (W.Context foreignInterface config, state) + runForeign (\(conf, _) -> W.resetHook conf) wtr + +-- | Marshals the opaque state to a C-style byte array and size pointer. +foreign export ccall "plugin_marshal_state" + pluginMarshalState :: Wetterhorn -> Ptr Word32 -> IO (Ptr Word8) + +pluginMarshalState :: Wetterhorn -> Ptr Word32 -> IO (Ptr Word8) +pluginMarshalState stblptr outlen = do + (_, st) <- deRefStablePtr stblptr + let bs = CH.pack (W.marshalState st) + ret <- mallocBytes (BS.length bs) + poke outlen (fromIntegral $ BS.length bs) + forM_ (zip [0 ..] (BS.unpack bs)) $ \(off, w8) -> do + pokeByteOff ret off w8 + return ret + +foreign export ccall "plugin_handle_button" + pluginHandleButton :: Ptr WlrPointerButtonEvent -> Word32 -> Wetterhorn -> IO Wetterhorn + +pluginHandleButton :: Ptr WlrPointerButtonEvent -> Word32 -> Wetterhorn -> IO Wetterhorn +pluginHandleButton eventPtr modifiers = do + runForeign $ + \( _, + W.State {W.currentHooks = W.Hooks {buttonHook = buttonHook}} + ) -> do + event <- W.wio $ + runForeignDemarshal eventPtr $ do + ButtonEvent + <$> demarshal + <*> demarshal + <*> demarshal + <*> pure modifiers + <*> ( ( \u8 -> + if (u8 :: Word8) == 0 + then ButtonReleased + else ButtonPressed + ) + <$> demarshal + ) + + buttonHook event + +foreign export ccall "plugin_handle_keybinding" + pluginHandleKeybinding :: + Ptr WlrInputDevice -> + Ptr WlrEventKeyboardKey -> + Word32 -> + Word32 -> + Word32 -> + Ptr CInt -> + Wetterhorn -> + IO Wetterhorn + +pluginHandleKeybinding :: + Ptr WlrInputDevice -> + Ptr WlrEventKeyboardKey -> + Word32 -> + Word32 -> + Word32 -> + Ptr CInt -> + Wetterhorn -> + IO Wetterhorn +pluginHandleKeybinding inputDevicePtr eventPtr mods sym cp = + runForeignWithReturn $ + \( _, + W.State {W.currentHooks = W.Hooks {keyHook = keyHook}} + ) -> do + event <- W.wio $ + runForeignDemarshal eventPtr $ do + tMs <- demarshal + kc <- demarshal + _ <- (demarshal :: ForeignDemarshal Word32) + keyState <- demarshal + return $ + KeyEvent + tMs + kc + (if keyState == (0 :: Word8) then KeyReleased else KeyPressed) + mods + sym + (toEnum $ fromIntegral cp) + inputDevicePtr + keyHook event + return 1 + +-- | Function exported to the harness to handle the mapping/unmapping/deletion +-- of an XDG surface. +foreign export ccall "plugin_handle_surface" + pluginHandleSurface :: + Ptr WlrXdgSurface -> CInt -> Wetterhorn -> IO Wetterhorn + +pluginHandleSurface :: Ptr WlrXdgSurface -> CInt -> Wetterhorn -> IO Wetterhorn +pluginHandleSurface p t = + runForeign + ( \(_, W.State {currentHooks = W.Hooks {surfaceHook = surfaceHook}}) -> + surfaceHook $ + SurfaceEvent (toEnum $ fromIntegral t) (toSurface p) + ) + +-- | Function exported to the harness to handle the mapping/unmapping/deletion +-- of an XWayland surface. +foreign export ccall "plugin_handle_xwayland_surface" + pluginHandleXWaylandSurface :: + Ptr WlrXWaylandSurface -> CInt -> Wetterhorn -> IO Wetterhorn + +pluginHandleXWaylandSurface :: + Ptr WlrXWaylandSurface -> CInt -> Wetterhorn -> IO Wetterhorn +pluginHandleXWaylandSurface p t = + runForeign + ( \( _, + W.State + { currentHooks = W.Hooks {surfaceHook = surfaceHook} + } + ) -> surfaceHook $ SurfaceEvent (toEnum $ fromIntegral t) (toSurface p) + ) diff --git a/plug/src/Wetterhorn/Foreign/ForeignInterface.hs b/plug/src/Wetterhorn/Foreign/ForeignInterface.hs new file mode 100644 index 0000000..471e3a9 --- /dev/null +++ b/plug/src/Wetterhorn/Foreign/ForeignInterface.hs @@ -0,0 +1,81 @@ +module Wetterhorn.Foreign.ForeignInterface + ( getForeignInterface, + ForeignInterface (..), + ForeignDemarshal (..), + runForeignDemarshal, + demarshal, + doShellExec, + ) +where + +import Control.Monad.State (MonadState (get, put), MonadTrans (lift), StateT, evalStateT) +import Data.Void (Void) +import Foreign (Ptr, Storable (peek, sizeOf), castPtr, plusPtr) +import Foreign.C (CChar, CInt (..)) +import Foreign.C.String +import GHC.Exts (FunPtr) +import Wetterhorn.Foreign.WlRoots + +newtype ForeignDemarshal a = ForeignDemarshal (StateT (Ptr ()) IO a) + deriving (Functor, Monad, Applicative, MonadState (Ptr ())) + +runForeignDemarshal :: Ptr b -> ForeignDemarshal a -> IO a +runForeignDemarshal p (ForeignDemarshal dm) = evalStateT dm (castPtr p) + +demarshal :: (Storable a) => ForeignDemarshal a +demarshal = do + ptr <- get + val <- ForeignDemarshal $ lift $ peek $ castPtr ptr + put (plusPtr ptr (sizeOf val)) + return val + +type CtxT = Ptr Void + +type ForeignCallGetPtr = CtxT -> IO (Ptr ()) + +type ForeignCall = CtxT -> IO () + +type ForeignCallStr = CtxT -> CString -> IO () + +type ForeignCallInt = CtxT -> CInt -> IO () + +foreign import ccall "get_foreign_interface" foreignInterfacePtr :: IO (Ptr ()) + +foreign import ccall "dynamic" toForeignCall :: FunPtr ForeignCall -> ForeignCall + +foreign import ccall "dynamic" toForeignCallStr :: FunPtr ForeignCallStr -> ForeignCallStr + +foreign import ccall "dynamic" toForeignCallInt :: FunPtr ForeignCallInt -> ForeignCallInt + +foreign import ccall "dynamic" toForeignCallGetPtr :: FunPtr ForeignCallGetPtr -> ForeignCallGetPtr + +foreign import ccall "shell_exec" shellExec :: Ptr CChar -> IO () + +data ForeignInterface = ForeignInterface + { requestHotReload :: IO (), + requestLog :: String -> IO (), + requestExit :: Int -> IO (), + getSeat :: IO (Ptr WlrSeat) + } + +doShellExec :: String -> IO () +doShellExec str = withCString str shellExec + +getForeignInterface :: IO ForeignInterface +getForeignInterface = do + ptr <- foreignInterfacePtr + runForeignDemarshal ptr $ do + ctx <- demarshal + requestHotReloadFn <- demarshal + doLogFn <- demarshal + doRequestExit <- demarshal + getSeatFn <- demarshal + + return $ + ForeignInterface + { requestHotReload = toForeignCall requestHotReloadFn ctx, + requestLog = \str -> + withCString str $ \cs -> toForeignCallStr doLogFn ctx cs, + requestExit = toForeignCallInt doRequestExit ctx . fromIntegral, + getSeat = castPtr <$> toForeignCallGetPtr getSeatFn ctx + } diff --git a/plug/src/Wetterhorn/Foreign/WlRoots.hs b/plug/src/Wetterhorn/Foreign/WlRoots.hs new file mode 100644 index 0000000..0581b77 --- /dev/null +++ b/plug/src/Wetterhorn/Foreign/WlRoots.hs @@ -0,0 +1,67 @@ +module Wetterhorn.Foreign.WlRoots where + +import Foreign (IntPtr, Ptr, Word32, intPtrToPtr, ptrToIntPtr, nullPtr) +import Text.Read + +data WlrKeyboard + +data WlrPointer + +data WlrPointerButtonEvent + +data WlrSeat + +data WlrInputDevice + +data WlrEventKeyboardKey + +data WlrXdgSurface + +data WlrXWaylandSurface + +data Surface + = XdgSurface (Ptr WlrXdgSurface) + | XWaylandSurface (Ptr WlrXWaylandSurface) + deriving (Ord, Eq) + +instance Show Surface where + show (XdgSurface p) = show (XdgSerializeSurface (ptrToIntPtr p)) + show (XWaylandSurface p) = show (XWaylandSerializeSurface (ptrToIntPtr p)) + +instance Read Surface where + readPrec = fmap toSurf readPrec + where + toSurf (XdgSerializeSurface ip) = XdgSurface (intPtrToPtr ip) + toSurf (XWaylandSerializeSurface ip) = XWaylandSurface (intPtrToPtr ip) + +-- | Type which exists specifically to derive instances of read and show. +data SerializableSurface + = XdgSerializeSurface IntPtr + | XWaylandSerializeSurface IntPtr + deriving (Read, Show) + +class ForeignSurface a where + toSurface :: Ptr a -> Surface + +instance ForeignSurface WlrXdgSurface where + toSurface = XdgSurface + +instance ForeignSurface WlrXWaylandSurface where + toSurface = XWaylandSurface + +guardNull :: Ptr a -> Maybe (Ptr a) +guardNull p | p == nullPtr = Nothing +guardNull p = Just p + +foreign import ccall "wlr_seat_set_keyboard" wlrSeatSetKeyboard :: + Ptr WlrSeat -> Ptr WlrInputDevice -> IO () + +foreign import ccall "wlr_seat_get_keyboard" wlrSeatGetKeyboard :: + Ptr WlrSeat -> IO (Ptr WlrKeyboard) + +foreign import ccall "wlr_keyboard_get_modifiers" wlrKeyboardGetModifiers :: + Ptr WlrKeyboard -> IO Word32 + +foreign import ccall "wlr_seat_keyboard_notify_key" + wlrSeatKeyboardNotifyKey :: + Ptr WlrSeat -> Word32 -> Word32 -> Word32 -> IO () diff --git a/plug/src/Wetterhorn/Keys/Macros.hs b/plug/src/Wetterhorn/Keys/Macros.hs new file mode 100644 index 0000000..a794193 --- /dev/null +++ b/plug/src/Wetterhorn/Keys/Macros.hs @@ -0,0 +1,145 @@ +-- There are constraints used for better type-level enforced safety rules. +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + +module Wetterhorn.Keys.Macros + ( MacroSupport, + macroStartStopKeybind, + macroReplayKeybind, + stopMacroRecording, + startRecording, + ) +where + +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans (MonadTrans (lift)) +import Data.Default.Class +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Type.Bool +import Data.Type.Equality +import Data.Word +import Foreign (Ptr) +import GHC.TypeError +import Wetterhorn.Core.KeyEvent +import Wetterhorn.Core.W +import Wetterhorn.Dsl.Input +import Wetterhorn.Foreign.WlRoots (WlrInputDevice) + +data RecordedKey = RecordedKey Word32 Word32 KeyState Word32 Word32 Char + deriving (Read, Show) + +data MacrosState = MacrosState + { macros :: Map String [RecordedKey], + currentlyRecording :: Maybe String + } + deriving (Read, Show) + +instance Default MacrosState where + def = MacrosState mempty def + +instance ExtensionClass MacrosState + +type family Find a ls where + Find b (a : t) = (b == a) || Find b t + Find _ '[] = False + +-- | Provides a Vim-esque keybinding behavior for macro recording. +-- +-- Designed to be used like: +-- +-- bind ev (Mod1 .+ 'q') macroStartStopKeybind +macroStartStopKeybind :: (HasMacroSupport spy) => InputM spy () +macroStartStopKeybind = do + currentlyRecordingMacro + >>= ( \case + Just ch -> do + liftIO $ putStrLn $ "Done Recording: " ++ ch + stopMacroRecording + Nothing -> do + (InputKeyEvent (KeyEvent {codepoint = cp})) <- nextInputPressEvent + liftIO $ putStrLn $ "Recording: " ++ [cp] + startRecording [cp] + ) + +-- | Provides a keybinding for replaying a macro. +-- +-- Designed to be used like: +-- +-- bind ev (weak $ Mod1 .+ '@') macroReplayKeybind +macroReplayKeybind :: (HasMacroSupport spy) => InputM spy () +macroReplayKeybind = do + ( InputKeyEvent + (KeyEvent {codepoint = cp, device = device}) + ) <- + nextInputPressEvent + replayMacro device [cp] + +startRecording :: (Wlike m) => String -> m () +startRecording ch = + xmodify + ( \m@MacrosState {macros = macros} -> + m + { macros = Map.delete ch macros, + currentlyRecording = Just ch + } + ) + +stopMacroRecording :: (Wlike m) => m () +stopMacroRecording = xmodify (\m -> m {currentlyRecording = Nothing}) + +currentlyRecordingMacro :: (Wlike m) => m (Maybe String) +currentlyRecordingMacro = xgets currentlyRecording + +replayMacro :: Ptr WlrInputDevice -> String -> InputM spy () +replayMacro inputDevice s = do + m <- liftW (Map.lookup s <$> xgets macros) + -- 'tail' is to cut off the last keystroke which stops the recording. + mapM_ (replayEvents . map toInputEvent . reverse . tail) m + where + toInputEvent :: RecordedKey -> InputEvent + toInputEvent (RecordedKey ts kc st mo keysym cp) = + InputKeyEvent $ KeyEvent ts kc st mo keysym cp inputDevice + +pushMacroKey :: (Wlike m) => KeyEvent -> m () +pushMacroKey ke = do + cur <- xgets currentlyRecording + whenJust cur $ \ch -> do + let recordedKey = toRecordedKey ke + in xmodify $ \m@MacrosState {macros = macros} -> + m {macros = Map.insertWith (++) ch [recordedKey] macros} + where + whenJust (Just a) fn = fn a + whenJust _ _ = return () + + toRecordedKey (KeyEvent ts c s m keysym cp _) = RecordedKey ts c s m keysym cp + +-- | Phantom type defining a proxy required to support macros. +data MacroSupport + +-- | Instance for macro support. +instance InputProxy MacroSupport where + onKeyEvent _ ie = do + lift $ whenKeyEvent ie pushMacroKey + return ie + +class HasMacroSupport t + +instance + ( If + (Find MacroSupport t) + True + ( TypeError + ( Text "This Requires the Macro Proxy to be Enabled." + :<>: Text "Please enable this by adding MacroSupport to your" + :<>: Text "inputProxies list.\n" + :<>: Text "i.e. Change " + :<>: ShowType t + :<>: Text " to " + :<>: ShowType (MacroSupport ': t) + ) + ) + ~ True + ) => + HasMacroSupport t + +instance HasMacroSupport MacroSupport diff --git a/plug/src/Wetterhorn/Keys/MagicModifierKey.hs b/plug/src/Wetterhorn/Keys/MagicModifierKey.hs new file mode 100644 index 0000000..6bc8bb3 --- /dev/null +++ b/plug/src/Wetterhorn/Keys/MagicModifierKey.hs @@ -0,0 +1,50 @@ +module Wetterhorn.Keys.MagicModifierKey where + +import Data.Data +import Data.Default.Class +import GHC.TypeNats +import Wetterhorn.Core.KeyEvent +import Wetterhorn.Core.W +import Wetterhorn.Dsl.Bind +import Wetterhorn.Dsl.Input +import Control.Monad.RWS (MonadTrans(lift)) +import Control.Monad.Trans.Maybe (MaybeT(..)) + +data MagicModifierProxy (keycode :: Natural) inputproxy + deriving (Typeable) + +newtype MagicModifierState (keycode :: Natural) = MagicModifierState {isPressed :: Bool} + deriving (Typeable, Eq, Show, Ord, Read) + +instance Default (MagicModifierState k) where + def = MagicModifierState False + +instance (KnownNat k) => ExtensionClass (MagicModifierState k) + +instance + (KnownNat keycode, InputProxy inputproxy) => + InputProxy (MagicModifierProxy keycode inputproxy) + where + onKeyEvent proxy ie = do + case ie of + (InputKeyEvent (KeyEvent {keycode = kc, state = state})) + | fromIntegral kc == natVal (keycodeProxy proxy) -> do + lift $ setMagicModifierPressed proxy (state == KeyPressed) + MaybeT (return Nothing) + _ -> do + pressed <- lift $ isMagicModifierPressed proxy + if pressed + then onKeyEvent (Proxy :: Proxy inputproxy) ie + else return ie + where + keycodeProxy :: Proxy (MagicModifierProxy kc a) -> Proxy kc + keycodeProxy _ = Proxy + + isMagicModifierPressed p = isPressed <$> getModState p + setMagicModifierPressed p = modifyModState p . const + + getModState :: (KnownNat kc) => Proxy (MagicModifierProxy kc a) -> W (MagicModifierState kc) + getModState _ = xget + + modifyModState :: (KnownNat kc) => Proxy (MagicModifierProxy kc a) -> (MagicModifierState kc -> Bool) -> W () + modifyModState _ fn = xmodify (MagicModifierState . fn) diff --git a/plug/src/Wetterhorn/Layout/Combine.hs b/plug/src/Wetterhorn/Layout/Combine.hs new file mode 100644 index 0000000..10a0208 --- /dev/null +++ b/plug/src/Wetterhorn/Layout/Combine.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE ViewPatterns #-} + +module Wetterhorn.Layout.Combine where + +import Data.Typeable +import Wetterhorn.Constraints +import Wetterhorn.Core.W + +data (|||) a b = Comb LR a b + deriving (Typeable, Read, Show) + +data Next = Next + deriving (Typeable) + +data Reset = Reset + deriving (Typeable) + +(|||) :: a -> b -> (a ||| b) +a ||| b = Comb L a b + +data LR = L | R deriving (Read, Show, Ord, Eq, Enum) + +instance (HandleMessage a, HandleMessage b) => HandleMessage (a ||| b) where + handleMessage (fromMessage -> Just Next) (Comb L l r) = return (Comb R l r) + handleMessage (fromMessage -> Just Reset) (Comb _ l r) = return (Comb L l r) + handleMessage mesg (Comb L l r) = + Comb L <$> handleMessage mesg l <*> pure r + handleMessage mesg (Comb R l r) = + Comb L l <$> handleMessage mesg r + +instance (LayoutClass a, LayoutClass b) => LayoutClass (a ||| b) where + -- In order to use this layout class, the lay-out type 'a' must satisfy BOTH + -- the left and right constraints. + type LayoutConstraint (a ||| b) = LayoutConstraint a &&&& LayoutConstraint b + + runLayout as (Comb R r l) = do + (r', ret) <- runLayout as r + return (Comb R r' l, ret) + runLayout as (Comb L r l) = do + (l', ret) <- runLayout as l + return (Comb R r l', ret) + + serializeLayout (Comb lr l r) = show (Comb lr (serializeLayout l) (serializeLayout r)) + readLayout str = Comb lr <$> l <*> r + where + (Comb lr (readLayout -> l) (readLayout -> r)) = read str + + description (Comb _ l r) = description l ++ " ||| " ++ description r diff --git a/plug/src/Wetterhorn/Layout/Full.hs b/plug/src/Wetterhorn/Layout/Full.hs new file mode 100644 index 0000000..b7e4d91 --- /dev/null +++ b/plug/src/Wetterhorn/Layout/Full.hs @@ -0,0 +1,23 @@ +module Wetterhorn.Layout.Full where + +import Data.Data (Typeable) +import Data.Default.Class +import Wetterhorn.Constraints +import Wetterhorn.Core.W +import Wetterhorn.StackSet + +data Full = Full + deriving (Read, Show, Typeable) + +instance Default Full where + def = Full + +instance HandleMessage Full + +instance LayoutClass Full where + type LayoutConstraint Full = Unconstrained + + runLayout = pureLayout $ \l _ -> + case l of + (focused -> Just a) -> [(a, RationalRect 1 1 1 1)] + _ -> [] diff --git a/plug/src/Wetterhorn/StackSet.hs b/plug/src/Wetterhorn/StackSet.hs new file mode 100644 index 0000000..86d1b8e --- /dev/null +++ b/plug/src/Wetterhorn/StackSet.hs @@ -0,0 +1,210 @@ +module Wetterhorn.StackSet where + +import Control.Monad (void) +import Data.Monoid (First(..)) +import Control.Monad.Identity +import Control.Monad.Writer (MonadWriter (tell), execWriter) +import Data.Maybe (isJust, mapMaybe) +import Data.Maybe (isJust) + +-- | The root datastructure for holding the state of the windows. +data StackSet s sd t l a = StackSet + { -- | The currently selected screen. + current :: Screen s sd t l a, + -- | Remaining visible screens. + visible :: [Screen s sd t l a], + -- | Workspaces that exist, but are not on a screen. + hidden :: [Workspace t l a] + } + deriving (Read, Show, Eq, Ord, Functor) + +class TraverseWorkspace f where + traverseWorkspaces :: + (Applicative m) => (Workspace t l a -> m (Workspace t' l' a')) -> f t l a -> m (f t' l' a') + +traverseWorkspaces_ :: (TraverseWorkspace f, Monad m) => (Workspace t l a -> m ()) -> f t l a -> m () +traverseWorkspaces_ f = void . traverseWorkspaces (\w -> f w >> pure w) + +foldMapWorkspaces :: + (Monoid m, TraverseWorkspace f) => (Workspace t l a -> m) -> f t l a -> m +foldMapWorkspaces fn = execWriter . traverseWorkspaces_ (tell . fn) + +mapWorkspaces :: + (TraverseWorkspace f) => + (Workspace t l a -> Workspace t' l' a') -> + f t l a -> + f t' l' a' +mapWorkspaces fn = runIdentity . traverseWorkspaces (pure . fn) + +instance TraverseWorkspace Workspace where + traverseWorkspaces f = f + +instance TraverseWorkspace (Screen s sd) where + traverseWorkspaces f scr = (\w' -> scr {workspace = w'}) <$> f (workspace scr) + +instance TraverseWorkspace (StackSet s sd) where + traverseWorkspaces f (StackSet cur vis hid) = + StackSet + <$> traverseWorkspaces f cur + <*> traverse (traverseWorkspaces f) vis + <*> traverse (traverseWorkspaces f) hid + +instance Traversable Stack where + traverse f (Stack u d) = + Stack <$> traverse f u <*> traverse f d + +instance (TraverseWorkspace f) => Foldable (f t l) where + foldMap fn = + execWriter + . traverseWorkspaces_ (\(Workspace _ _ s) -> tell (foldMap (fn . windowInSeat) s)) + +instance (Functor (f t l), TraverseWorkspace f) => Traversable (f t l) where + sequenceA = + traverseWorkspaces $ + \(Workspace t l sf) -> Workspace t l <$> traverse sequenceA sf + +class HasFocus f where + focused :: f a -> Maybe a + +data Rectangle = Rectangle Int Int Int Int + deriving (Read, Show, Eq, Ord) + +instance HasFocus (StackSet s sd t l) where + focused (StackSet c _ _) = focused c + +data Screen s sd t l a = Screen + { screenDetail :: sd, + screenId :: s, + workspace :: Workspace t l a + } + deriving (Read, Show, Eq, Ord, Functor) + +instance HasFocus (Screen s sd t l) where + focused (Screen _ _ w) = focused w + +-- | Defines where a window should appear. +data WindowSeat a = Floating Rectangle a | Tiled a + deriving (Read, Show, Eq, Ord, Functor, Foldable) + +windowInSeat :: WindowSeat a -> a +windowInSeat (Floating _ a) = a +windowInSeat (Tiled a) = a + +instance Traversable WindowSeat where + sequenceA (Floating r fa) = Floating r <$> fa + sequenceA (Tiled fa) = Tiled <$> fa + +instance HasFocus WindowSeat where + focused (Floating _ a) = Just a + focused (Tiled a) = Just a + +data Workspace t l a = Workspace + { tag :: t, + layout :: l, + stack :: Stack (WindowSeat a) + } + deriving (Read, Show, Eq, Ord, Functor) + +instance HasFocus (Workspace t l) where + focused (Workspace _ _ s) = windowInSeat <$> focused s + +data Stack a = Stack + { -- | The elements above the focused one. + up :: ![a], + -- | The elements below the focused one including the focused one itself. + down :: ![a] + } + deriving (Read, Show, Eq, Ord, Functor, Foldable) + +instance HasFocus Stack where + focused (Stack _ (a : _)) = Just a + focused _ = Nothing + +-- | Change the tag in a structure. +mapTag :: (TraverseWorkspace f) => (t -> t') -> f t l a -> f t' l a +mapTag fn = mapWorkspaces (\w -> w {tag = fn (tag w)}) + +-- | Change the layout in a structure. +mapLayout :: (TraverseWorkspace f) => (l -> l') -> f t l a -> f t l' a +mapLayout fn = mapWorkspaces (\w -> w {layout = fn (layout w)}) + +-- | Return all the tags in a structure. +tags :: (TraverseWorkspace f) => f t l a -> [t] +tags = foldMapWorkspaces ((: []) . tag) + +-- | Insert a new window into the StackSet. The optional rectangle indicates if +-- the window should be floating or tiled. +-- +-- The window is inserted just above the the currently focused window and is +-- given focus. +insert :: a -> Maybe Rectangle -> StackSet s sd t l a -> StackSet s sd t l a +insert win rect = + runIdentity + . onCurrentStack + ( \(Stack u d) -> + return $ + (\w -> Stack u (w : d)) $ + maybe (Tiled win) (`Floating` win) rect + ) + +-- | Find the tag associated with a window. +findTag :: (TraverseWorkspace f, Eq a) => a -> f t l a -> Maybe t +findTag a = + getFirst + . foldMapWorkspaces + ( \ws -> + foldMap + ( \a' -> + First $ if a' == a then Just (tag ws) else Nothing + ) + ws + ) + +-- | Return true if the window exist in a structure +elem :: (TraverseWorkspace f, Eq a) => a -> f t l a -> Bool +elem a = isJust . findTag a + +-- | Convenience function for inserting a window in stack set tiled. +insertTiled :: a -> StackSet s sd t l a -> StackSet s sd t l a +insertTiled win = insert win Nothing + +integrate :: Stack a -> [a] +integrate (Stack u d) = u ++ d + +differentiate :: [a] -> Stack a +differentiate = Stack [] + +applyStack :: + (Monad m) => + (Stack (WindowSeat a) -> m (Stack (WindowSeat a))) -> + Workspace t l a -> + m (Workspace t l a) +applyStack fn (Workspace t l s) = Workspace t l <$> fn s + +-- | Apply a function to the currently focused stack. +onCurrentStack :: + (Monad m) => + (Stack (WindowSeat a) -> m (Stack (WindowSeat a))) -> + StackSet s sd t l a -> + m (StackSet s sd t l a) +onCurrentStack fn (StackSet cur vis hid) = + StackSet <$> cur' cur <*> pure vis <*> pure hid + where + cur' (Screen s sd ws) = Screen s sd <$> ws' ws + ws' (Workspace t l s) = Workspace t l <$> fn s + +catMaybes :: StackSet s sd t l (Maybe a) -> StackSet s sd t l a +catMaybes (StackSet cur hidden visible) = + StackSet (catMaybesS cur) (map catMaybesS hidden) (map catMaybesW visible) + where + catMaybesS (Screen a b ws) = Screen a b $ catMaybesW ws + catMaybesW (Workspace a b st) = Workspace a b $ catMaybesSt st + catMaybesSt (Stack up down) = + Stack (mapMaybe sequenceA up) (mapMaybe sequenceA down) + +filter :: (a -> Bool) -> StackSet s sd t l a -> StackSet s sd t l a +filter ffn = + Wetterhorn.StackSet.catMaybes . fmap (\a -> if ffn a then Just a else Nothing) + +delete :: (Eq a) => a -> StackSet s sd t l a -> StackSet s sd t l a +delete win = Wetterhorn.StackSet.filter (/=win) diff --git a/plug/src/harness_adapter.c b/plug/src/harness_adapter.c new file mode 100644 index 0000000..24b813c --- /dev/null +++ b/plug/src/harness_adapter.c @@ -0,0 +1,81 @@ +// This file provides functions for the wetterhorn harness that are not +// expressible directly in haskell. +// +// Currently these functions exclusively enable/disable the Haskell runtime. + +#include "HsFFI.h" +#include "plugin_interface.h" +#include +#include +#include + +const char *plugin_name = "Wetterhorn"; + +void* foreign_interface; + +void* get_foreign_interface() +{ + return foreign_interface; +} + +extern void performMajorGC(); + +void plugin_metaload(int argc, char** argv) +{ + // hs_init(&argc, &argv); +} + +void plugin_load(int argc, char **argv, foreign_interface_t* fintf) { + hs_init(&argc, &argv); + foreign_interface = fintf; +} + +void plugin_teardown(opqst_t st) { + hs_exit(); +} + +void shell_exec(const char* cmd) { + if (fork() == 0) { + execl("/bin/sh", "/bin/sh", "-c", cmd, NULL); + exit(1); + } +} + +static const char msg[] = + "Wetterhorn Plugin v 0.01\n\n" + "Welcome, and thank you for your interest.\n\n" + "This is merely a plugin to the Wetterhorn Compositor and not meant to be\n" + "executed as a standalone binary. This plugin requires a harness to run\n" + "To use this file, please use './wtr_harness [full-path-to-wtr.so]'\n" + "That will allow you to see how this compositor works in all its glory!\n"; +static const int msg_sz = sizeof(msg); + +/* + * Implemens a basic _start that prints inforamtion and exits for users on an + * x86_64 system. + */ +__attribute__((naked)) void _start() +{ + + // Make system call to print the message + asm( + // Load the address of the string into rsi + "mov %0, %%rsi\n" + // Load the string length into edx + "mov %1, %%edx\n" + // Load the file descriptor for stdout into edi + "mov $1, %%edi\n" + // Load the syscall number for sys_write into eax + "mov $1, %%eax\n" + // Make the syscall + "syscall\n" + + // Exit the program. + "mov $0, %%rdi\n" + "mov $60, %%rax\n" + "syscall\n" + : + : "r"(msg), "r"(msg_sz) // Input: address of msg + : "%rsi", "%edx", "%edi" // Clobbered registers + ); +} diff --git a/plug/stack.yaml b/plug/stack.yaml new file mode 100644 index 0000000..2c4375a --- /dev/null +++ b/plug/stack.yaml @@ -0,0 +1,67 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# https://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +resolver: lts-23.28 +# ghc-9.6.4 +# lts-21.21 +# resolver: nightly-2023-09-24 +# resolver: ghc-9.6.2 +# +# The location of a snapshot can be provided as a file or url. Stack assumes +# a snapshot provided as a file might change, whereas a url resource does not. +# +# resolver: ./custom-snapshot.yaml +# resolver: https://example.com/snapshots/2023-01-01.yaml + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# subdirs: +# - auto-update +# - wai +packages: +- . +# Dependency packages to be pulled from upstream that are not in the resolver. +# These entries can reference officially published versions as well as +# forks / in-progress versions pinned to a git hash. For example: +# +# extra-deps: +# - acme-missiles-0.3 +# - git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# +# extra-deps: [] + +# Override default flag values for local packages and extra-deps +# flags: {} + +# Extra package databases containing global packages +# extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of Stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=2.13" +# +# Override the architecture used by Stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by Stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor diff --git a/plug/test/Spec.hs b/plug/test/Spec.hs new file mode 100644 index 0000000..cd4753f --- /dev/null +++ b/plug/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented" diff --git a/rt/CMakeLists.txt b/rt/CMakeLists.txt new file mode 100644 index 0000000..a7a0a77 --- /dev/null +++ b/rt/CMakeLists.txt @@ -0,0 +1,84 @@ +cmake_minimum_required(VERSION 3.10) +project ( + wtr_harness + VERSION 0.1 + LANGUAGES C) + +set(CMAKE_VERBOSE_MAKEFILE ON) +set(CMAKE_BUILD_TYPE Debug) + +include_directories(include/ ../wlroots/include /usr/include/pixman-1 + ${CMAKE_CURRENT_BINARY_DIR}/ + ${CMAKE_CURRENT_BINARY_DIR}/../wlroots/include + ${CMAKE_CURRENT_BINARY_DIR}/../wlroots/protocol +) + +add_definitions(-DWLR_USE_UNSTABLE) + +execute_process( + COMMAND pkg-config --variable=pkgdatadir wayland-protocols + OUTPUT_VARIABLE WAYLAND_PROTOCOLS + RESULT_VARIABLE ec + OUTPUT_STRIP_TRAILING_WHITESPACE +) +if(${ec} EQUAL 0) +else() + message(FATAL_ERROR "Failed to execute pkg-config") +endif() + +execute_process( + COMMAND pkg-config --variable=wayland_scanner wayland-scanner + OUTPUT_VARIABLE WAYLAND_SCANNER + RESULT_VARIABLE ec + OUTPUT_STRIP_TRAILING_WHITESPACE +) +if(${ec} EQUAL 0) +else() + message(FATAL_ERROR "Failed to execute pkg-config") +endif() + +set(PLUGIN_INTF ${CMAKE_BINARY_DIR}/plugin_interface.h) +add_custom_command( + OUTPUT ${PLUGIN_INTF} + COMMAND perl ${PROJECT_SOURCE_DIR}/tools/genintf.pl < + ${PROJECT_SOURCE_DIR}/include/plugin.h > ${PLUGIN_INTF} + DEPENDS ${PROJECT_SOURCE_DIR}/include/plugin.h + DEPENDS ${PROJECT_SOURCE_DIR}/tools/genintf.pl +) + +set(PLUGIN_LOAD ${CMAKE_BINARY_DIR}/gen_plugin_load.c) +add_custom_command( + OUTPUT ${PLUGIN_LOAD} + COMMAND perl ${PROJECT_SOURCE_DIR}/tools/genbuild.pl < + ${PROJECT_SOURCE_DIR}/include/plugin.h > ${PLUGIN_LOAD} + DEPENDS ${PROJECT_SOURCE_DIR}/include/plugin.h + DEPENDS ${PROJECT_SOURCE_DIR}/tools/genbuild.pl +) + +add_custom_command( + OUTPUT xdg-shell-protocol.h + COMMAND ${WAYLAND_SCANNER} server-header + ${WAYLAND_PROTOCOLS}/stable/xdg-shell/xdg-shell.xml + xdg-shell-protocol.h +) + +add_custom_command( + OUTPUT xdg-shell-protocol.c + COMMAND ${WAYLAND_SCANNER} private-code + ${WAYLAND_PROTOCOLS}/stable/xdg-shell/xdg-shell.xml + xdg-shell-protocol.c + DEPENDS xdg-shell-protocol.h +) + +file (GLOB_RECURSE SOURCES src/*.c) + +set(CMAKE_EXPORT_COMPILE_COMMANDS ON) + +add_executable (wtr_harness ${SOURCES} ${PLUGIN_LOAD} ${PLUGIN_INTF} + xdg-shell-protocol.c) + +target_link_libraries(wtr_harness dl) +target_link_directories(wtr_harness PUBLIC + "${CMAKE_CURRENT_BINARY_DIR}/../wlroots") +target_link_libraries(wtr_harness wlroots-0.18 wayland-server xkbcommon pthread) +target_link_options(wtr_harness PRIVATE -Wl,--wrap=pthread_create) diff --git a/rt/include/foreign_intf.h b/rt/include/foreign_intf.h new file mode 100644 index 0000000..6558fab --- /dev/null +++ b/rt/include/foreign_intf.h @@ -0,0 +1,33 @@ +/* Contains a structure, which contains functions to back-call into + * the harness code. */ + +#ifndef __FOREIGN_INTERFACE +#define __FOREIGN_INTERFACE + +#define EXPORT(a) a + +typedef void *ctx_t; + +typedef struct FOREIGN_INTERFACE { + /* DO NOT ADD ANY UNEXPORTED VARIABLES HERE */ + + /* The context, which needs to be passed to each function. This context is + * opaque to the plugin and should not be changed. */ + EXPORT(ctx_t ctx); + + /* Requests the harness hot reload the current plugin. */ + EXPORT(void (*request_hot_reload)(ctx_t ctx)); + + /* Requests the harness hot reload the current plugin. */ + EXPORT(void (*do_log)(ctx_t ctx, const char *str)); + + /* Requestes that the whole system exit. Exits with the given return code. */ + EXPORT(void (*request_exit)(ctx_t ctx, int rc)); + + /* Returns the seat associated with the server. */ + EXPORT(void *(*get_seat)(ctx_t ctx)); +} foreign_interface_t; + +#undef EXPORT + +#endif /* __FOREIGN_INTERFACE */ diff --git a/rt/include/plugin.h b/rt/include/plugin.h new file mode 100644 index 0000000..4d69d76 --- /dev/null +++ b/rt/include/plugin.h @@ -0,0 +1,190 @@ +#ifndef _PLUGIN_H_ +#define _PLUGIN_H_ + +#include +#include +#include +#include +#include +#include +#include +#include + +#include "plugin_types.h" +#include + +/* + * Marker macro to define what functions should be exported. This generates the + * interface which the plugin needs to implement. + */ +#define EXPORT(a) a + +#define EXPORT_INCLUDE(a) + +// clang-format off +EXPORT_INCLUDE() +EXPORT_INCLUDE() +EXPORT_INCLUDE() +EXPORT_INCLUDE() +// clang-format on + +#define MAX_QUEUED_ACTIONS 8 + +typedef void *dlhandle_t; + +/* Opaque state for a plugin. Not to be touched by the harness (not that it + * really can be.) */ + +struct PLUGIN; +/* This structure represents an action requested by the plugin for the harness. + */ +typedef struct { + int (*action)(struct PLUGIN *requester, void *arg); + void (*arg_dtor)(void *arg); + union { + void *ptr_arg; + int int_arg; + char *str_arg; + }; +} requested_action_t; + +/* + * Structure for the plugin. + */ +typedef struct PLUGIN { + /* The argc this plugin is loaded with. Typically the argc from main(). */ + int argc; + + /* The argv this plugin is loaded with. Typically the argv from main(). */ + char **argv; + + /* Filename the plugin is loaded from. */ + char filename[PATH_MAX]; + + /* Interface to the harness that this plugin can use. */ + foreign_interface_t foreign_intf; + + /* Opaque state of this plugin. The state is usually some kind of pointer to + * the plugin state, but all the harness knows is the opaque state is a + * pointer-sized piece of data. + * + * This opaque state is used in a linear pattern where the handlers take the + * opaque state, maybe operate on it, and return a new opaque state, which is + * then passed to the next handler, etc. It is on the plugin to properly + * manager the memory for this state and to destroy it upon teardown. + * + * It's guaranteed that this state is used linearly, meaning the harness gives + * up all ownership to it once passed into a handler. */ + opqst_t state; + + /* This plugin's lock. This avoids potential issues with multiple threads + * trying to change the opaque state at once which can lead to undesireable + * outcomes. */ + pthread_mutex_t lock; + + /** Set to not-zero if this plugin is initialized, otherwise set to zero. */ + int initialized; + + /* The handle to the shared library. */ + dlhandle_t library_handle; + + /* Pointer to the plugin name. This is in the shared library and a + * null-terminated string. If the library does not have a plugin name, this + * will be NULL. */ + const char *plugin_name; + + /** + * Initializes the plugin on the first time, and only the first time, it is + * loaded. This is used to do things like setup a runtime that cannot be + * reliably torn down. It is up to the plugin to ensure this won't interfere + * with hot-reloading. + */ + EXPORT(void (*plugin_metaload)(int argc, char **argv)); + + /** Intializes the plugin with the given argc/argv. This is the first thing + * called on the plugin and is called immediately after the library is loaded. + */ + EXPORT(void (*plugin_load)(int argc, char **argv, foreign_interface_t *intf)); + + /* Start the plugin with the marshalled state from the previous plugin. + * + * This should return the opaque state from the mashalled_state. + * + * This function should not fail if the state cannot be demarshalled, rather a + * default state should be returned. This is because changing the plugin and + * hot-reloading can produce incompatibilities between the old state and the + * new state, and this should not cause a failure. + */ + EXPORT(opqst_t (*plugin_hot_start)(uint8_t *mashalled_state, uint32_t n)); + + /* + * Starts the plugin without a marshalled state. Happens during the first boot + * when there is not state. + */ + EXPORT(opqst_t (*plugin_cold_start)()); + + /* + * Marshals the state to a bytestring. The returned pointer should be malloc'd + * on the heap. The harness takes ownership of the malloc'd pointer. + * + * This is usually called in preparation for a teardown followed by a + * hot-start. + */ + EXPORT(uint8_t *(*plugin_marshal_state)(opqst_t st, uint32_t *szout)); + + /* + * Teardown the plugin in preperation for the library's imminent unloading. + */ + EXPORT(void (*plugin_teardown)(opqst_t)); + + /* + * Handles a keybinding. + */ + EXPORT(opqst_t (*plugin_handle_keybinding)( + struct wlr_keyboard *keyboard, struct wlr_keyboard_key_event *event, + uint32_t modifiers, uint32_t keysym, uint32_t codepoint, int *out_handled, + opqst_t state)); + + EXPORT(opqst_t (*plugin_handle_button)(struct wlr_pointer_button_event *event, + uint32_t modifiers, opqst_t state)); + + /* + * Handles a surface being mapped, unmapped or destroyed. + */ + EXPORT(opqst_t (*plugin_handle_surface)(void *surface, surface_event_t event, + opqst_t)); + + /* List of requested actions by the plugin. Right now there is a maximum of 8 + * allowed at one time. That should be plenty. The actions should be flushed + * after each call to a handler anyway. */ + size_t n_requested_actions; + requested_action_t requested_actions[MAX_QUEUED_ACTIONS]; +} plugin_t; + +#undef EXPORT +#undef EXPORT_INCLUDE + +/* Reloads the plugin. This tears down the existing plugin, marshals the state + * for it and reloads it. + * + * This function will call dlclose on the plugin's library handle. + */ +int plugin_hot_reload(int argc, char **argv, const char *filepath, + plugin_t *plugin); + +/* + * Like hot-reload, but uses the same parameters the plugin was originally + * loaded with. + */ +int plugin_hot_reload_same_state(plugin_t *plugin); + +/* Starts a plugin in a cold state. Called after load_plugin_from_file. */ +void plugin_cold_start(plugin_t *plugin); + +/* Reads a plugin from a filename. */ +int load_plugin_from_file(int argc, char **argv, const char *filename, + plugin_t *plugin); + +void plugin_run_requested_actions(plugin_t *plugin); + +#endif /* _PLUGIN_H_ */ diff --git a/rt/include/plugin_types.h b/rt/include/plugin_types.h new file mode 100644 index 0000000..df1eab5 --- /dev/null +++ b/rt/include/plugin_types.h @@ -0,0 +1,9 @@ +#pragma once + +typedef void *opqst_t; + +typedef enum { + SURFACE_MAP = 0, + SURFACE_UNMAP, + SURFACE_DELETE, +} surface_event_t; diff --git a/rt/include/wl.h b/rt/include/wl.h new file mode 100644 index 0000000..dc7fe9f --- /dev/null +++ b/rt/include/wl.h @@ -0,0 +1,116 @@ +#pragma once + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#include + +/* For brevity's sake, struct members are annotated where they are used. */ +enum montis_cursor_mode { + TINYWL_CURSOR_PASSTHROUGH, + TINYWL_CURSOR_MOVE, + TINYWL_CURSOR_RESIZE, +}; + +struct montis_server { + struct wl_display *wl_display; + struct wlr_backend *backend; + struct wlr_renderer *renderer; + struct wlr_allocator *allocator; + struct wlr_scene *scene; + struct wlr_scene_output_layout *scene_layout; + + struct wlr_xdg_shell *xdg_shell; + struct wl_listener new_xdg_toplevel; + struct wl_listener new_xdg_popup; + struct wl_list toplevels; + + struct wlr_cursor *cursor; + struct wlr_xcursor_manager *cursor_mgr; + struct wl_listener cursor_motion; + struct wl_listener cursor_motion_absolute; + struct wl_listener cursor_button; + struct wl_listener cursor_axis; + struct wl_listener cursor_frame; + + struct wlr_seat *seat; + struct wl_listener new_input; + struct wl_listener request_cursor; + struct wl_listener request_set_selection; + struct wl_list keyboards; + enum montis_cursor_mode cursor_mode; + struct montis_toplevel *grabbed_toplevel; + double grab_x, grab_y; + struct wlr_box grab_geobox; + uint32_t resize_edges; + + struct wlr_output_layout *output_layout; + struct wl_list outputs; + struct wl_listener new_output; + + struct wlr_session *session; + plugin_t plugin; +}; + +struct montis_output { + struct wl_list link; + struct montis_server *server; + struct wlr_output *wlr_output; + struct wl_listener frame; + struct wl_listener request_state; + struct wl_listener destroy; +}; + +struct montis_toplevel { + struct wl_list link; + struct montis_server *server; + struct wlr_xdg_toplevel *xdg_toplevel; + struct wlr_scene_tree *scene_tree; + struct wl_listener map; + struct wl_listener unmap; + struct wl_listener destroy; + struct wl_listener commit; + struct wl_listener request_move; + struct wl_listener request_resize; + struct wl_listener request_maximize; + struct wl_listener request_fullscreen; +}; + +struct montis_keyboard { + struct wl_list link; + struct montis_server *server; + struct wlr_keyboard *wlr_keyboard; + + struct wl_listener modifiers; + struct wl_listener key; + struct wl_listener destroy; +}; + +struct montis_popup { + struct wlr_xdg_popup *xdg_popup; + struct wl_listener commit; + struct wl_listener destroy; +}; + diff --git a/rt/src/plugin.c b/rt/src/plugin.c new file mode 100644 index 0000000..37a6dd3 --- /dev/null +++ b/rt/src/plugin.c @@ -0,0 +1,266 @@ +#include "plugin.h" +#include "foreign_intf.h" +#include "wl.h" + +#include +#include +#include +#include +#include +#include +#include +#include + +/* Utility function for showing the marshalled states as hex code */ +static void shx(uint8_t *state, uint32_t sz) +{ + uint32_t i = 0; + while (i < sz) { + for (int j = 0; j < 16; ++j) { + if (i < sz) { + printf("%02x ", (unsigned int)state[i]); + } + else { + printf(" "); + } + ++i; + } + + i -= 16; + + printf(" "); + + for (int j = 0; j < 16; ++j) { + if (i < sz) { + if (isprint(state[i]) && !isspace(state[i])) { + printf("%c", state[i]); + } + else { + printf("."); + } + } + else { + printf(" "); + } + ++i; + } + printf("\n"); + } +} + +int load_plugin_from_dl_(dlhandle_t dl, plugin_t *plug); + +static void lock(plugin_t *plugin) { pthread_mutex_lock(&plugin->lock); }; + +static void unlock(plugin_t *plugin) { pthread_mutex_unlock(&plugin->lock); }; + +static int plugin_hot_reload_same_state_action_(plugin_t *plugin, void *ignore) +{ + return plugin_hot_reload_same_state(plugin); +} + +void do_request_hot_reload(void *plugv) +{ + plugin_t *plugin = plugv; + + size_t n = plugin->n_requested_actions++; + if (n < 8) { + plugin->requested_actions[n].action = plugin_hot_reload_same_state_action_; + plugin->requested_actions[n].arg_dtor = NULL; + } +} + +static int plugin_do_log(plugin_t *plugin, void *chrs) +{ + char *str = chrs; + puts(str); + return 0; +} + +void do_request_log(void *plugv, const char *str) +{ + plugin_t *plugin = plugv; + + size_t n = plugin->n_requested_actions++; + if (n < 8) { + plugin->requested_actions[n].action = plugin_do_log; + plugin->requested_actions[n].str_arg = strdup(str); + plugin->requested_actions[n].arg_dtor = free; + } +} + +static int plugin_do_exit(void *plugv, int ec) +{ + exit(ec); + return 0; +} + +void do_request_exit(void *plugv, int ec) +{ + plugin_t *plugin = plugv; + + size_t n = plugin->n_requested_actions++; + if (n < 8) { + plugin->requested_actions[n].action = + (int (*)(plugin_t *, void *))plugin_do_exit; + plugin->requested_actions[n].int_arg = ec; + plugin->requested_actions[n].arg_dtor = NULL; + } +} + +static void* plugin_get_seat(void* ctx) { + struct montis_server* server = wl_container_of(ctx, server, plugin); + return server->seat; +} + +static int load_plugin_from_file_(int argc, char **argv, const char *filename, + plugin_t *plugin) +{ + dlhandle_t lib = dlopen(filename, RTLD_LAZY); + int ec = 0; + + if (!lib) { + fprintf(stderr, "Failed to open library: %s: %s\n", filename, dlerror()); + ec = 1; + goto end; + } + + printf("Loading file.\n"); + ec = load_plugin_from_dl_(lib, plugin); + + if (ec) { + goto end; + } + + strncpy(plugin->filename, filename, sizeof(plugin->filename)); + plugin->argc = argc; + plugin->argv = argv; + + plugin->foreign_intf.ctx = plugin; + plugin->foreign_intf.request_hot_reload = do_request_hot_reload; + plugin->foreign_intf.do_log = do_request_log; + plugin->foreign_intf.request_exit = do_request_exit; + plugin->foreign_intf.get_seat = plugin_get_seat; + + plugin->plugin_load(plugin->argc, plugin->argv, &plugin->foreign_intf); +end: + return ec; +} + +static void maybe_run_metaload(int argc, char **argv, plugin_t *plugin) +{ + static char *loaded_plugins[12]; + int i; + for (i = 0; i < 12 && loaded_plugins[i]; ++i) { + if (strcmp(loaded_plugins[i], plugin->plugin_name) == 0) { + return; // Plugin is already loaded + } + } + loaded_plugins[i] = strdup(plugin->plugin_name); + + printf("First time loading %s, running metaload.\n", plugin->plugin_name); + if (plugin->plugin_metaload) { + plugin->plugin_metaload(argc, argv); + } +} + +int load_plugin_from_file(int argc, char **argv, const char *filename, + plugin_t *plugin) +{ + memset(plugin, 0, sizeof(*plugin)); + + pthread_mutexattr_t attr; + if (pthread_mutexattr_init(&attr)) { + perror("pthread_mutexattr_init"); + return 1; + } + + if (pthread_mutexattr_settype(&attr, PTHREAD_MUTEX_RECURSIVE)) { + perror("pthread_mutexattr_settype"); + return 1; + } + + if (pthread_mutex_init(&plugin->lock, &attr)) { + pthread_mutexattr_destroy(&attr); + perror("pthread_mutexattr_init"); + return 1; + } + pthread_mutexattr_destroy(&attr); + int rc = load_plugin_from_file_(argc, argv, filename, plugin); + + if (rc == 0) { + maybe_run_metaload(argc, argv, plugin); + } + + return rc; +} + +int plugin_hot_reload_same_state(plugin_t *plugin) +{ + char filename_cpy[PATH_MAX]; + strncpy(filename_cpy, plugin->filename, sizeof(filename_cpy)); + return plugin_hot_reload(plugin->argc, plugin->argv, filename_cpy, plugin); +} + +int plugin_hot_reload(int argc, char **argv, const char *filepath, + plugin_t *plugin) +{ + int ec = 0; + uint32_t sz = 0; + uint8_t *marshalled_state = NULL; + + printf("Hot Reloading %s\n", plugin->plugin_name); + lock(plugin); + + printf("Marshalling state ...\n"); + marshalled_state = plugin->plugin_marshal_state(plugin->state, &sz); + + printf("Calling teardown ...\n"); + plugin->plugin_teardown(plugin->state); + + printf("State Marshalled:\n"); + shx(marshalled_state, sz); + + printf("Unloading old library handle.\n"); + if (dlclose(plugin->library_handle)) { + printf("Could not close library handle: %s\n", dlerror()); + } + + if ((ec = load_plugin_from_file_(argc, argv, filepath, plugin))) { + goto fail; + } + + printf("Hot starting plugin ...\n"); + plugin->state = plugin->plugin_hot_start(marshalled_state, sz); + +fail: + free(marshalled_state); + unlock(plugin); + return ec; +} + +void plugin_run_requested_actions(plugin_t *plugin) +{ + lock(plugin); + requested_action_t requested_actions[MAX_QUEUED_ACTIONS]; + size_t n_requested_actions = plugin->n_requested_actions; + memcpy(&requested_actions, plugin->requested_actions, + sizeof(requested_actions)); + plugin->n_requested_actions = 0; + unlock(plugin); + + size_t i; + for (i = 0; i < n_requested_actions; ++i) { + requested_actions[i].action(plugin, requested_actions[i].str_arg); + if (requested_actions[i].arg_dtor) { + requested_actions[i].arg_dtor(requested_actions[i].ptr_arg); + } + } +} + +void plugin_cold_start(plugin_t *plugin) +{ + lock(plugin); + plugin->state = plugin->plugin_cold_start(); + unlock(plugin); +} diff --git a/rt/src/wl.c b/rt/src/wl.c new file mode 100644 index 0000000..261e082 --- /dev/null +++ b/rt/src/wl.c @@ -0,0 +1,1066 @@ +#define _POSIX_C_SOURCE 200112L + +#include +#include +#include +#include + +#include + +#include "xdg-decoration-unstable-v1-client-protocol.h" + +// This macro is responsible for calling a handler on a plugin. This macro will +// acquire the plugin's lock, call the member with the arguments and update the +// state. +// +// This only works on function which have the format: +// +// opqst_t function(args ..., opqst_t state); +// +// Note that the state parameter is omitted from this macro. +#define plugin_call_update_state(plugin, member, ...) \ + do { \ + plugin_t *pl__ = &(plugin); \ + pthread_mutex_lock(&pl__->lock); \ + pl__->state = pl__->member(__VA_ARGS__, pl__->state); \ + pthread_mutex_unlock(&pl__->lock); \ + plugin_run_requested_actions(pl__); \ + } while (0) + +static void focus_toplevel(struct montis_toplevel *toplevel, + struct wlr_surface *surface) +{ + /* Note: this function only deals with keyboard focus. */ + if (toplevel == NULL) { + return; + } + struct montis_server *server = toplevel->server; + struct wlr_seat *seat = server->seat; + struct wlr_surface *prev_surface = seat->keyboard_state.focused_surface; + if (prev_surface == surface) { + /* Don't re-focus an already focused surface. */ + return; + } + if (prev_surface) { + /* + * Deactivate the previously focused surface. This lets the client know + * it no longer has focus and the client will repaint accordingly, e.g. + * stop displaying a caret. + */ + struct wlr_xdg_toplevel *prev_toplevel = + wlr_xdg_toplevel_try_from_wlr_surface(prev_surface); + if (prev_toplevel != NULL) { + wlr_xdg_toplevel_set_activated(prev_toplevel, false); + } + } + struct wlr_keyboard *keyboard = wlr_seat_get_keyboard(seat); + /* Move the toplevel to the front */ + wlr_scene_node_raise_to_top(&toplevel->scene_tree->node); + wl_list_remove(&toplevel->link); + wl_list_insert(&server->toplevels, &toplevel->link); + /* Activate the new surface */ + wlr_xdg_toplevel_set_activated(toplevel->xdg_toplevel, true); + /* + * Tell the seat to have the keyboard enter this surface. wlroots will keep + * track of this and automatically send key events to the appropriate + * clients without additional work on your part. + */ + if (keyboard != NULL) { + wlr_seat_keyboard_notify_enter(seat, toplevel->xdg_toplevel->base->surface, + keyboard->keycodes, keyboard->num_keycodes, + &keyboard->modifiers); + } +} + +static void keyboard_handle_modifiers(struct wl_listener *listener, void *data) +{ + /* This event is raised when a modifier key, such as shift or alt, is + * pressed. We simply communicate this to the client. */ + struct montis_keyboard *keyboard = + wl_container_of(listener, keyboard, modifiers); + /* + * A seat can only have one keyboard, but this is a limitation of the + * Wayland protocol - not wlroots. We assign all connected keyboards to the + * same seat. You can swap out the underlying wlr_keyboard like this and + * wlr_seat handles this transparently. + */ + wlr_seat_set_keyboard(keyboard->server->seat, keyboard->wlr_keyboard); + /* Send modifiers to the client. */ + wlr_seat_keyboard_notify_modifiers(keyboard->server->seat, + &keyboard->wlr_keyboard->modifiers); +} + +static void keyboard_handle_key(struct wl_listener *listener, void *data) +{ + /* This event is raised when a key is pressed or released. */ + struct montis_keyboard *keyboard = wl_container_of(listener, keyboard, key); + struct montis_server *server = keyboard->server; + struct wlr_keyboard_key_event *event = data; + struct wlr_seat *seat = server->seat; + + /* Translate libinput keycode -> xkbcommon */ + uint32_t keycode = event->keycode + 8; + /* Get a list of keysyms based on the keymap for this keyboard */ + const xkb_keysym_t *syms; + int nsyms = + xkb_state_key_get_syms(keyboard->wlr_keyboard->xkb_state, keycode, &syms); + + int handled = false; + uint32_t modifiers = wlr_keyboard_get_modifiers(keyboard->wlr_keyboard); + uint32_t codepoint; + int ec; + + if (nsyms > 0 && syms[0] >= XKB_KEY_XF86Switch_VT_1 && + syms[0] <= XKB_KEY_XF86Switch_VT_12) { + /* Escape-hatch to change sessions. These should always be available key + * bindings regardless of what the plugin dictates. This allows an escape + * hatch to edit the plugin in a different vterm and then use the escape + * hatch below to hot-restart the plugin if things get borked. */ + if (event->state == WL_KEYBOARD_KEY_STATE_PRESSED) { + wlr_session_change_vt(server->session, + syms[0] - XKB_KEY_XF86Switch_VT_1 + 1); + } + } + else if (modifiers == + (WLR_MODIFIER_SHIFT | WLR_MODIFIER_CTRL | WLR_MODIFIER_ALT) && + nsyms > 0 && syms[0] == XKB_KEY_Escape) { + /* Escape-hatch to hot-reload the plugin in case the plugin got borked and + * stops accepting keybindings. Ctrl+Shift+Alt+Escape will always reload the + * plugin.*/ + if (event->state == WL_KEYBOARD_KEY_STATE_PRESSED) { + if ((ec = plugin_hot_reload_same_state(&server->plugin)) != 0) { + fprintf(stderr, "Failed to hot reload plugin"); + exit(1); + } + } + } + else { + /* Pass the information along to the plugin for the plugin to handle. The + * plugin will return via 'handled' whether or not the key event was handled + * or not. */ + if (nsyms > 0) { + codepoint = + xkb_state_key_get_utf32(keyboard->wlr_keyboard->xkb_state, keycode); + plugin_call_update_state(server->plugin, plugin_handle_keybinding, + keyboard->wlr_keyboard, event, modifiers, + syms[0], codepoint, &handled); + } + } +} + +static void keyboard_handle_destroy(struct wl_listener *listener, void *data) +{ + /* This event is raised by the keyboard base wlr_input_device to signal + * the destruction of the wlr_keyboard. It will no longer receive events + * and should be destroyed. + */ + struct montis_keyboard *keyboard = + wl_container_of(listener, keyboard, destroy); + wl_list_remove(&keyboard->modifiers.link); + wl_list_remove(&keyboard->key.link); + wl_list_remove(&keyboard->destroy.link); + wl_list_remove(&keyboard->link); + free(keyboard); +} + +static void server_new_keyboard(struct montis_server *server, + struct wlr_input_device *device) +{ + struct wlr_keyboard *wlr_keyboard = wlr_keyboard_from_input_device(device); + + struct montis_keyboard *keyboard = calloc(1, sizeof(*keyboard)); + keyboard->server = server; + keyboard->wlr_keyboard = wlr_keyboard; + + struct xkb_rule_names names = (struct xkb_rule_names){0}; + names.layout = "jr"; + names.variant = "jdvprk"; + names.options = "numpad:mac"; + + /* We need to prepare an XKB keymap and assign it to the keyboard. This + * assumes the defaults (e.g. layout = "us"). */ + struct xkb_context *context = xkb_context_new(XKB_CONTEXT_NO_FLAGS); + struct xkb_keymap *keymap = + xkb_keymap_new_from_names(context, &names, XKB_KEYMAP_COMPILE_NO_FLAGS); + + if (!keymap) { + fprintf(stderr, "Unable to read keymap.\n"); + exit(1); + } + + wlr_keyboard_set_keymap(wlr_keyboard, keymap); + xkb_keymap_unref(keymap); + xkb_context_unref(context); + wlr_keyboard_set_repeat_info(wlr_keyboard, 25, 600); + + /* Here we set up listeners for keyboard events. */ + keyboard->modifiers.notify = keyboard_handle_modifiers; + wl_signal_add(&wlr_keyboard->events.modifiers, &keyboard->modifiers); + keyboard->key.notify = keyboard_handle_key; + wl_signal_add(&wlr_keyboard->events.key, &keyboard->key); + keyboard->destroy.notify = keyboard_handle_destroy; + wl_signal_add(&device->events.destroy, &keyboard->destroy); + + wlr_seat_set_keyboard(server->seat, keyboard->wlr_keyboard); + + /* And add the keyboard to our list of keyboards */ + wl_list_insert(&server->keyboards, &keyboard->link); +} + +static void server_new_pointer(struct montis_server *server, + struct wlr_input_device *device) +{ + /* We don't do anything special with pointers. All of our pointer handling + * is proxied through wlr_cursor. On another compositor, you might take this + * opportunity to do libinput configuration on the device to set + * acceleration, etc. */ + wlr_cursor_attach_input_device(server->cursor, device); +} + +static void server_new_input(struct wl_listener *listener, void *data) +{ + /* This event is raised by the backend when a new input device becomes + * available. */ + struct montis_server *server = wl_container_of(listener, server, new_input); + struct wlr_input_device *device = data; + switch (device->type) { + case WLR_INPUT_DEVICE_KEYBOARD: + server_new_keyboard(server, device); + break; + case WLR_INPUT_DEVICE_POINTER: + server_new_pointer(server, device); + break; + default: + break; + } + /* We need to let the wlr_seat know what our capabilities are, which is + * communiciated to the client. In TinyWL we always have a cursor, even if + * there are no pointer devices, so we always include that capability. */ + uint32_t caps = WL_SEAT_CAPABILITY_POINTER; + if (!wl_list_empty(&server->keyboards)) { + caps |= WL_SEAT_CAPABILITY_KEYBOARD; + } + wlr_seat_set_capabilities(server->seat, caps); +} + +static void seat_request_cursor(struct wl_listener *listener, void *data) +{ + struct montis_server *server = + wl_container_of(listener, server, request_cursor); + /* This event is raised by the seat when a client provides a cursor image */ + struct wlr_seat_pointer_request_set_cursor_event *event = data; + struct wlr_seat_client *focused_client = + server->seat->pointer_state.focused_client; + /* This can be sent by any client, so we check to make sure this one is + * actually has pointer focus first. */ + if (focused_client == event->seat_client) { + /* Once we've vetted the client, we can tell the cursor to use the + * provided surface as the cursor image. It will set the hardware cursor + * on the output that it's currently on and continue to do so as the + * cursor moves between outputs. */ + wlr_cursor_set_surface(server->cursor, event->surface, event->hotspot_x, + event->hotspot_y); + } +} + +static void seat_request_set_selection(struct wl_listener *listener, void *data) +{ + /* This event is raised by the seat when a client wants to set the selection, + * usually when the user copies something. wlroots allows compositors to + * ignore such requests if they so choose, but in montis we always honor + */ + struct montis_server *server = + wl_container_of(listener, server, request_set_selection); + struct wlr_seat_request_set_selection_event *event = data; + wlr_seat_set_selection(server->seat, event->source, event->serial); +} + +static struct montis_toplevel *desktop_toplevel_at(struct montis_server *server, + double lx, double ly, + struct wlr_surface **surface, + double *sx, double *sy) +{ + /* This returns the topmost node in the scene at the given layout coords. + * We only care about surface nodes as we are specifically looking for a + * surface in the surface tree of a montis_toplevel. */ + struct wlr_scene_node *node = + wlr_scene_node_at(&server->scene->tree.node, lx, ly, sx, sy); + if (node == NULL || node->type != WLR_SCENE_NODE_BUFFER) { + return NULL; + } + struct wlr_scene_buffer *scene_buffer = wlr_scene_buffer_from_node(node); + struct wlr_scene_surface *scene_surface = + wlr_scene_surface_try_from_buffer(scene_buffer); + if (!scene_surface) { + return NULL; + } + + *surface = scene_surface->surface; + /* Find the node corresponding to the montis_toplevel at the root of this + * surface tree, it is the only one for which we set the data field. */ + struct wlr_scene_tree *tree = node->parent; + while (tree != NULL && tree->node.data == NULL) { + tree = tree->node.parent; + } + return tree->node.data; +} + +static void reset_cursor_mode(struct montis_server *server) +{ + /* Reset the cursor mode to passthrough. */ + server->cursor_mode = TINYWL_CURSOR_PASSTHROUGH; + server->grabbed_toplevel = NULL; +} + +static void process_cursor_move(struct montis_server *server, uint32_t time) +{ + /* Move the grabbed toplevel to the new position. */ + struct montis_toplevel *toplevel = server->grabbed_toplevel; + wlr_scene_node_set_position(&toplevel->scene_tree->node, + server->cursor->x - server->grab_x, + server->cursor->y - server->grab_y); +} + +static void process_cursor_resize(struct montis_server *server, uint32_t time) +{ + /* + * Resizing the grabbed toplevel can be a little bit complicated, because we + * could be resizing from any corner or edge. This not only resizes the + * toplevel on one or two axes, but can also move the toplevel if you resize + * from the top or left edges (or top-left corner). + * + * Note that some shortcuts are taken here. In a more fleshed-out + * compositor, you'd wait for the client to prepare a buffer at the new + * size, then commit any movement that was prepared. + */ + struct montis_toplevel *toplevel = server->grabbed_toplevel; + double border_x = server->cursor->x - server->grab_x; + double border_y = server->cursor->y - server->grab_y; + int new_left = server->grab_geobox.x; + int new_right = server->grab_geobox.x + server->grab_geobox.width; + int new_top = server->grab_geobox.y; + int new_bottom = server->grab_geobox.y + server->grab_geobox.height; + + if (server->resize_edges & WLR_EDGE_TOP) { + new_top = border_y; + if (new_top >= new_bottom) { + new_top = new_bottom - 1; + } + } + else if (server->resize_edges & WLR_EDGE_BOTTOM) { + new_bottom = border_y; + if (new_bottom <= new_top) { + new_bottom = new_top + 1; + } + } + if (server->resize_edges & WLR_EDGE_LEFT) { + new_left = border_x; + if (new_left >= new_right) { + new_left = new_right - 1; + } + } + else if (server->resize_edges & WLR_EDGE_RIGHT) { + new_right = border_x; + if (new_right <= new_left) { + new_right = new_left + 1; + } + } + + struct wlr_box geo_box; + wlr_xdg_surface_get_geometry(toplevel->xdg_toplevel->base, &geo_box); + wlr_scene_node_set_position(&toplevel->scene_tree->node, new_left - geo_box.x, + new_top - geo_box.y); + + int new_width = new_right - new_left; + int new_height = new_bottom - new_top; + wlr_xdg_toplevel_set_size(toplevel->xdg_toplevel, new_width, new_height); +} + +static void process_cursor_motion(struct montis_server *server, uint32_t time) +{ + /* If the mode is non-passthrough, delegate to those functions. */ + if (server->cursor_mode == TINYWL_CURSOR_MOVE) { + process_cursor_move(server, time); + return; + } + else if (server->cursor_mode == TINYWL_CURSOR_RESIZE) { + process_cursor_resize(server, time); + return; + } + + /* Otherwise, find the toplevel under the pointer and send the event along. */ + double sx, sy; + struct wlr_seat *seat = server->seat; + struct wlr_surface *surface = NULL; + struct montis_toplevel *toplevel = desktop_toplevel_at( + server, server->cursor->x, server->cursor->y, &surface, &sx, &sy); + if (!toplevel) { + /* If there's no toplevel under the cursor, set the cursor image to a + * default. This is what makes the cursor image appear when you move it + * around the screen, not over any toplevels. */ + wlr_cursor_set_xcursor(server->cursor, server->cursor_mgr, "default"); + } + if (surface) { + /* + * Send pointer enter and motion events. + * + * The enter event gives the surface "pointer focus", which is distinct + * from keyboard focus. You get pointer focus by moving the pointer over + * a window. + * + * Note that wlroots will avoid sending duplicate enter/motion events if + * the surface has already has pointer focus or if the client is already + * aware of the coordinates passed. + */ + wlr_seat_pointer_notify_enter(seat, surface, sx, sy); + wlr_seat_pointer_notify_motion(seat, time, sx, sy); + } + else { + /* Clear pointer focus so future button events and such are not sent to + * the last client to have the cursor over it. */ + wlr_seat_pointer_clear_focus(seat); + } +} + +static void server_cursor_motion(struct wl_listener *listener, void *data) +{ + /* This event is forwarded by the cursor when a pointer emits a _relative_ + * pointer motion event (i.e. a delta) */ + struct montis_server *server = + wl_container_of(listener, server, cursor_motion); + struct wlr_pointer_motion_event *event = data; + /* The cursor doesn't move unless we tell it to. The cursor automatically + * handles constraining the motion to the output layout, as well as any + * special configuration applied for the specific input device which + * generated the event. You can pass NULL for the device if you want to move + * the cursor around without any input. */ + wlr_cursor_move(server->cursor, &event->pointer->base, event->delta_x, + event->delta_y); + process_cursor_motion(server, event->time_msec); +} + +static void server_cursor_motion_absolute(struct wl_listener *listener, + void *data) +{ + /* This event is forwarded by the cursor when a pointer emits an _absolute_ + * motion event, from 0..1 on each axis. This happens, for example, when + * wlroots is running under a Wayland window rather than KMS+DRM, and you + * move the mouse over the window. You could enter the window from any edge, + * so we have to warp the mouse there. There is also some hardware which + * emits these events. */ + struct montis_server *server = + wl_container_of(listener, server, cursor_motion_absolute); + struct wlr_pointer_motion_absolute_event *event = data; + wlr_cursor_warp_absolute(server->cursor, &event->pointer->base, event->x, + event->y); + process_cursor_motion(server, event->time_msec); +} + +static void server_cursor_button(struct wl_listener *listener, void *data) +{ + /* This event is forwarded by the cursor when a pointer emits a button + * event. */ + struct montis_server *server = + wl_container_of(listener, server, cursor_button); + struct wlr_pointer_button_event *event = data; + struct wlr_seat *seat = server->seat; + struct wlr_keyboard *keyboard = wlr_seat_get_keyboard(seat); + uint32_t modifiers = wlr_keyboard_get_modifiers(keyboard); + + plugin_call_update_state(server->plugin, plugin_handle_button, event, + modifiers); + + /* Notify the client with pointer focus that a button press has occurred */ + // wlr_seat_pointer_notify_button(server->seat, event->time_msec, + // event->button, + // event->state); + // double sx, sy; + // struct wlr_surface *surface = NULL; + // struct montis_toplevel *toplevel = desktop_toplevel_at( + // server, server->cursor->x, server->cursor->y, &surface, &sx, &sy); + // if (event->state == WLR_BUTTON_RELEASED) { + // /* If you released any buttons, we exit interactive move/resize mode. */ + // reset_cursor_mode(server); + // } + // else { + // /* Focus that client if the button was _pressed_ */ + // focus_toplevel(toplevel, surface); + // } +} + +static void server_cursor_axis(struct wl_listener *listener, void *data) +{ + /* This event is forwarded by the cursor when a pointer emits an axis event, + * for example when you move the scroll wheel. */ + struct montis_server *server = wl_container_of(listener, server, cursor_axis); + struct wlr_pointer_axis_event *event = data; + /* Notify the client with pointer focus of the axis event. */ + wlr_seat_pointer_notify_axis( + server->seat, event->time_msec, event->orientation, event->delta, + event->delta_discrete, event->source, event->relative_direction); +} + +static void server_cursor_frame(struct wl_listener *listener, void *data) +{ + /* This event is forwarded by the cursor when a pointer emits an frame + * event. Frame events are sent after regular pointer events to group + * multiple events together. For instance, two axis events may happen at the + * same time, in which case a frame event won't be sent in between. */ + struct montis_server *server = + wl_container_of(listener, server, cursor_frame); + /* Notify the client with pointer focus of the frame event. */ + wlr_seat_pointer_notify_frame(server->seat); +} + +static void output_frame(struct wl_listener *listener, void *data) +{ + /* This function is called every time an output is ready to display a frame, + * generally at the output's refresh rate (e.g. 60Hz). */ + struct montis_output *output = wl_container_of(listener, output, frame); + struct wlr_scene *scene = output->server->scene; + + struct wlr_scene_output *scene_output = + wlr_scene_get_scene_output(scene, output->wlr_output); + + /* Render the scene if needed and commit the output */ + wlr_scene_output_commit(scene_output, NULL); + + struct timespec now; + clock_gettime(CLOCK_MONOTONIC, &now); + wlr_scene_output_send_frame_done(scene_output, &now); +} + +static void output_request_state(struct wl_listener *listener, void *data) +{ + /* This function is called when the backend requests a new state for + * the output. For example, Wayland and X11 backends request a new mode + * when the output window is resized. */ + struct montis_output *output = + wl_container_of(listener, output, request_state); + const struct wlr_output_event_request_state *event = data; + wlr_output_commit_state(output->wlr_output, event->state); +} + +static void output_destroy(struct wl_listener *listener, void *data) +{ + struct montis_output *output = wl_container_of(listener, output, destroy); + + wl_list_remove(&output->frame.link); + wl_list_remove(&output->request_state.link); + wl_list_remove(&output->destroy.link); + wl_list_remove(&output->link); + free(output); +} + +static void server_new_output(struct wl_listener *listener, void *data) +{ + /* This event is raised by the backend when a new output (aka a display or + * monitor) becomes available. */ + struct montis_server *server = wl_container_of(listener, server, new_output); + struct wlr_output *wlr_output = data; + + /* Configures the output created by the backend to use our allocator + * and our renderer. Must be done once, before commiting the output */ + wlr_output_init_render(wlr_output, server->allocator, server->renderer); + + /* The output may be disabled, switch it on. */ + struct wlr_output_state state; + wlr_output_state_init(&state); + wlr_output_state_set_enabled(&state, true); + + /* Some backends don't have modes. DRM+KMS does, and we need to set a mode + * before we can use the output. The mode is a tuple of (width, height, + * refresh rate), and each monitor supports only a specific set of modes. We + * just pick the monitor's preferred mode, a more sophisticated compositor + * would let the user configure it. */ + struct wlr_output_mode *mode = wlr_output_preferred_mode(wlr_output); + if (mode != NULL) { + wlr_output_state_set_mode(&state, mode); + } + + /* Atomically applies the new output state. */ + wlr_output_commit_state(wlr_output, &state); + wlr_output_state_finish(&state); + + /* Allocates and configures our state for this output */ + struct montis_output *output = calloc(1, sizeof(*output)); + output->wlr_output = wlr_output; + output->server = server; + + /* Sets up a listener for the frame event. */ + output->frame.notify = output_frame; + wl_signal_add(&wlr_output->events.frame, &output->frame); + + /* Sets up a listener for the state request event. */ + output->request_state.notify = output_request_state; + wl_signal_add(&wlr_output->events.request_state, &output->request_state); + + /* Sets up a listener for the destroy event. */ + output->destroy.notify = output_destroy; + wl_signal_add(&wlr_output->events.destroy, &output->destroy); + + wl_list_insert(&server->outputs, &output->link); + + /* Adds this to the output layout. The add_auto function arranges outputs + * from left-to-right in the order they appear. A more sophisticated + * compositor would let the user configure the arrangement of outputs in the + * layout. + * + * The output layout utility automatically adds a wl_output global to the + * display, which Wayland clients can see to find out information about the + * output (such as DPI, scale factor, manufacturer, etc). + */ + struct wlr_output_layout_output *l_output = + wlr_output_layout_add_auto(server->output_layout, wlr_output); + struct wlr_scene_output *scene_output = + wlr_scene_output_create(server->scene, wlr_output); + wlr_scene_output_layout_add_output(server->scene_layout, l_output, + scene_output); +} + +static void xdg_toplevel_map(struct wl_listener *listener, void *data) +{ + /* Called when the surface is mapped, or ready to display on-screen. */ + struct montis_toplevel *toplevel = wl_container_of(listener, toplevel, map); + + wl_list_insert(&toplevel->server->toplevels, &toplevel->link); + + fprintf(stderr, "Surface map ...\n"); + plugin_call_update_state(toplevel->server->plugin, plugin_handle_surface, + toplevel, SURFACE_MAP); + fprintf(stderr, "/ Surface map ...\n"); + + focus_toplevel(toplevel, toplevel->xdg_toplevel->base->surface); +} + +static void xdg_toplevel_unmap(struct wl_listener *listener, void *data) +{ + /* Called when the surface is unmapped, and should no longer be shown. */ + struct montis_toplevel *toplevel = wl_container_of(listener, toplevel, unmap); + + /* Reset the cursor mode if the grabbed toplevel was unmapped. */ + if (toplevel == toplevel->server->grabbed_toplevel) { + reset_cursor_mode(toplevel->server); + } + + fprintf(stderr, "Surface unmap ...\n"); + plugin_call_update_state(toplevel->server->plugin, plugin_handle_surface, + toplevel, SURFACE_UNMAP); + fprintf(stderr, "/ Surface map ...\n"); + + wl_list_remove(&toplevel->link); +} + +static void xdg_toplevel_destroy(struct wl_listener *listener, void *data) +{ + /* Called when the xdg_toplevel is destroyed. */ + struct montis_toplevel *toplevel = + wl_container_of(listener, toplevel, destroy); + + wl_list_remove(&toplevel->map.link); + wl_list_remove(&toplevel->unmap.link); + wl_list_remove(&toplevel->destroy.link); + wl_list_remove(&toplevel->request_move.link); + wl_list_remove(&toplevel->request_resize.link); + wl_list_remove(&toplevel->request_maximize.link); + wl_list_remove(&toplevel->request_fullscreen.link); + + fprintf(stderr, "Surface destroy ...\n"); + plugin_call_update_state(toplevel->server->plugin, plugin_handle_surface, + toplevel, SURFACE_DELETE); + fprintf(stderr, "/ Surface destroy ...\n"); + + free(toplevel); +} + +static void begin_interactive(struct montis_toplevel *toplevel, + enum montis_cursor_mode mode, uint32_t edges) +{ + /* This function sets up an interactive move or resize operation, where the + * compositor stops propegating pointer events to clients and instead + * consumes them itself, to move or resize windows. */ + struct montis_server *server = toplevel->server; + struct wlr_surface *focused_surface = + server->seat->pointer_state.focused_surface; + if (toplevel->xdg_toplevel->base->surface != + wlr_surface_get_root_surface(focused_surface)) { + /* Deny move/resize requests from unfocused clients. */ + return; + } + server->grabbed_toplevel = toplevel; + server->cursor_mode = mode; + + if (mode == TINYWL_CURSOR_MOVE) { + server->grab_x = server->cursor->x - toplevel->scene_tree->node.x; + server->grab_y = server->cursor->y - toplevel->scene_tree->node.y; + } + else { + struct wlr_box geo_box; + wlr_xdg_surface_get_geometry(toplevel->xdg_toplevel->base, &geo_box); + + double border_x = (toplevel->scene_tree->node.x + geo_box.x) + + ((edges & WLR_EDGE_RIGHT) ? geo_box.width : 0); + double border_y = (toplevel->scene_tree->node.y + geo_box.y) + + ((edges & WLR_EDGE_BOTTOM) ? geo_box.height : 0); + server->grab_x = server->cursor->x - border_x; + server->grab_y = server->cursor->y - border_y; + + server->grab_geobox = geo_box; + server->grab_geobox.x += toplevel->scene_tree->node.x; + server->grab_geobox.y += toplevel->scene_tree->node.y; + + server->resize_edges = edges; + } +} + +static void xdg_toplevel_request_move(struct wl_listener *listener, void *data) +{ + /* This event is raised when a client would like to begin an interactive + * move, typically because the user clicked on their client-side + * decorations. Note that a more sophisticated compositor should check the + * provided serial against a list of button press serials sent to this + * client, to prevent the client from requesting this whenever they want. */ + struct montis_toplevel *toplevel = + wl_container_of(listener, toplevel, request_move); + begin_interactive(toplevel, TINYWL_CURSOR_MOVE, 0); +} + +static void xdg_toplevel_request_resize(struct wl_listener *listener, + void *data) +{ + /* This event is raised when a client would like to begin an interactive + * resize, typically because the user clicked on their client-side + * decorations. Note that a more sophisticated compositor should check the + * provided serial against a list of button press serials sent to this + * client, to prevent the client from requesting this whenever they want. */ + struct wlr_xdg_toplevel_resize_event *event = data; + struct montis_toplevel *toplevel = + wl_container_of(listener, toplevel, request_resize); + begin_interactive(toplevel, TINYWL_CURSOR_RESIZE, event->edges); +} + +static void xdg_toplevel_request_maximize(struct wl_listener *listener, + void *data) +{ + /* This event is raised when a client would like to maximize itself, + * typically because the user clicked on the maximize button on + * client-side decorations. montis doesn't support maximization, but + * to conform to xdg-shell protocol we still must send a configure. + * wlr_xdg_surface_schedule_configure() is used to send an empty reply. */ + struct montis_toplevel *toplevel = + wl_container_of(listener, toplevel, request_maximize); + wlr_xdg_surface_schedule_configure(toplevel->xdg_toplevel->base); +} + +static void xdg_toplevel_request_fullscreen(struct wl_listener *listener, + void *data) +{ + /* Just as with request_maximize, we must send a configure here. */ + struct montis_toplevel *toplevel = + wl_container_of(listener, toplevel, request_fullscreen); + wlr_xdg_surface_schedule_configure(toplevel->xdg_toplevel->base); +} + +static void xdg_popup_commit(struct wl_listener *listener, void *data) { + /* Called when a new surface state is committed. */ + struct montis_popup *popup = wl_container_of(listener, popup, commit); + + if (popup->xdg_popup->base->initial_commit) { + /* When an xdg_surface performs an initial commit, the compositor must + * reply with a configure so the client can map the surface. + * montis sends an empty configure. A more sophisticated compositor + * might change an xdg_popup's geometry to ensure it's not positioned + * off-screen, for example. */ + wlr_xdg_surface_schedule_configure(popup->xdg_popup->base); + } +} + +static void xdg_popup_destroy(struct wl_listener *listener, void *data) { + /* Called when the xdg_popup is destroyed. */ + struct montis_popup *popup = wl_container_of(listener, popup, destroy); + + wl_list_remove(&popup->commit.link); + wl_list_remove(&popup->destroy.link); + + free(popup); +} + +static void server_new_xdg_popup(struct wl_listener *listener, void *data) { + /* This event is raised when a client creates a new popup. */ + struct wlr_xdg_popup *xdg_popup = data; + + struct montis_popup *popup = calloc(1, sizeof(*popup)); + popup->xdg_popup = xdg_popup; + + /* We must add xdg popups to the scene graph so they get rendered. The + * wlroots scene graph provides a helper for this, but to use it we must + * provide the proper parent scene node of the xdg popup. To enable this, + * we always set the user data field of xdg_surfaces to the corresponding + * scene node. */ + struct wlr_xdg_surface *parent = wlr_xdg_surface_try_from_wlr_surface(xdg_popup->parent); + assert(parent != NULL); + struct wlr_scene_tree *parent_tree = parent->data; + xdg_popup->base->data = wlr_scene_xdg_surface_create(parent_tree, xdg_popup->base); + + popup->commit.notify = xdg_popup_commit; + wl_signal_add(&xdg_popup->base->surface->events.commit, &popup->commit); + + popup->destroy.notify = xdg_popup_destroy; + wl_signal_add(&xdg_popup->events.destroy, &popup->destroy); +} + +static void xdg_toplevel_commit(struct wl_listener *listener, void *data) { + /* Called when a new surface state is committed. */ + struct montis_toplevel *toplevel = wl_container_of(listener, toplevel, commit); + + if (toplevel->xdg_toplevel->base->initial_commit) { + /* When an xdg_surface performs an initial commit, the compositor must + * reply with a configure so the client can map the surface. montis + * configures the xdg_toplevel with 0,0 size to let the client pick the + * dimensions itself. */ + wlr_xdg_toplevel_set_size(toplevel->xdg_toplevel, 0, 0); + } +} + +static void server_new_xdg_toplevel(struct wl_listener *listener, void *data) +{ + /* This event is raised when a client creates a new toplevel (application window). */ + struct montis_server *server = wl_container_of(listener, server, new_xdg_toplevel); + struct wlr_xdg_toplevel *xdg_toplevel = data; + + /* Allocate a montis_toplevel for this surface */ + struct montis_toplevel *toplevel = calloc(1, sizeof(*toplevel)); + toplevel->server = server; + toplevel->xdg_toplevel = xdg_toplevel; + toplevel->scene_tree = + wlr_scene_xdg_surface_create(&toplevel->server->scene->tree, xdg_toplevel->base); + toplevel->scene_tree->node.data = toplevel; + xdg_toplevel->base->data = toplevel->scene_tree; + + /* Listen to the various events it can emit */ + toplevel->map.notify = xdg_toplevel_map; + wl_signal_add(&xdg_toplevel->base->surface->events.map, &toplevel->map); + toplevel->unmap.notify = xdg_toplevel_unmap; + wl_signal_add(&xdg_toplevel->base->surface->events.unmap, &toplevel->unmap); + toplevel->commit.notify = xdg_toplevel_commit; + wl_signal_add(&xdg_toplevel->base->surface->events.commit, &toplevel->commit); + + toplevel->destroy.notify = xdg_toplevel_destroy; + wl_signal_add(&xdg_toplevel->events.destroy, &toplevel->destroy); + + /* cotd */ + toplevel->request_move.notify = xdg_toplevel_request_move; + wl_signal_add(&xdg_toplevel->events.request_move, &toplevel->request_move); + toplevel->request_resize.notify = xdg_toplevel_request_resize; + wl_signal_add(&xdg_toplevel->events.request_resize, &toplevel->request_resize); + toplevel->request_maximize.notify = xdg_toplevel_request_maximize; + wl_signal_add(&xdg_toplevel->events.request_maximize, &toplevel->request_maximize); + toplevel->request_fullscreen.notify = xdg_toplevel_request_fullscreen; + wl_signal_add(&xdg_toplevel->events.request_fullscreen, &toplevel->request_fullscreen); +} + +int main(int argc, char *argv[]) +{ + wlr_log_init(WLR_DEBUG, NULL); + char *startup_cmd = NULL; + char *plugin = NULL; + + int c; + while ((c = getopt(argc, argv, "s:p:h")) != -1) { + switch (c) { + case 's': + startup_cmd = optarg; + break; + case 'p': + plugin = optarg; + break; + default: + printf("Usage: %s -p [plugin] [-s startup command]\n", argv[0]); + return 0; + } + } + if (optind < argc || !plugin) { + printf("Usage: %s -p [plugin] [-s startup command]\n", argv[0]); + return 0; + } + + struct montis_server server = {0}; + + if (load_plugin_from_file(argc, argv, plugin, &server.plugin)) { + fprintf(stderr, "Failed to read plugin from file.\n"); + return 1; + } + + plugin_cold_start(&server.plugin); + + /* The Wayland display is managed by libwayland. It handles accepting + * clients from the Unix socket, manging Wayland globals, and so on. */ + server.wl_display = wl_display_create(); + /* The backend is a wlroots feature which abstracts the underlying input and + * output hardware. The autocreate option will choose the most suitable + * backend based on the current environment, such as opening an X11 window + * if an X11 server is running. */ + server.backend = wlr_backend_autocreate( + wl_display_get_event_loop(server.wl_display), &server.session); + if (server.backend == NULL) { + wlr_log(WLR_ERROR, "failed to create wlr_backend"); + return 1; + } + + /* Autocreates a renderer, either Pixman, GLES2 or Vulkan for us. The user + * can also specify a renderer using the WLR_RENDERER env var. + * The renderer is responsible for defining the various pixel formats it + * supports for shared memory, this configures that for clients. */ + server.renderer = wlr_renderer_autocreate(server.backend); + if (server.renderer == NULL) { + wlr_log(WLR_ERROR, "failed to create wlr_renderer"); + return 1; + } + + wlr_renderer_init_wl_display(server.renderer, server.wl_display); + + /* Autocreates an allocator for us. + * The allocator is the bridge between the renderer and the backend. It + * handles the buffer creation, allowing wlroots to render onto the + * screen */ + server.allocator = wlr_allocator_autocreate(server.backend, server.renderer); + if (server.allocator == NULL) { + wlr_log(WLR_ERROR, "failed to create wlr_allocator"); + return 1; + } + + /* This creates some hands-off wlroots interfaces. The compositor is + * necessary for clients to allocate surfaces, the subcompositor allows to + * assign the role of subsurfaces to surfaces and the data device manager + * handles the clipboard. Each of these wlroots interfaces has room for you + * to dig your fingers in and play with their behavior if you want. Note that + * the clients cannot set the selection directly without compositor approval, + * see the handling of the request_set_selection event below.*/ + wlr_compositor_create(server.wl_display, 5, server.renderer); + wlr_subcompositor_create(server.wl_display); + wlr_data_device_manager_create(server.wl_display); + + /* Creates an output layout, which a wlroots utility for working with an + * arrangement of screens in a physical layout. */ + server.output_layout = wlr_output_layout_create(server.wl_display); + + /* Configure a listener to be notified when new outputs are available on the + * backend. */ + wl_list_init(&server.outputs); + server.new_output.notify = server_new_output; + wl_signal_add(&server.backend->events.new_output, &server.new_output); + + /* Create a scene graph. This is a wlroots abstraction that handles all + * rendering and damage tracking. All the compositor author needs to do + * is add things that should be rendered to the scene graph at the proper + * positions and then call wlr_scene_output_commit() to render a frame if + * necessary. + */ + server.scene = wlr_scene_create(); + server.scene_layout = + wlr_scene_attach_output_layout(server.scene, server.output_layout); + + /* Set up xdg-shell version 3. The xdg-shell is a Wayland protocol which is + * used for application windows. For more detail on shells, refer to + * https://drewdevault.com/2018/07/29/Wayland-shells.html. + */ + wl_list_init(&server.toplevels); + server.xdg_shell = wlr_xdg_shell_create(server.wl_display, 3); + server.new_xdg_toplevel.notify = server_new_xdg_toplevel; + wl_signal_add(&server.xdg_shell->events.new_toplevel, + &server.new_xdg_toplevel); + server.new_xdg_popup.notify = server_new_xdg_popup; + wl_signal_add(&server.xdg_shell->events.new_popup, &server.new_xdg_popup); + + /* + * Creates a cursor, which is a wlroots utility for tracking the cursor + * image shown on screen. + */ + server.cursor = wlr_cursor_create(); + wlr_cursor_attach_output_layout(server.cursor, server.output_layout); + + /* Creates an xcursor manager, another wlroots utility which loads up + * Xcursor themes to source cursor images from and makes sure that cursor + * images are available at all scale factors on the screen (necessary for + * HiDPI support). */ + server.cursor_mgr = wlr_xcursor_manager_create(NULL, 24); + + /* + * wlr_cursor *only* displays an image on screen. It does not move around + * when the pointer moves. However, we can attach input devices to it, and + * it will generate aggregate events for all of them. In these events, we + * can choose how we want to process them, forwarding them to clients and + * moving the cursor around. More detail on this process is described in + * https://drewdevault.com/2018/07/17/Input-handling-in-wlroots.html. + * + * And more comments are sprinkled throughout the notify functions above. + */ + server.cursor_mode = TINYWL_CURSOR_PASSTHROUGH; + server.cursor_motion.notify = server_cursor_motion; + wl_signal_add(&server.cursor->events.motion, &server.cursor_motion); + server.cursor_motion_absolute.notify = server_cursor_motion_absolute; + wl_signal_add(&server.cursor->events.motion_absolute, + &server.cursor_motion_absolute); + server.cursor_button.notify = server_cursor_button; + wl_signal_add(&server.cursor->events.button, &server.cursor_button); + server.cursor_axis.notify = server_cursor_axis; + wl_signal_add(&server.cursor->events.axis, &server.cursor_axis); + server.cursor_frame.notify = server_cursor_frame; + wl_signal_add(&server.cursor->events.frame, &server.cursor_frame); + + /* + * Configures a seat, which is a single "seat" at which a user sits and + * operates the computer. This conceptually includes up to one keyboard, + * pointer, touch, and drawing tablet device. We also rig up a listener to + * let us know when new input devices are available on the backend. + */ + wl_list_init(&server.keyboards); + server.new_input.notify = server_new_input; + wl_signal_add(&server.backend->events.new_input, &server.new_input); + server.seat = wlr_seat_create(server.wl_display, "seat0"); + server.request_cursor.notify = seat_request_cursor; + wl_signal_add(&server.seat->events.request_set_cursor, + &server.request_cursor); + server.request_set_selection.notify = seat_request_set_selection; + wl_signal_add(&server.seat->events.request_set_selection, + &server.request_set_selection); + + /* Add a Unix socket to the Wayland display. */ + const char *socket = wl_display_add_socket_auto(server.wl_display); + if (!socket) { + wlr_backend_destroy(server.backend); + return 1; + } + + /* Start the backend. This will enumerate outputs and inputs, become the DRM + * master, etc */ + if (!wlr_backend_start(server.backend)) { + wlr_backend_destroy(server.backend); + wl_display_destroy(server.wl_display); + return 1; + } + + /* Set the WAYLAND_DISPLAY environment variable to our socket and run the + * startup command if requested. */ + setenv("WAYLAND_DISPLAY", socket, true); + if (startup_cmd) { + if (fork() == 0) { + execl("/bin/sh", "/bin/sh", "-c", startup_cmd, (void *)NULL); + } + } + /* Run the Wayland event loop. This does not return until you exit the + * compositor. Starting the backend rigged up all of the necessary event + * loop configuration to listen to libinput events, DRM events, generate + * frame events at the refresh rate, and so on. */ + wlr_log(WLR_INFO, "Running Wayland compositor on WAYLAND_DISPLAY=%s", socket); + wl_display_run(server.wl_display); + + /* Once wl_display_run returns, we destroy all clients then shut down the + * server. */ + wl_display_destroy_clients(server.wl_display); + wlr_scene_node_destroy(&server.scene->tree.node); + wlr_xcursor_manager_destroy(server.cursor_mgr); + wlr_output_layout_destroy(server.output_layout); + wl_display_destroy(server.wl_display); + return 0; +} diff --git a/rt/tools/genbuild.pl b/rt/tools/genbuild.pl new file mode 100644 index 0000000..1acabc0 --- /dev/null +++ b/rt/tools/genbuild.pl @@ -0,0 +1,48 @@ +#!/usr/bin/env perl + +$comment=""; + +print "#include \n"; +print "#include \n"; +print "#include \n"; +print "#include \n"; +print "#include \"plugin.h\"\n\n"; + +print "int load_plugin_from_dl_(dlhandle_t dl, plugin_t* plug)\n"; +print "{\n"; +print " void* ptr;\n"; +print " int ret = 0;\n"; +print "\n"; +print " const char** name = dlsym(dl, \"plugin_name\");\n"; +print " memset(plug, 0, sizeof(*plug));\n"; +print " if (name) {\n"; +print " plug->plugin_name = *name;\n"; +print " } else {\n"; +print " plug->plugin_name = NULL;\n"; +print " }\n"; +print " plug->state = NULL;\n"; +print " plug->library_handle = dl;\n"; +print "\n"; +while (<>) { + if (/^\s*EXPORT/) { + my $line = "$_"; + while (not ($line =~ /;$/)) { + my $nextline = ; + last unless defined $nextline; + + $line="$line$nextline"; + } + if ($line =~ /^\s*EXPORT\(\s*((?:\w|\s*\*\s*)+)\s*\(\*(\w+)\)\s*\((.*)\)\);/s) { + print "\n"; + print " ptr = dlsym(dl, \"$2\");\n"; + print " if (!ptr) {\n"; + print " fprintf(stderr, \"Plugin missing %s\\n\", \"$2\");\n"; + print " ret |= 1;\n"; + print " }\n"; + print " plug->$2 = ptr;\n"; + $comment=""; + } + } +} +print "\n return ret;\n"; +print "}\n"; diff --git a/rt/tools/genintf.pl b/rt/tools/genintf.pl new file mode 100644 index 0000000..794f966 --- /dev/null +++ b/rt/tools/genintf.pl @@ -0,0 +1,42 @@ +#!/usr/bin/env perl + +$comment=""; + +print "#ifndef _PLUG_INTF\n"; +print "#define _PLUG_INTF\n"; +print "\n#include \n"; +print "\n#include \n"; + +while () { + if (/^\s*\/\*/) { + $_ =~ s/^\s*//; + $comment="$_"; + next; + } + + if (/^\s*\*/) { + $_ =~ s/^\s*/ /; + $comment="$comment$_"; + next; + } + + if (/^\s*EXPORT_INCLUDE\((.*)\)/) { + print "#include $1\n"; + } elsif (/^\s*EXPORT/) { + my $line = "$_"; + while (not ($line =~ /;$/)) { + my $nextline = ; + last unless defined $nextline; + + $line="$line$nextline"; + } + if ($line =~ /^\s*EXPORT\(\s*((?:\w|\s*\*\s*)+)\s*\(\*(\w+)\)\s*\((.*)\)\);/s) { + print "$comment"; + print "$1 $2($3);\n\n"; + $comment=""; + } elsif ($line =~ /^\s*EXPORT\((.*)\);/s) { + print "$1\n"; + } + } +} +print "#endif /* _PLUG_INTF */\n"; diff --git a/src/Config.hs b/src/Config.hs deleted file mode 100644 index e76e6ea..0000000 --- a/src/Config.hs +++ /dev/null @@ -1,88 +0,0 @@ -module Config (config) where - -import Control.Monad (unless) -import Data.Bits -import Data.Data (Proxy (Proxy)) -import Wetterhorn.Core.ButtonEvent as ButtonEvent -import Wetterhorn.Core.KeyEvent as KeyEvent -import Wetterhorn.Core.W -import Wetterhorn.Dsl.Bind -import Wetterhorn.Dsl.Input -import Wetterhorn.Keys.Macros -import Wetterhorn.Keys.MagicModifierKey -import Wetterhorn.Layout.Full - -config :: Config WindowLayout -config = - defaultConfig - { hooks = - defaultHooks - { surfaceHook = do - handleSurface - }, - layout = WindowLayout Full, - resetHook = do - useInputHandler $ - withProxies inputProxies $ do - ev <- nextInputEvent - - bind ev (released btnLeft) $ - run $ - wio $ - putStrLn "Left Button Released!!" - - unless (isPressEvent ev) $ do - forwardEvent ev - continue - - bind ev (Shift .+ Mod1 .+ 'R') $ run requestHotReload - - bind ev (Mod1 .+ 't') $ run (shellExec "alacritty") - - bind ev (Mod1 .+ 'p') $ do - ev2 <- nextInputPressEvent - - bind ev2 (Mod1 .+ 'p') $ - run $ - wio $ - putStrLn "Test" - - bind ev (Mod1 .+ btnLeft) $ - run $ - wio $ - putStrLn "Left Button Press!!" - - bind ev (Mod1 .+ 'q') macroStartStopKeybind - - bind ev (weak $ Mod1 .+ '@') macroReplayKeybind - - bind ev (weak $ ModX 5 .+ btnLeft) $ - run $ - wio $ - putStrLn "Fake Modifier With Button!!!" - - bind ev (weak $ ModX 5 .+ 't') $ - run $ - wio $ - putStrLn "Fake Modifier!!" - - forwardEvent ev - } - where - inputProxies :: - Proxy - '[ MacroSupport, - MagicModifierProxy 59 SetXtra -- Only log keys when F1 (keycode 59 is pressed) - ] - inputProxies = Proxy - -data SetXtra - -instance InputProxy SetXtra where - onKeyEvent _ ie = - case ie of - (InputKeyEvent ke@(KeyEvent {KeyEvent.modifiers = modifiers})) -> - return $ InputKeyEvent ke {KeyEvent.modifiers = modifiers .|. modifierToMask (ModX 5)} - (InputButtonEvent be@(ButtonEvent {ButtonEvent.modifiers = modifiers})) -> - return $ InputButtonEvent be {ButtonEvent.modifiers = modifiers .|. modifierToMask (ModX 5)} - _ -> return ie diff --git a/src/Lib.hs b/src/Lib.hs deleted file mode 100644 index d36ff27..0000000 --- a/src/Lib.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Lib - ( someFunc - ) where - -someFunc :: IO () -someFunc = putStrLn "someFunc" diff --git a/src/Wetterhorn/Constraints.hs b/src/Wetterhorn/Constraints.hs deleted file mode 100644 index 129fd6c..0000000 --- a/src/Wetterhorn/Constraints.hs +++ /dev/null @@ -1,13 +0,0 @@ --- | Contains useful constraints and constraint combinators for type-level --- metaprogramming. -module Wetterhorn.Constraints where - --- | A null constraint. All types implement this. -class Unconstrained a - -instance Unconstrained a - --- | Combines multiple constraints by 'And'ing them together. -class (c1 a, c2 a) => (&&&&) c1 c2 a - -instance (c1 a, c2 a) => (&&&&) c1 c2 a diff --git a/src/Wetterhorn/Core.hs b/src/Wetterhorn/Core.hs deleted file mode 100644 index d853191..0000000 --- a/src/Wetterhorn/Core.hs +++ /dev/null @@ -1,152 +0,0 @@ -{-# HLINT ignore "Use camelCase" #-} - -module Wetterhorn.Core --- ( WState (..), --- WConfig (..), --- SurfaceState (..), --- W, --- getWConfig, --- getWState, --- runW, --- Wetterhorn, --- initWetterhorn, --- wio, --- incrementState, --- readWState, --- defaultConfig, --- requestHotReload, --- ctxConfig, --- KeyEvent (..), --- KeyState (..), --- ) -where - --- import Control.Arrow (first) --- import Control.Exception --- import Data.ByteString (ByteString) --- import Data.Char (ord) --- import Data.Map (Map) --- import Foreign (Ptr, StablePtr, Word32, newStablePtr) --- import Text.Printf --- import Wetterhorn.Foreign.ForeignInterface (ForeignInterface) --- import Wetterhorn.Foreign.WlRoots --- import qualified Data.ByteString.Char8 as CH --- import qualified Data.Map as Map --- import qualified Wetterhorn.Foreign.ForeignInterface as ForeignInterface --- --- data WContext = WContext --- { ctxForeignInterface :: ForeignInterface, --- ctxConfig :: WConfig --- } --- --- -- This is the OpaqueState passed to the harness. --- type Wetterhorn = StablePtr (WContext, WState) --- --- requestHotReload :: W () --- requestHotReload = do --- fi <- ctxForeignInterface <$> getWContext --- wio $ ForeignInterface.requestHotReload fi --- --- requestLog :: String -> W () --- requestLog str = do --- fi <- ctxForeignInterface <$> getWContext --- wio $ ForeignInterface.requestLog fi str --- --- requestExit :: Int -> W () --- requestExit ec = do --- fi <- ctxForeignInterface <$> getWContext --- wio $ ForeignInterface.requestExit fi ec --- --- initWetterhorn :: WConfig -> IO Wetterhorn --- initWetterhorn conf = do --- foreignInterface <- ForeignInterface.getForeignInterface --- newStablePtr (WContext foreignInterface conf, WState "this is a string" 0) --- --- defaultBindings :: Map (KeyState, Word32, Word32) (W ()) --- defaultBindings = --- Map.fromList --- [ ((KeyPressed, 0x9, sym 'Q'), requestHotReload), --- ((KeyPressed, 0x8, sym 'r'), wio $ ForeignInterface.doShellExec "wofi --show run"), --- ((KeyPressed, 0x8, sym 'l'), requestLog "This is a log statement!\n"), --- ((KeyPressed, 0x8, sym 't'), wio $ ForeignInterface.doShellExec "alacritty"), --- ((KeyPressed, 0x9, sym 'T'), wio $ ForeignInterface.doShellExec "gnome-terminal"), --- ((KeyPressed, 0x8, sym 'c'), wio $ ForeignInterface.doShellExec "pavucontrol"), --- ( (KeyPressed, 0x8, sym 'p'), --- wio $ do --- putStrLn "Maps:" --- putStrLn =<< readFile "/proc/self/maps" --- ), --- ((KeyPressed, 0x8, sym 'q'), requestExit 0) --- ] --- where --- sym = fromIntegral . ord --- --- defaultConfig :: WConfig --- defaultConfig = --- WConfig --- { keybindingHandler = \keyEvent -> do --- seatPtr <- (wio . ForeignInterface.getSeat . ctxForeignInterface) =<< getWContext --- --- maybe --- ( wio $ do --- wlrSeatSetKeyboard seatPtr (device keyEvent) --- wlrSeatKeyboardNotifyKey --- seatPtr --- (timeMs keyEvent) --- (keycode keyEvent) --- ( case state keyEvent of --- KeyReleased -> 0 --- _ -> 1 --- ) --- --- return True --- ) --- (fmap (const True)) --- $ Map.lookup --- (state keyEvent, modifiers keyEvent, keysym keyEvent) --- defaultBindings, --- surfaceHandler = \state surface -> wio (printf "Surface %s is %s\n" (show surface) (show state)) --- } --- --- readWState :: ByteString -> IO WState --- readWState bs = --- catch --- (return $ read (CH.unpack bs)) --- ( \e -> --- let _ = (e :: SomeException) in return (WState "" 0) --- ) --- --- newtype W a = W ((WContext, WState) -> IO (a, WState)) --- --- instance Functor W where --- fmap mfn (W fn) = W $ fmap (first mfn) <$> fn --- --- instance Applicative W where --- pure a = W $ \(_, s) -> return (a, s) --- mfn <*> ma = do --- fn <- mfn --- fn <$> ma --- --- instance Monad W where --- (W fntoa) >>= fnmb = W $ \(config, state) -> do --- (a, state') <- fntoa (config, state) --- let W fntob = fnmb a --- fntob (config, state') --- --- getWContext :: W WContext --- getWContext = W pure --- --- getWConfig :: W WConfig --- getWConfig = ctxConfig <$> getWContext --- --- getWState :: W WState --- getWState = W $ \(_, s) -> pure (s, s) --- --- runW :: W a -> (WContext, WState) -> IO (a, WState) --- runW (W fn) = fn --- --- incrementState :: W Int --- incrementState = W $ \(_, WState s i) -> return (i, WState s (i + 1)) --- --- wio :: IO a -> W a --- wio fn = W $ \(_, b) -> fn >>= \a -> return (a, b) diff --git a/src/Wetterhorn/Core/ButtonEvent.hs b/src/Wetterhorn/Core/ButtonEvent.hs deleted file mode 100644 index cc3d905..0000000 --- a/src/Wetterhorn/Core/ButtonEvent.hs +++ /dev/null @@ -1,15 +0,0 @@ -module Wetterhorn.Core.ButtonEvent where - -import Wetterhorn.Foreign.WlRoots -import Data.Word (Word32) -import Foreign (Ptr) - -data ButtonState = ButtonReleased | ButtonPressed deriving (Show, Read, Eq, Enum, Ord) - -data ButtonEvent = ButtonEvent { - pointer :: Ptr WlrPointer, - timeMs :: Word32, - button :: Word32, - modifiers :: Word32, - state :: ButtonState -} deriving (Eq, Show, Ord) diff --git a/src/Wetterhorn/Core/KeyEvent.hs b/src/Wetterhorn/Core/KeyEvent.hs deleted file mode 100644 index 77d273f..0000000 --- a/src/Wetterhorn/Core/KeyEvent.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Wetterhorn.Core.KeyEvent - ( KeyEvent (..), - KeyState (..), - ) -where - -import Data.Word (Word32) -import Foreign (Ptr) -import Wetterhorn.Foreign.WlRoots - -data KeyState = KeyPressed | KeyReleased deriving (Show, Read, Eq, Enum, Ord) - -data KeyEvent = KeyEvent - { timeMs :: Word32, - keycode :: Word32, - state :: KeyState, - modifiers :: Word32, - keysym :: Word32, - codepoint :: Char, - device :: Ptr WlrInputDevice - } - deriving (Show, Ord, Eq) diff --git a/src/Wetterhorn/Core/Keys.hs b/src/Wetterhorn/Core/Keys.hs deleted file mode 100644 index 54d7125..0000000 --- a/src/Wetterhorn/Core/Keys.hs +++ /dev/null @@ -1,239 +0,0 @@ -module Wetterhorn.Core.Keys where - -import Control.Monad (forever, void, when) -import Control.Monad.Cont.Class -import Control.Monad.IO.Class -import Control.Monad.State (MonadState (get, put), MonadTrans (lift), StateT, evalStateT, gets, modify) -import Control.Monad.Trans.Cont -import Data.Bits -import Data.Word -import Wetterhorn.Core.ButtonEvent (ButtonEvent) -import Wetterhorn.Core.KeyEvent -import qualified Wetterhorn.Core.KeyEvent as KeyEvent -import qualified Wetterhorn.Core.ButtonEvent as ButtonEvent -import Wetterhorn.Core.W -import Wetterhorn.Foreign.WlRoots (wlrSeatKeyboardNotifyKey, wlrSeatSetKeyboard) - --- | Forwards the given key event to the focused window. -forwardKey :: KeyEvent -> W () -forwardKey keyEvent = do - seatPtr <- getSeat - wio $ do - wlrSeatSetKeyboard - seatPtr - (device keyEvent) - - wlrSeatKeyboardNotifyKey - seatPtr - (timeMs keyEvent) - (keycode keyEvent) - ( case state keyEvent of - KeyReleased -> 0 - _ -> 1 - ) - --- | Forwards the current key event to the focused window. -forwardEvent :: KeyEvent -> KeysM () -forwardEvent = liftW . forwardKey - --- | Enumeration of possible modifiers -data Modifier = Shift | Lock | Control | Mod1 | Mod2 | Mod3 | Mod4 | Mod5 - deriving (Eq, Ord, Show, Read, Enum, Bounded) - --- | Converts a modifier to its associated mask. -modifierToMask :: Modifier -> Word32 -modifierToMask m = - 1 - `shiftL` case m of - Shift -> 0 - Lock -> 1 - Control -> 2 - Mod1 -> 3 - Mod2 -> 4 - Mod3 -> 5 - Mod4 -> 6 - Mod5 -> 7 - -data KeysState = KeysState - { -- | Reference to the top. Used for a continue statement. - keysTop :: KeysM (), - handleContinuation :: KeyContinuation -> W () - } - --- | The Keys monad. This monad abstracts away control flow for handling key --- bindings. This makes it easy to make key-sequence bindings. --- newtype KeysM a = KeysM ((KeyEvent -> W ()) -> KeyEvent -> W (KeysMR a)) -newtype KeysM a = KeysM (ContT () (StateT KeysState W) a) - deriving (Monad, Functor, Applicative, MonadCont, MonadIO) - --- | KeysM can be lifted from a W action. -instance Wlike KeysM where - liftW = KeysM . lift . lift - -type KeyContinuation = KeyEvent -> W () - -useKeysWithContinuation :: (KeyContinuation -> W ()) -> KeysM () -> W () -useKeysWithContinuation continuation (forever -> km@(KeysM c)) = - evalStateT (evalContT c) (KeysState km continuation) - -useKeys :: KeysM () -> W () -useKeys = useKeysWithContinuation putKeyHandler - --- | Returns the next key event. -nextKeyEvent :: KeysM KeyEvent -nextKeyEvent = do - st <- KeysM $ lift get - KeysM $ - shiftT - ( \keyHandler -> - lift . lift $ - handleContinuation st (\kp -> evalStateT (keyHandler kp) st) - ) - --- | Discards the rest of the continuation and starts again from the top. Useful --- for keybinds where once the key is handled, there's nothing left to do. -continue :: KeysM () -continue = do - st <- KeysM $ lift get - let (KeysM topCont) = keysTop st - - -- This shift discards the rest of the computation and instead returns to the - -- top of the handler. - KeysM $ shiftT (\_ -> resetT topCont) - --- | Returns the "top" continuation. -getTop :: KeysM (KeysM ()) -getTop = KeysM (gets keysTop) - -putKeyHandler :: KeyContinuation -> W () -putKeyHandler handler = do - s@State {currentHooks = hooks} <- get - put - s - { currentHooks = - hooks - { keyHook = void <$> handler - } - } - -nextButtonEvent :: KeysM ButtonEvent -nextButtonEvent = do - st <- KeysM get - KeysM $ - shiftT $ \h -> - lift $ lift $ putButtonHandler (\ev -> evalStateT (h ev) st) - where - putButtonHandler h = do - modify $ \st -> st {currentHooks = (currentHooks st) {buttonHook = h}} - -nextButtonOrKeyEvent :: KeysM (Either ButtonEvent KeyEvent) -nextButtonOrKeyEvent = do - st <- KeysM get - KeysM $ - shiftT $ \rest -> - lift $ lift $ do - putButtonHandler (\ev -> evalStateT (rest (Left ev)) st) - handleContinuation st (\ev -> evalStateT (rest (Right ev)) st) - - where - putButtonHandler h = do - modify $ \st -> st {currentHooks = (currentHooks st) {buttonHook = h}} - -nextButtonOrKeyPress :: KeysM (Either ButtonEvent KeyEvent) -nextButtonOrKeyPress = do - ev <- nextButtonOrKeyEvent - case ev of - Left bev | ButtonEvent.state bev == ButtonEvent.ButtonPressed -> return ev - Left bev -> forwardButtonEvent bev >> nextButtonOrKeyPress - Right kev | KeyEvent.state kev == KeyEvent.KeyPressed -> return ev - Right kev -> forwardEvent kev >> nextButtonOrKeyPress - - where - forwardButtonEvent _ = return () - - --- | Returns the next KeyPressed event. This is likely what 90% of use cases --- want rather than nextKeyEvent. -nextKeyPress :: KeysM KeyEvent -nextKeyPress = do - k <- nextKeyEvent - if KeyEvent.state k /= KeyPressed - then forwardEvent k >> nextKeyPress - else return k - --- --- binding EDSL used to expressively create key bindings and subbindings inside --- a KeysM () context. --- - -data KeyMatcher = KeyMatcher Word32 Char - deriving (Show) - --- | Like a KeyMatcher, but allows additional modifiers to be pressed, not just --- the exact ones given. -newtype WeakKeyMatcher = WeakKeyMatcher KeyMatcher - --- | Converts a KeyMatcher to a weak key matcher. -weak :: KeyMatcher -> WeakKeyMatcher -weak = WeakKeyMatcher - -class KeyMatcherId r where - toKeyMatcher :: r -> KeyMatcher - -instance KeyMatcherId KeyMatcher where - toKeyMatcher = id - -instance KeyMatcherId Char where - toKeyMatcher = KeyMatcher 0 - -class KeyMatcherBuilder b where - (.+) :: (KeyMatcherId i) => b -> i -> KeyMatcher - -instance KeyMatcherBuilder Modifier where - (.+) m (toKeyMatcher -> (KeyMatcher mods ch)) = - KeyMatcher (mods .|. modifierToMask m) ch - -infixr 9 .+ - -class MatchKey m where - matchKey :: m -> KeyEvent -> Bool - -instance MatchKey (KeyEvent -> Bool) where - matchKey = ($) - -instance MatchKey Bool where - matchKey = const - -instance MatchKey Char where - matchKey ch ev = ch == KeyEvent.codepoint ev - -instance MatchKey KeyMatcher where - matchKey (KeyMatcher m ch) ev = - ch == KeyEvent.codepoint ev && m == KeyEvent.modifiers ev - -instance MatchKey WeakKeyMatcher where - matchKey (WeakKeyMatcher (KeyMatcher m ch)) ev = - ch == KeyEvent.codepoint ev && (m .|. ms) == ms - where - ms = KeyEvent.modifiers ev - -class IsKeysM m where - toKeysM :: m a -> KeysM a - -instance IsKeysM W where - toKeysM = liftW - -instance IsKeysM KeysM where - toKeysM = id - -bind :: (MatchKey m, IsKeysM k) => KeyEvent -> m -> k () -> KeysM () -bind ev m act = do - when (matchKey m ev) $ do - toKeysM act - continue - -ignoreReleaseEvents :: KeyEvent -> KeysM () -ignoreReleaseEvents ev = do - when (KeyEvent.state ev /= KeyEvent.KeyPressed) $ do - forwardEvent ev - continue diff --git a/src/Wetterhorn/Core/SurfaceEvent.hs b/src/Wetterhorn/Core/SurfaceEvent.hs deleted file mode 100644 index 3e7eaf3..0000000 --- a/src/Wetterhorn/Core/SurfaceEvent.hs +++ /dev/null @@ -1,16 +0,0 @@ -module Wetterhorn.Core.SurfaceEvent - ( SurfaceEvent (..), - SurfaceState (..), - ) -where - -import Wetterhorn.Foreign.WlRoots - -data SurfaceState = Map | Unmap | Destroy - deriving (Eq, Ord, Show, Read, Enum) - -data SurfaceEvent = SurfaceEvent - { state :: SurfaceState, - surface :: Surface - } - deriving (Eq, Ord, Show) diff --git a/src/Wetterhorn/Core/W.hs b/src/Wetterhorn/Core/W.hs deleted file mode 100644 index 862f9fa..0000000 --- a/src/Wetterhorn/Core/W.hs +++ /dev/null @@ -1,379 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} - -module Wetterhorn.Core.W where - -import Control.Arrow (Arrow (first)) -import Control.Monad ((<=<)) -import Control.Monad.RWS (MonadIO (liftIO), MonadReader (..), MonadState, modify) -import Control.Monad.Reader (ReaderT (runReaderT)) -import Control.Monad.State (StateT (runStateT), gets, modify') -import Control.Monad.Trans.Class -import Control.Monad.Trans.Maybe -import Data.Data (TypeRep, Typeable, cast, tyConModule, tyConName, tyConPackage) -import Data.Default.Class (Default, def) -import Data.Kind (Constraint, Type) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Maybe (fromMaybe, mapMaybe) -import Data.Proxy -import Data.Set (Set) -import qualified Data.Set as Set -import Foreign (Ptr, StablePtr, intPtrToPtr, ptrToIntPtr) -import Text.Printf (printf) -import Text.Read hiding (lift) -import Type.Reflection (someTypeRep, someTypeRepTyCon) -import Wetterhorn.Core.ButtonEvent (ButtonEvent) -import Wetterhorn.Core.KeyEvent -import Wetterhorn.Core.SurfaceEvent -import Wetterhorn.Foreign.ForeignInterface (ForeignInterface) -import qualified Wetterhorn.Foreign.ForeignInterface as ForeignInterface -import Wetterhorn.Foreign.WlRoots (Surface, WlrSeat) -import Wetterhorn.StackSet hiding (layout) -import qualified Wetterhorn.StackSet as StackSet - -data RationalRect = RationalRect Rational Rational Rational Rational - --- | Wrapper for a message. Messages are sent to layout and layouts are supposed --- to handle them. This hides a typeable parameter. -data Message where - Message :: (Typeable a) => a -> Message - --- | casts a message to a type. -fromMessage :: (Typeable a) => Message -> Maybe a -fromMessage (Message t) = cast t - --- | Wraps a type in a message. -toMessage :: (Typeable a) => a -> Message -toMessage = Message - -class (Typeable l) => HandleMessage l where - handleMessage :: Message -> l -> MaybeT W l - handleMessage _ = return - -newtype Window = Window - { surface :: Surface - } - deriving (Show, Ord, Eq, Read) - --- | Types of this class "lay out" windows by assigning rectangles and handle --- messages. -class (Typeable l, HandleMessage l) => LayoutClass l where - -- | Constraints on the type to lay out. Sometimes a layout requires the 'a' - -- type to be "Ord", other times "Eq", this is the mechanism by which this - -- constraint is expressed. - type LayoutConstraint l :: Type -> Constraint - - -- | Runs the layout in an impure way returning a modified layout and the list - -- of windows to their rectangles under a monad. - runLayout :: (LayoutConstraint l a) => Stack a -> l -> W (l, [(a, RationalRect)]) - - readLayout :: String -> Maybe l - default readLayout :: (Read l) => String -> Maybe l - readLayout = readMaybe - - serializeLayout :: l -> String - default serializeLayout :: (Show l) => l -> String - serializeLayout = show - - description :: l -> String - default description :: (Show l) => l -> String - description = show - {-# MINIMAL runLayout #-} - --- | Lifts a pure-layout implementation to a signature that complies with --- 'runLayout' -pureLayout :: - (Stack a -> l -> [(a, RationalRect)]) -> - Stack a -> - l -> - W (l, [(a, RationalRect)]) -pureLayout fn as l = return (l, fn as l) - --- A Layout which hides the layout parameter under an existential type and --- asserts the layout hidden can work with Window types. -data WindowLayout - = forall l a. - (LayoutClass l, LayoutConstraint l a, a ~ Window) => - WindowLayout l - -runWindowLayout :: Stack Window -> WindowLayout -> W (WindowLayout, [(Window, RationalRect)]) -runWindowLayout as (WindowLayout l) = first WindowLayout <$> runLayout as l - -handleWindowMessage :: Message -> WindowLayout -> MaybeT W WindowLayout -handleWindowMessage m (WindowLayout l) = WindowLayout <$> handleMessage m l - --- | Using the 'Layout' as a witness, parse existentially wrapped windows --- from a 'String'. -readWindowLayout :: WindowLayout -> String -> WindowLayout -readWindowLayout (WindowLayout l) s - | (Just x) <- readLayout s = - WindowLayout (asTypeOf x l) -readWindowLayout l _ = l - --- | Serializes a window layout to a string. -serializeWindowLayout :: WindowLayout -> String -serializeWindowLayout (WindowLayout l) = serializeLayout l - -type ScreenId = () - -type ScreenDetail = () - -type Tag = String - -newtype ReadPtr a = ReadPtr (Ptr ()) - -instance Read (ReadPtr a) where - readPrec = fmap (ReadPtr . intPtrToPtr) readPrec - -instance Show (ReadPtr a) where - show (ReadPtr ptr) = show (ptrToIntPtr ptr) - -type Wetterhorn = StablePtr (Context, State) - -data Context = Context - { ctxForeignInterface :: ForeignInterface, - ctxConfig :: Config WindowLayout - } - -defaultHooks :: Hooks -defaultHooks = - Hooks - { keyHook = \_ -> return (), - surfaceHook = handleSurface, - buttonHook = \_ -> return () - } - -defaultConfig :: Config () -defaultConfig = - Config - { hooks = defaultHooks, - layout = (), - resetHook = return () - } - -data Hooks = Hooks - { keyHook :: KeyEvent -> W (), - surfaceHook :: SurfaceEvent -> W (), - buttonHook :: ButtonEvent -> W () - } - -data Config l = Config - { layout :: l, - hooks :: Hooks, - resetHook :: W () - } - --- | Typeclass defining the set of types which can be used as state extensions --- to the W monad. These state extensions may be persistent or not. --- --- There are default implementations for all methods if the type implements --- Read, Show and Default, -class (Typeable a) => ExtensionClass a where - -- | The initial value used for the first time an extension is 'gotten' or - -- demarshalling fails. - initialValue :: a - - -- | Transforms a type into a string. If the type cannot be marshalled, this - -- function should return Nothing. - -- - -- If a type cannot be marshalled, it cannot persist across hot reloads. - marshalExtension :: a -> Maybe String - - -- | Reads an extension from a string. If this type is not marshallable or - -- reading fails, this function should return Nothing. - demarshalExtension :: String -> Maybe a - - -- | If the type implements Default, use the default implementation. - default initialValue :: (Default a) => a - initialValue = def - - -- | If the type implements Show, use show for the marshalling. - default marshalExtension :: (Show a) => a -> Maybe String - marshalExtension = Just . show - - -- | If the type implements Read, use read for the demarshalling. - default demarshalExtension :: (Read a) => String -> Maybe a - demarshalExtension = readMaybe - -data StateExtension where - StateExtension :: (ExtensionClass a) => a -> StateExtension - --- | Puts a state extension. -xput :: forall a m. (ExtensionClass a, Wlike m) => a -> m () -xput val = liftW $ do - modify' $ \state@State {extensibleState = extensibleState} -> - state - { extensibleState = - M.insert - ( xRepr (Proxy :: Proxy a) - ) - (Right $ StateExtension val) - extensibleState - } - --- | Modifies a state extension. -xmodify :: forall a m. (ExtensionClass a, Wlike m) => (a -> a) -> m () -xmodify fn = xput . fn =<< xget - --- | Modifies a state extension in the monadic context. -xmodifyM :: forall a m. (ExtensionClass a, Wlike m) => (a -> m a) -> m () -xmodifyM fn = (xput <=< fn) =<< xget - --- | Produces a string representation of a type used to key into the extensible --- state map. -xRepr :: forall proxy a. (ExtensionClass a) => proxy a -> String -xRepr _ = tyconToStr $ someTypeRepTyCon (someTypeRep (Proxy :: Proxy a)) - where - tyconToStr tc = - printf "%s.%s.%s" (tyConPackage tc) (tyConModule tc) (tyConName tc) - --- | Gets a state extension. -xget :: forall a m. (ExtensionClass a, Wlike m) => m a -xget = do - xs <- liftW $ gets extensibleState - case M.lookup (xRepr (Proxy :: Proxy a)) xs of - Just (Right (StateExtension a)) -> return (fromMaybe initialValue (cast a)) - Just (Left str) -> - let v = fromMaybe initialValue (demarshalExtension str) - in xput v >> return v - Nothing -> - xput (initialValue :: a) >> return initialValue - -xgets :: forall a b m. (ExtensionClass a, Wlike m) => (a -> b) -> m b -xgets fn = fn <$> xget - --- State as it is marshalled. Used for derived instances of Show and Read. -data MarshalledState - = MarshalledState - (StackSet ScreenId ScreenDetail Tag String Window) - (Set Window) - [(String, String)] - deriving (Show, Read) - -data State = State - { -- The datastructure containing the state of the windows. - mapped :: StackSet ScreenId ScreenDetail Tag WindowLayout Window, - -- | All the windows wetterhorn knows about, even if they are not mapped. - allWindows :: Set Window, - -- | Current set of hooks. The initial hooks are provided by the - -- configuration, but the hooks can change during operation. This is how key - -- sequences can be mapped. - currentHooks :: Hooks, - -- | Map from the typerep string to the state extension. - extensibleState :: Map String (Either String StateExtension) - } - --- | Initializes a "cold" state from a configuration. A cold state is the --- initial state on startup. It is constrasted with a "hot" state, which is a --- persisted state after a hot-reload. -initColdState :: Config WindowLayout -> IO State -initColdState Config {layout = layout, hooks = hooks} = - return $ - State - ( StackSet (Screen () () (Workspace "0" layout (Stack [] []))) [] [] - ) - mempty - hooks - mempty - --- | Marshals the serializable parts of the state to a string. This happens --- during a hot-reload where some state must be saved to persist across hot --- reloads. -marshalState :: State -> String -marshalState - ( State - { mapped = mapped, - allWindows = allWindows, - extensibleState = xs - } - ) = - show $ - MarshalledState - (mapLayout serializeWindowLayout mapped) - allWindows - (mapMaybe (\(k, v) -> (k,) <$> doMarshalEx v) (M.toList xs)) - where - doMarshalEx (Left s) = Just s - doMarshalEx (Right (StateExtension a)) = marshalExtension a - --- | Demarshals the string from "marshalState" into a state. Uses the provided --- config to fill out non-persistent parts of the state. -demarshalState :: Config WindowLayout -> String -> State -demarshalState Config {hooks = hooks, layout = layout} str = - State mapped allWindows hooks xs - where - ( MarshalledState - (mapLayout (readWindowLayout layout) -> mapped) - allWindows - (fmap Left . M.fromList -> xs) - ) = read str - --- | This is _the_ main monad used for Wetterhorn operations. Contains --- everything required to operate. Contains the state, configuration and --- interface to foreign code. -newtype W a = W (ReaderT Context (StateT State IO) a) - deriving (Functor, Applicative, Monad, MonadState State, MonadIO) - --- | Let Config be the thing W is a reader for. There is already a way to get --- the foreign interface in the context. -instance MonadReader (Config WindowLayout) W where - local fn (W r) = W $ local (\(Context fi conf) -> Context fi (fn conf)) r - ask = W $ ctxConfig <$> ask - -runW :: W a -> (Context, State) -> IO (a, State) -runW (W fn) (ctx, st) = runStateT (runReaderT fn ctx) st - -foreignInterface :: W ForeignInterface -foreignInterface = W $ ctxForeignInterface <$> ask - -getSeat :: W (Ptr WlrSeat) -getSeat = (wio . ForeignInterface.getSeat) =<< foreignInterface - -requestHotReload :: W () -requestHotReload = (wio . ForeignInterface.requestHotReload) =<< foreignInterface - -requestExit :: Int -> W () -requestExit ec = (wio . flip ForeignInterface.requestExit ec) =<< foreignInterface - -shellExec :: String -> W () -shellExec = wio . ForeignInterface.doShellExec - -wio :: IO a -> W a -wio = liftIO - --- | Type class to lift an arbitrary 'W' computation into another monad. -class (Monad m) => Wlike m where - liftW :: W a -> m a - --- | Trivial instance of W for Wlike. -instance Wlike W where - liftW = id - --- Default implementations for common handlers. - --- | handles a new surface event. This updates the state to reflect how it --- should look in the harness. -handleSurface :: SurfaceEvent -> W () -handleSurface (SurfaceEvent state (Window -> win)) = - case state of - Destroy -> - modify $ - \st@State - { allWindows = allWindows, - mapped = mapped - } -> - st - { allWindows = Set.delete win allWindows, - mapped = StackSet.delete win mapped - } - Unmap -> modify $ - \st@State {mapped = mapped} -> - st - { mapped = StackSet.delete win mapped - } - Map -> modify $ - \st@State {mapped = mapped, allWindows = allWindows} -> - st - { mapped = StackSet.insertTiled win mapped, - allWindows = Set.insert win allWindows - } diff --git a/src/Wetterhorn/Dsl/Bind.hs b/src/Wetterhorn/Dsl/Bind.hs deleted file mode 100644 index 0b6adaf..0000000 --- a/src/Wetterhorn/Dsl/Bind.hs +++ /dev/null @@ -1,128 +0,0 @@ --- | eDSL for the 'bind' function. The 'bind' function provides an easy way to --- bind certain actions to other actions. -module Wetterhorn.Dsl.Bind - ( bind, - (.+), - MatchEvent (..), - Modifier (..), - released, - weak, - run, - modifierToMask, - module X, - ) -where - -import Control.Monad -import Control.Monad.Trans -import Data.Bits -import Data.Word -import Wetterhorn.Core.ButtonEvent (ButtonEvent(..)) -import qualified Wetterhorn.Core.ButtonEvent as ButtonEvent -import Wetterhorn.Core.KeyEvent (KeyEvent(..)) -import qualified Wetterhorn.Core.KeyEvent as KeyEvent -import Wetterhorn.Core.W -import Wetterhorn.Dsl.Buttons as X -import Wetterhorn.Dsl.Input - -class MatchEvent m where - matches :: m -> InputEvent -> W Bool - -instance MatchEvent (InputEvent -> W Bool) where - matches = ($) - -instance MatchEvent Char where - matches ch (InputKeyEvent ke) = return $ KeyEvent.codepoint ke == ch - matches _ _ = return False - -instance MatchEvent Button where - matches (Button b) (InputButtonEvent be) = - return $ ButtonEvent.button be == b - matches _ _ = return False - --- | Enumeration of possible modifiers. --- --- ModX can be used for extra user-defined modifiers which are not standard xkb --- modifiers. -data Modifier - = Shift - | Lock - | Control - | Mod1 - | Mod2 - | Mod3 - | Mod4 - | Mod5 - | ModX Int - deriving (Eq, Ord, Show, Read) - --- | Converts a modifier to its associated mask. -modifierToMask :: Modifier -> Word32 -modifierToMask m = - 1 - `shiftL` case m of - Shift -> 0 - Lock -> 1 - Control -> 2 - Mod1 -> 3 - Mod2 -> 4 - Mod3 -> 5 - Mod4 -> 6 - Mod5 -> 7 - ModX b -> b + 8 - -released :: (MatchEvent m) => m -> InputEvent -> W Bool -released me ev | not (isPressEvent ev) = matches me ev -released _ _ = return False - -data MatchModifiers = MatchModifiers - { weakModifierMatch :: Bool, - modifierMask :: Word32, - baseMatch :: InputEvent -> W Bool - } - -instance MatchEvent MatchModifiers where - matches (MatchModifiers weak bits base) ev = do - mods <- getMods ev - b <- liftW $ base ev - - return $ - b - && ( (not weak && mods == bits) - || (weak && (bits .&. mods == bits)) - ) - where - getMods (InputButtonEvent (ButtonEvent {ButtonEvent.modifiers = mods})) = return mods - getMods (InputKeyEvent (KeyEvent {KeyEvent.modifiers = mods})) = return mods - getMods _ = getModifierState - -class LiftMatchModifiers a where - toModifiers :: a -> MatchModifiers - default toModifiers :: (MatchEvent a) => a -> MatchModifiers - toModifiers = MatchModifiers False 0 . matches - -instance LiftMatchModifiers MatchModifiers where - toModifiers = id - -instance LiftMatchModifiers Char - -instance LiftMatchModifiers Button - --- toModifiers ch = MatchModifiers False 0 (matches ch) - -(.+) :: (LiftMatchModifiers mods) => Modifier -> mods -> MatchModifiers -(.+) modifier (toModifiers -> (MatchModifiers b mask base)) = - MatchModifiers b (mask .|. modifierToMask modifier) base - -infixr 9 .+ - -bind :: (MatchEvent match) => InputEvent -> match -> InputM spy () -> InputM spy () -bind ev match action = do - matches' <- liftW $ matches match ev - when matches' (action >> continue) - -weak :: MatchModifiers -> MatchModifiers -weak m = m {weakModifierMatch = True} - -run :: W () -> InputM spy () -run = liftW diff --git a/src/Wetterhorn/Dsl/Buttons.hsc b/src/Wetterhorn/Dsl/Buttons.hsc deleted file mode 100644 index c3e049c..0000000 --- a/src/Wetterhorn/Dsl/Buttons.hsc +++ /dev/null @@ -1,229 +0,0 @@ -module Wetterhorn.Dsl.Buttons where - -import Data.Word - -#include - -data Button = Button Word32 - -btnMisc :: Button -btnMisc = Button #const BTN_MISC - -btn0 :: Button -btn0 = Button #const BTN_0 - -btn1 :: Button -btn1 = Button #const BTN_1 - -btn2 :: Button -btn2 = Button #const BTN_2 - -btn3 :: Button -btn3 = Button #const BTN_3 - -btn4 :: Button -btn4 = Button #const BTN_4 - -btn5 :: Button -btn5 = Button #const BTN_5 - -btn6 :: Button -btn6 = Button #const BTN_6 - -btn7 :: Button -btn7 = Button #const BTN_7 - -btn8 :: Button -btn8 = Button #const BTN_8 - -btn9 :: Button -btn9 = Button #const BTN_9 - -btnMouse :: Button -btnMouse = Button #const BTN_MOUSE - -btnLeft :: Button -btnLeft = Button #const BTN_LEFT - -btnRight :: Button -btnRight = Button #const BTN_RIGHT - -btnMiddle :: Button -btnMiddle = Button #const BTN_MIDDLE - -btnSide :: Button -btnSide = Button #const BTN_SIDE - -btnExtra :: Button -btnExtra = Button #const BTN_EXTRA - -btnForward :: Button -btnForward = Button #const BTN_FORWARD - -btnBack :: Button -btnBack = Button #const BTN_BACK - -btnTask :: Button -btnTask = Button #const BTN_TASK - -btnJoystick :: Button -btnJoystick = Button #const BTN_JOYSTICK - -btnTrigger :: Button -btnTrigger = Button #const BTN_TRIGGER - -btnThumb :: Button -btnThumb = Button #const BTN_THUMB - -btnThumb2 :: Button -btnThumb2 = Button #const BTN_THUMB2 - -btnTop :: Button -btnTop = Button #const BTN_TOP - -btnTop2 :: Button -btnTop2 = Button #const BTN_TOP2 - -btnPinkie :: Button -btnPinkie = Button #const BTN_PINKIE - -btnBase :: Button -btnBase = Button #const BTN_BASE - -btnBase2 :: Button -btnBase2 = Button #const BTN_BASE2 - -btnBase3 :: Button -btnBase3 = Button #const BTN_BASE3 - -btnBase4 :: Button -btnBase4 = Button #const BTN_BASE4 - -btnBase5 :: Button -btnBase5 = Button #const BTN_BASE5 - -btnBase6 :: Button -btnBase6 = Button #const BTN_BASE6 - -btnDead :: Button -btnDead = Button #const BTN_DEAD - -btnGamepad :: Button -btnGamepad = Button #const BTN_GAMEPAD - -btnSouth :: Button -btnSouth = Button #const BTN_SOUTH - -btnA :: Button -btnA = Button #const BTN_A - -btnEast :: Button -btnEast = Button #const BTN_EAST - -btnB :: Button -btnB = Button #const BTN_B - -btnC :: Button -btnC = Button #const BTN_C - -btnNorth :: Button -btnNorth = Button #const BTN_NORTH - -btnX :: Button -btnX = Button #const BTN_X - -btnWest :: Button -btnWest = Button #const BTN_WEST - -btnY :: Button -btnY = Button #const BTN_Y - -btnZ :: Button -btnZ = Button #const BTN_Z - -btnTl :: Button -btnTl = Button #const BTN_TL - -btnTr :: Button -btnTr = Button #const BTN_TR - -btnTl2 :: Button -btnTl2 = Button #const BTN_TL2 - -btnTr2 :: Button -btnTr2 = Button #const BTN_TR2 - -btnSelect :: Button -btnSelect = Button #const BTN_SELECT - -btnStart :: Button -btnStart = Button #const BTN_START - -btnMode :: Button -btnMode = Button #const BTN_MODE - -btnThumbl :: Button -btnThumbl = Button #const BTN_THUMBL - -btnThumbr :: Button -btnThumbr = Button #const BTN_THUMBR - -btnDigi :: Button -btnDigi = Button #const BTN_DIGI - -btnToolPen :: Button -btnToolPen = Button #const BTN_TOOL_PEN - -btnToolRubber :: Button -btnToolRubber = Button #const BTN_TOOL_RUBBER - -btnToolBrush :: Button -btnToolBrush = Button #const BTN_TOOL_BRUSH - -btnToolPencil :: Button -btnToolPencil = Button #const BTN_TOOL_PENCIL - -btnToolAirbrush :: Button -btnToolAirbrush = Button #const BTN_TOOL_AIRBRUSH - -btnToolFinger :: Button -btnToolFinger = Button #const BTN_TOOL_FINGER - -btnToolMouse :: Button -btnToolMouse = Button #const BTN_TOOL_MOUSE - -btnToolLens :: Button -btnToolLens = Button #const BTN_TOOL_LENS - -btnToolQuinttap :: Button -btnToolQuinttap = Button #const BTN_TOOL_QUINTTAP - -btnStylus3 :: Button -btnStylus3 = Button #const BTN_STYLUS3 - -btnTouch :: Button -btnTouch = Button #const BTN_TOUCH - -btnStylus :: Button -btnStylus = Button #const BTN_STYLUS - -btnStylus2 :: Button -btnStylus2 = Button #const BTN_STYLUS2 - -btnToolDoubletap :: Button -btnToolDoubletap = Button #const BTN_TOOL_DOUBLETAP - -btnToolTripletap :: Button -btnToolTripletap = Button #const BTN_TOOL_TRIPLETAP - -btnToolQuadtap :: Button -btnToolQuadtap = Button #const BTN_TOOL_QUADTAP - -btnWheel :: Button -btnWheel = Button #const BTN_WHEEL - -btnGearDown :: Button -btnGearDown = Button #const BTN_GEAR_DOWN - -btnGearUp :: Button -btnGearUp = Button #const BTN_GEAR_UP diff --git a/src/Wetterhorn/Dsl/Input.hs b/src/Wetterhorn/Dsl/Input.hs deleted file mode 100644 index 1a0c294..0000000 --- a/src/Wetterhorn/Dsl/Input.hs +++ /dev/null @@ -1,286 +0,0 @@ -{-# LANGUAGE DataKinds #-} - -module Wetterhorn.Dsl.Input - ( InputM, - InputEvent (..), - InputProxy (..), - NoProxy, - withProxies, - forwardEvent, - forwardKey, - whenKeyEvent, - whenButtonEvent, - useInputHandler, - unwrap, - filterEvent, - isPressEvent, - nextInputEventThat, - replayEvents, - isKeyEvent, - nextInputPressEvent, - continue, - nextInputEvent, - getModifierState, - ) -where - -import Control.Concurrent (threadDelay) -import Control.Monad -import Control.Monad.Cont (MonadCont) -import Control.Monad.Loops (andM) -import Control.Monad.RWS - ( MonadIO (liftIO), - MonadReader (ask), - MonadState (get), - MonadTrans (lift), - RWST, - execRWST, - gets, - modify, - ) -import Control.Monad.Trans.Cont -import Control.Monad.Trans.Maybe (MaybeT (runMaybeT)) -import Data.IORef (newIORef, readIORef, writeIORef) -import Data.Proxy -import Data.Word (Word32) -import qualified Wetterhorn.Core.ButtonEvent as ButtonEvent -import qualified Wetterhorn.Core.KeyEvent as KeyEvent -import Wetterhorn.Core.W (W (..)) -import qualified Wetterhorn.Core.W as W -import Wetterhorn.Foreign.WlRoots (guardNull, wlrKeyboardGetModifiers, wlrSeatGetKeyboard, wlrSeatKeyboardNotifyKey, wlrSeatSetKeyboard) - -class InputProxy (spy :: k) where - onKeyEvent :: Proxy spy -> InputEvent -> MaybeT W InputEvent - -instance (InputProxy h, InputProxy t) => InputProxy (h ': t) where - onKeyEvent _ = onKeyEvent (Proxy :: Proxy h) <=< onKeyEvent (Proxy :: Proxy t) - -instance InputProxy '[] where - onKeyEvent _ = return - -data NoProxy - -instance InputProxy NoProxy where - onKeyEvent _ = return - -instance (InputProxy s1, InputProxy s2) => InputProxy (s1, s2) where - onKeyEvent proxy = onKeyEvent (fmap fst proxy) <=< onKeyEvent (fmap snd proxy) - --- | Union of event types. -data InputEvent - = InputButtonEvent ButtonEvent.ButtonEvent - | InputKeyEvent KeyEvent.KeyEvent - --- | Context for the input. -newtype InputContext spy = InputContext - { -- | Top of the input routine. Used in "continue" statement. - inputTop :: InputM spy () - } - -newtype InputState spy = InputState - { inputSource :: InputM spy InputEvent - } - --- | Input monad for handling all kinds of input. -newtype InputM spy a = InputM (ContT () (RWST (InputContext spy) () (InputState spy) W) a) - deriving (Monad, Functor, Applicative, MonadCont, MonadIO) - -instance MonadFail (InputM spy) where - fail _ = continue - --- | Lifts a W action to an InputM action. -instance W.Wlike (InputM spy) where - liftW = InputM . lift . lift - --- | Resets the input handler to the top. -continue :: InputM spy a -continue = do - (InputContext {inputTop = (InputM top)}) <- InputM ask - InputM $ shiftT (\_ -> resetT top) - --- | Forwards the given key event to the focused window. -forwardKey :: KeyEvent.KeyEvent -> W () -forwardKey keyEvent = do - seatPtr <- W.getSeat - W.wio $ do - wlrSeatSetKeyboard - seatPtr - (KeyEvent.device keyEvent) - - wlrSeatKeyboardNotifyKey - seatPtr - (KeyEvent.timeMs keyEvent) - (KeyEvent.keycode keyEvent) - ( case KeyEvent.state keyEvent of - KeyEvent.KeyReleased -> 0 - _ -> 1 - ) - --- | Executes a function if the input event is a key event. If it is not a key --- event, then nothing happens. -whenKeyEvent :: (Monad m) => InputEvent -> (KeyEvent.KeyEvent -> m ()) -> m () -whenKeyEvent (InputKeyEvent ke) = ($ ke) -whenKeyEvent _ = const (return ()) - --- | Executes a function in the input event is a button event. If it is not a --- button event, then nothing happens. -whenButtonEvent :: - (Monad m) => InputEvent -> (ButtonEvent.ButtonEvent -> m ()) -> m () -whenButtonEvent (InputButtonEvent be) = ($ be) -whenButtonEvent _ = const (return ()) - --- | Forwards the given input event to focused window. -forwardEvent :: (W.Wlike m) => InputEvent -> m () -forwardEvent = \case - InputKeyEvent kv -> W.liftW $ forwardKey kv - InputButtonEvent _ -> return () - --- | "Unwraps" a maybe. If the maybe is present, the handler proceeds. If the --- maybe is not present, the handler restarts execution from the top. -unwrap :: Maybe a -> InputM spy a -unwrap (Just val) = return val -unwrap Nothing = continue - --- | Runs the series of events from the top as if they were input. -replayEvents :: [InputEvent] -> InputM spy () -replayEvents events = do - ioref <- liftIO (newIORef events) - - (InputM oldInput) <- InputM $ gets inputSource - - let newInput = - InputM $ - shiftT - ( \thingToDo -> do - r <- liftIO (readIORef ioref) - case r of - [] -> do - modify $ \st -> st {inputSource = InputM oldInput} - a <- oldInput - lift (thingToDo a) - (a : as) -> do - liftIO (writeIORef ioref as) - lift (thingToDo a) - ) - - InputM $ modify $ \st -> st {inputSource = newInput} - where - delay to act = liftIO (threadDelay to) >> act - --- | Call in the reset handler with the InputM handler you wolud like to use. -useInputHandler :: (InputProxy spy) => InputM spy () -> W () -useInputHandler (forever -> top@(InputM ctop)) = do - void $ execRWST (runContT ctop return) (InputContext top) (InputState useSeatEvents) - --- | Returns the next input event that's either a kep press or a button press. -nextInputPressEvent :: InputM spy InputEvent -nextInputPressEvent = nextInputEventThat (andM [isPressEvent, not . modifierKey]) - -modifierKey :: InputEvent -> Bool -modifierKey (InputKeyEvent (KeyEvent.KeyEvent {codepoint = '\NUL'})) = True -modifierKey _ = False - -nextInputEventThat :: (InputEvent -> Bool) -> InputM spy InputEvent -nextInputEventThat fn = - nextInputEvent - >>= ( \ie -> - if fn ie - then return ie - else forwardEvent ie >> nextInputEventThat fn - ) - -isKeyEvent :: InputEvent -> Bool -isKeyEvent (InputKeyEvent _) = True -isKeyEvent _ = False - -isPressEvent :: InputEvent -> Bool -isPressEvent (InputButtonEvent be) - | ButtonEvent.state be == ButtonEvent.ButtonPressed = - True -isPressEvent (InputKeyEvent ke) - | KeyEvent.state ke == KeyEvent.KeyPressed = - True -isPressEvent _ = False - --- | Returns the event only if it matches the filter. If it does not match the --- filter, execution resets to the top. -filterEvent :: (InputEvent -> Bool) -> InputEvent -> InputM spy InputEvent -filterEvent fn ev | fn ev = return ev -filterEvent _ _ = continue - -getModifierState :: W Word32 -getModifierState = do - seat <- W.getSeat - keyboard <- W.wio $ wlrSeatGetKeyboard seat - maybe (return 0) (W.wio . wlrKeyboardGetModifiers) (guardNull keyboard) - -nextInputEvent :: InputM spy InputEvent -nextInputEvent = join $ InputM $ gets inputSource - -withProxies :: Proxy spy -> InputM spy a -> InputM spy a -withProxies _ = id - --- | Gets the next input event. -useSeatEvents :: forall spy. (InputProxy spy) => InputM spy InputEvent -useSeatEvents = - InputM $ - shiftT - ( \thingToDo -> do - putButtonHandler $ \be -> do - runSpies thingToDo (InputButtonEvent be) - - putKeyHandler $ \ke -> do - runSpies thingToDo (InputKeyEvent ke) - ) - where - runSpies fn ev = do - evM <- lift $ runMaybeT (onKeyEvent (Proxy :: Proxy spy) ev) - mapM_ - ( \ev' -> do - clearButtonHandler - clearKeyHandler - fn ev' - ) - evM - - clearButtonHandler = - lift $ - modify $ \st -> - st - { W.currentHooks = - (W.currentHooks st) - { W.buttonHook = const (return ()) - } - } - - clearKeyHandler = - lift $ - modify $ \st -> - st - { W.currentHooks = - (W.currentHooks st) - { W.keyHook = const (return ()) - } - } - - putButtonHandler h = lift $ do - (r, s) <- (,) <$> ask <*> get - lift $ - modify $ \st -> - st - { W.currentHooks = - (W.currentHooks st) - { W.buttonHook = \be -> void (execRWST (h be) r s) - } - } - - putKeyHandler h = lift $ do - (r, s) <- (,) <$> ask <*> get - lift $ - modify $ \st -> - st - { W.currentHooks = - (W.currentHooks st) - { W.keyHook = \ke -> void (execRWST (h ke) r s) - } - } diff --git a/src/Wetterhorn/Foreign.hs b/src/Wetterhorn/Foreign.hs deleted file mode 100644 index 2d0a42c..0000000 --- a/src/Wetterhorn/Foreign.hs +++ /dev/null @@ -1,18 +0,0 @@ -module Wetterhorn.Foreign - ( TypedIntPtr (..), - toPtr, - fromPtr, - ) -where - -import Foreign (IntPtr, Ptr) -import qualified Foreign - -toPtr :: TypedIntPtr a -> Ptr a -toPtr (TypedIntPtr ip) = Foreign.intPtrToPtr ip - -fromPtr :: Ptr a -> TypedIntPtr a -fromPtr = TypedIntPtr . Foreign.ptrToIntPtr - -newtype TypedIntPtr a = TypedIntPtr IntPtr - deriving (Show, Read, Eq, Ord, Num) diff --git a/src/Wetterhorn/Foreign/Export.hs b/src/Wetterhorn/Foreign/Export.hs deleted file mode 100644 index 51bd72b..0000000 --- a/src/Wetterhorn/Foreign/Export.hs +++ /dev/null @@ -1,208 +0,0 @@ --- | This module does not export anything. It exists simply to provide C-symbols --- for the plugin. -module Wetterhorn.Foreign.Export () where - -import Config -import Control.Arrow (Arrow (first)) -import Control.Monad (forM_) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as CH -import Foreign - ( Ptr, - Storable (poke, pokeByteOff), - Word32, - Word8, - deRefStablePtr, - freeStablePtr, - mallocBytes, - newStablePtr, - ) -import Foreign.C (CChar, CInt (..)) -import Wetterhorn.Core.ButtonEvent (ButtonEvent (ButtonEvent), ButtonState (ButtonPressed, ButtonReleased)) -import Wetterhorn.Core.KeyEvent (KeyEvent (..), KeyState (..)) -import Wetterhorn.Core.SurfaceEvent (SurfaceEvent (SurfaceEvent)) -import Wetterhorn.Core.W (W, Wetterhorn) -import qualified Wetterhorn.Core.W as W -import Wetterhorn.Foreign.ForeignInterface -import Wetterhorn.Foreign.WlRoots - -type Wetter = (W.Config W.WindowLayout, W.State) - -toWetter :: (W.Context, W.State) -> (W.Config W.WindowLayout, W.State) -toWetter = first W.ctxConfig - -runForeign :: (Wetter -> W ()) -> Wetterhorn -> IO Wetterhorn -runForeign fn stblptr = do - w@(ctx, st) <- deRefStablePtr stblptr - freeStablePtr stblptr - (_, state') <- W.runW (fn $ toWetter w) (ctx, st) - newStablePtr (ctx, state') - -runForeignWithReturn :: - (Storable a) => (Wetter -> W a) -> Ptr a -> Wetterhorn -> IO Wetterhorn -runForeignWithReturn fn ptr stableptr = do - w@(ctx, st) <- deRefStablePtr stableptr - freeStablePtr stableptr - (val, state') <- W.runW (fn $ toWetter w) (ctx, st) - poke ptr val - newStablePtr (ctx, state') - -runForeignWithReturn2 :: - (Storable a, Storable b) => - (Wetter -> W (a, b)) -> - Ptr a -> - Ptr b -> - Wetterhorn -> - IO Wetterhorn -runForeignWithReturn2 fn ptrA ptrB stableptr = do - w@(ctx, st) <- deRefStablePtr stableptr - freeStablePtr stableptr - ((vA, vB), state') <- W.runW (fn $ toWetter w) (ctx, st) - poke ptrA vA - poke ptrB vB - newStablePtr (ctx, state') - --- | This function is the implementation of the "hotstart" mechanism. It gives a --- pointer to the previously marshalled state and the length of that array and --- this function returns a Wetterhorn instance. -foreign export ccall "plugin_hot_start" - pluginHotStart :: - Ptr CChar -> Word32 -> IO Wetterhorn - -pluginHotStart :: Ptr CChar -> Word32 -> IO Wetterhorn -pluginHotStart chars len = do - bs <- BS.packCStringLen (chars, fromIntegral len) - foreignInterface <- getForeignInterface - wtr <- - newStablePtr - ( W.Context foreignInterface config, - W.demarshalState config (CH.unpack bs) - ) - runForeign (\(conf, _) -> W.resetHook conf) wtr - --- | This function is called when a "coldstart" request is receieved. It just --- calles the function "wetterhorn". This function should be defined in the main --- code as it's sort-of the equivalent of XMonad's "main" function. -foreign export ccall "plugin_cold_start" - pluginColdStart :: IO Wetterhorn - -pluginColdStart :: IO Wetterhorn -pluginColdStart = do - foreignInterface <- getForeignInterface - state <- W.initColdState config - wtr <- newStablePtr (W.Context foreignInterface config, state) - runForeign (\(conf, _) -> W.resetHook conf) wtr - --- | Marshals the opaque state to a C-style byte array and size pointer. -foreign export ccall "plugin_marshal_state" - pluginMarshalState :: Wetterhorn -> Ptr Word32 -> IO (Ptr Word8) - -pluginMarshalState :: Wetterhorn -> Ptr Word32 -> IO (Ptr Word8) -pluginMarshalState stblptr outlen = do - (_, st) <- deRefStablePtr stblptr - let bs = CH.pack (W.marshalState st) - ret <- mallocBytes (BS.length bs) - poke outlen (fromIntegral $ BS.length bs) - forM_ (zip [0 ..] (BS.unpack bs)) $ \(off, w8) -> do - pokeByteOff ret off w8 - return ret - -foreign export ccall "plugin_handle_button" - pluginHandleButton :: Ptr WlrPointerButtonEvent -> Word32 -> Wetterhorn -> IO Wetterhorn - -pluginHandleButton :: Ptr WlrPointerButtonEvent -> Word32 -> Wetterhorn -> IO Wetterhorn -pluginHandleButton eventPtr modifiers = do - runForeign $ - \( _, - W.State {W.currentHooks = W.Hooks {buttonHook = buttonHook}} - ) -> do - event <- W.wio $ - runForeignDemarshal eventPtr $ do - ButtonEvent - <$> demarshal - <*> demarshal - <*> demarshal - <*> pure modifiers - <*> ( ( \u8 -> - if (u8 :: Word8) == 0 - then ButtonReleased - else ButtonPressed - ) - <$> demarshal - ) - - buttonHook event - -foreign export ccall "plugin_handle_keybinding" - pluginHandleKeybinding :: - Ptr WlrInputDevice -> - Ptr WlrEventKeyboardKey -> - Word32 -> - Word32 -> - Word32 -> - Ptr CInt -> - Wetterhorn -> - IO Wetterhorn - -pluginHandleKeybinding :: - Ptr WlrInputDevice -> - Ptr WlrEventKeyboardKey -> - Word32 -> - Word32 -> - Word32 -> - Ptr CInt -> - Wetterhorn -> - IO Wetterhorn -pluginHandleKeybinding inputDevicePtr eventPtr mods sym cp = - runForeignWithReturn $ - \( _, - W.State {W.currentHooks = W.Hooks {keyHook = keyHook}} - ) -> do - event <- W.wio $ - runForeignDemarshal eventPtr $ do - tMs <- demarshal - kc <- demarshal - _ <- (demarshal :: ForeignDemarshal Word32) - keyState <- demarshal - return $ - KeyEvent - tMs - kc - (if keyState == (0 :: Word8) then KeyReleased else KeyPressed) - mods - sym - (toEnum $ fromIntegral cp) - inputDevicePtr - keyHook event - return 1 - --- | Function exported to the harness to handle the mapping/unmapping/deletion --- of an XDG surface. -foreign export ccall "plugin_handle_surface" - pluginHandleSurface :: - Ptr WlrXdgSurface -> CInt -> Wetterhorn -> IO Wetterhorn - -pluginHandleSurface :: Ptr WlrXdgSurface -> CInt -> Wetterhorn -> IO Wetterhorn -pluginHandleSurface p t = - runForeign - ( \(_, W.State {currentHooks = W.Hooks {surfaceHook = surfaceHook}}) -> - surfaceHook $ - SurfaceEvent (toEnum $ fromIntegral t) (toSurface p) - ) - --- | Function exported to the harness to handle the mapping/unmapping/deletion --- of an XWayland surface. -foreign export ccall "plugin_handle_xwayland_surface" - pluginHandleXWaylandSurface :: - Ptr WlrXWaylandSurface -> CInt -> Wetterhorn -> IO Wetterhorn - -pluginHandleXWaylandSurface :: - Ptr WlrXWaylandSurface -> CInt -> Wetterhorn -> IO Wetterhorn -pluginHandleXWaylandSurface p t = - runForeign - ( \( _, - W.State - { currentHooks = W.Hooks {surfaceHook = surfaceHook} - } - ) -> surfaceHook $ SurfaceEvent (toEnum $ fromIntegral t) (toSurface p) - ) diff --git a/src/Wetterhorn/Foreign/ForeignInterface.hs b/src/Wetterhorn/Foreign/ForeignInterface.hs deleted file mode 100644 index 471e3a9..0000000 --- a/src/Wetterhorn/Foreign/ForeignInterface.hs +++ /dev/null @@ -1,81 +0,0 @@ -module Wetterhorn.Foreign.ForeignInterface - ( getForeignInterface, - ForeignInterface (..), - ForeignDemarshal (..), - runForeignDemarshal, - demarshal, - doShellExec, - ) -where - -import Control.Monad.State (MonadState (get, put), MonadTrans (lift), StateT, evalStateT) -import Data.Void (Void) -import Foreign (Ptr, Storable (peek, sizeOf), castPtr, plusPtr) -import Foreign.C (CChar, CInt (..)) -import Foreign.C.String -import GHC.Exts (FunPtr) -import Wetterhorn.Foreign.WlRoots - -newtype ForeignDemarshal a = ForeignDemarshal (StateT (Ptr ()) IO a) - deriving (Functor, Monad, Applicative, MonadState (Ptr ())) - -runForeignDemarshal :: Ptr b -> ForeignDemarshal a -> IO a -runForeignDemarshal p (ForeignDemarshal dm) = evalStateT dm (castPtr p) - -demarshal :: (Storable a) => ForeignDemarshal a -demarshal = do - ptr <- get - val <- ForeignDemarshal $ lift $ peek $ castPtr ptr - put (plusPtr ptr (sizeOf val)) - return val - -type CtxT = Ptr Void - -type ForeignCallGetPtr = CtxT -> IO (Ptr ()) - -type ForeignCall = CtxT -> IO () - -type ForeignCallStr = CtxT -> CString -> IO () - -type ForeignCallInt = CtxT -> CInt -> IO () - -foreign import ccall "get_foreign_interface" foreignInterfacePtr :: IO (Ptr ()) - -foreign import ccall "dynamic" toForeignCall :: FunPtr ForeignCall -> ForeignCall - -foreign import ccall "dynamic" toForeignCallStr :: FunPtr ForeignCallStr -> ForeignCallStr - -foreign import ccall "dynamic" toForeignCallInt :: FunPtr ForeignCallInt -> ForeignCallInt - -foreign import ccall "dynamic" toForeignCallGetPtr :: FunPtr ForeignCallGetPtr -> ForeignCallGetPtr - -foreign import ccall "shell_exec" shellExec :: Ptr CChar -> IO () - -data ForeignInterface = ForeignInterface - { requestHotReload :: IO (), - requestLog :: String -> IO (), - requestExit :: Int -> IO (), - getSeat :: IO (Ptr WlrSeat) - } - -doShellExec :: String -> IO () -doShellExec str = withCString str shellExec - -getForeignInterface :: IO ForeignInterface -getForeignInterface = do - ptr <- foreignInterfacePtr - runForeignDemarshal ptr $ do - ctx <- demarshal - requestHotReloadFn <- demarshal - doLogFn <- demarshal - doRequestExit <- demarshal - getSeatFn <- demarshal - - return $ - ForeignInterface - { requestHotReload = toForeignCall requestHotReloadFn ctx, - requestLog = \str -> - withCString str $ \cs -> toForeignCallStr doLogFn ctx cs, - requestExit = toForeignCallInt doRequestExit ctx . fromIntegral, - getSeat = castPtr <$> toForeignCallGetPtr getSeatFn ctx - } diff --git a/src/Wetterhorn/Foreign/WlRoots.hs b/src/Wetterhorn/Foreign/WlRoots.hs deleted file mode 100644 index 0581b77..0000000 --- a/src/Wetterhorn/Foreign/WlRoots.hs +++ /dev/null @@ -1,67 +0,0 @@ -module Wetterhorn.Foreign.WlRoots where - -import Foreign (IntPtr, Ptr, Word32, intPtrToPtr, ptrToIntPtr, nullPtr) -import Text.Read - -data WlrKeyboard - -data WlrPointer - -data WlrPointerButtonEvent - -data WlrSeat - -data WlrInputDevice - -data WlrEventKeyboardKey - -data WlrXdgSurface - -data WlrXWaylandSurface - -data Surface - = XdgSurface (Ptr WlrXdgSurface) - | XWaylandSurface (Ptr WlrXWaylandSurface) - deriving (Ord, Eq) - -instance Show Surface where - show (XdgSurface p) = show (XdgSerializeSurface (ptrToIntPtr p)) - show (XWaylandSurface p) = show (XWaylandSerializeSurface (ptrToIntPtr p)) - -instance Read Surface where - readPrec = fmap toSurf readPrec - where - toSurf (XdgSerializeSurface ip) = XdgSurface (intPtrToPtr ip) - toSurf (XWaylandSerializeSurface ip) = XWaylandSurface (intPtrToPtr ip) - --- | Type which exists specifically to derive instances of read and show. -data SerializableSurface - = XdgSerializeSurface IntPtr - | XWaylandSerializeSurface IntPtr - deriving (Read, Show) - -class ForeignSurface a where - toSurface :: Ptr a -> Surface - -instance ForeignSurface WlrXdgSurface where - toSurface = XdgSurface - -instance ForeignSurface WlrXWaylandSurface where - toSurface = XWaylandSurface - -guardNull :: Ptr a -> Maybe (Ptr a) -guardNull p | p == nullPtr = Nothing -guardNull p = Just p - -foreign import ccall "wlr_seat_set_keyboard" wlrSeatSetKeyboard :: - Ptr WlrSeat -> Ptr WlrInputDevice -> IO () - -foreign import ccall "wlr_seat_get_keyboard" wlrSeatGetKeyboard :: - Ptr WlrSeat -> IO (Ptr WlrKeyboard) - -foreign import ccall "wlr_keyboard_get_modifiers" wlrKeyboardGetModifiers :: - Ptr WlrKeyboard -> IO Word32 - -foreign import ccall "wlr_seat_keyboard_notify_key" - wlrSeatKeyboardNotifyKey :: - Ptr WlrSeat -> Word32 -> Word32 -> Word32 -> IO () diff --git a/src/Wetterhorn/Keys/Macros.hs b/src/Wetterhorn/Keys/Macros.hs deleted file mode 100644 index a794193..0000000 --- a/src/Wetterhorn/Keys/Macros.hs +++ /dev/null @@ -1,145 +0,0 @@ --- There are constraints used for better type-level enforced safety rules. -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} - -module Wetterhorn.Keys.Macros - ( MacroSupport, - macroStartStopKeybind, - macroReplayKeybind, - stopMacroRecording, - startRecording, - ) -where - -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Trans (MonadTrans (lift)) -import Data.Default.Class -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Type.Bool -import Data.Type.Equality -import Data.Word -import Foreign (Ptr) -import GHC.TypeError -import Wetterhorn.Core.KeyEvent -import Wetterhorn.Core.W -import Wetterhorn.Dsl.Input -import Wetterhorn.Foreign.WlRoots (WlrInputDevice) - -data RecordedKey = RecordedKey Word32 Word32 KeyState Word32 Word32 Char - deriving (Read, Show) - -data MacrosState = MacrosState - { macros :: Map String [RecordedKey], - currentlyRecording :: Maybe String - } - deriving (Read, Show) - -instance Default MacrosState where - def = MacrosState mempty def - -instance ExtensionClass MacrosState - -type family Find a ls where - Find b (a : t) = (b == a) || Find b t - Find _ '[] = False - --- | Provides a Vim-esque keybinding behavior for macro recording. --- --- Designed to be used like: --- --- bind ev (Mod1 .+ 'q') macroStartStopKeybind -macroStartStopKeybind :: (HasMacroSupport spy) => InputM spy () -macroStartStopKeybind = do - currentlyRecordingMacro - >>= ( \case - Just ch -> do - liftIO $ putStrLn $ "Done Recording: " ++ ch - stopMacroRecording - Nothing -> do - (InputKeyEvent (KeyEvent {codepoint = cp})) <- nextInputPressEvent - liftIO $ putStrLn $ "Recording: " ++ [cp] - startRecording [cp] - ) - --- | Provides a keybinding for replaying a macro. --- --- Designed to be used like: --- --- bind ev (weak $ Mod1 .+ '@') macroReplayKeybind -macroReplayKeybind :: (HasMacroSupport spy) => InputM spy () -macroReplayKeybind = do - ( InputKeyEvent - (KeyEvent {codepoint = cp, device = device}) - ) <- - nextInputPressEvent - replayMacro device [cp] - -startRecording :: (Wlike m) => String -> m () -startRecording ch = - xmodify - ( \m@MacrosState {macros = macros} -> - m - { macros = Map.delete ch macros, - currentlyRecording = Just ch - } - ) - -stopMacroRecording :: (Wlike m) => m () -stopMacroRecording = xmodify (\m -> m {currentlyRecording = Nothing}) - -currentlyRecordingMacro :: (Wlike m) => m (Maybe String) -currentlyRecordingMacro = xgets currentlyRecording - -replayMacro :: Ptr WlrInputDevice -> String -> InputM spy () -replayMacro inputDevice s = do - m <- liftW (Map.lookup s <$> xgets macros) - -- 'tail' is to cut off the last keystroke which stops the recording. - mapM_ (replayEvents . map toInputEvent . reverse . tail) m - where - toInputEvent :: RecordedKey -> InputEvent - toInputEvent (RecordedKey ts kc st mo keysym cp) = - InputKeyEvent $ KeyEvent ts kc st mo keysym cp inputDevice - -pushMacroKey :: (Wlike m) => KeyEvent -> m () -pushMacroKey ke = do - cur <- xgets currentlyRecording - whenJust cur $ \ch -> do - let recordedKey = toRecordedKey ke - in xmodify $ \m@MacrosState {macros = macros} -> - m {macros = Map.insertWith (++) ch [recordedKey] macros} - where - whenJust (Just a) fn = fn a - whenJust _ _ = return () - - toRecordedKey (KeyEvent ts c s m keysym cp _) = RecordedKey ts c s m keysym cp - --- | Phantom type defining a proxy required to support macros. -data MacroSupport - --- | Instance for macro support. -instance InputProxy MacroSupport where - onKeyEvent _ ie = do - lift $ whenKeyEvent ie pushMacroKey - return ie - -class HasMacroSupport t - -instance - ( If - (Find MacroSupport t) - True - ( TypeError - ( Text "This Requires the Macro Proxy to be Enabled." - :<>: Text "Please enable this by adding MacroSupport to your" - :<>: Text "inputProxies list.\n" - :<>: Text "i.e. Change " - :<>: ShowType t - :<>: Text " to " - :<>: ShowType (MacroSupport ': t) - ) - ) - ~ True - ) => - HasMacroSupport t - -instance HasMacroSupport MacroSupport diff --git a/src/Wetterhorn/Keys/MagicModifierKey.hs b/src/Wetterhorn/Keys/MagicModifierKey.hs deleted file mode 100644 index 6bc8bb3..0000000 --- a/src/Wetterhorn/Keys/MagicModifierKey.hs +++ /dev/null @@ -1,50 +0,0 @@ -module Wetterhorn.Keys.MagicModifierKey where - -import Data.Data -import Data.Default.Class -import GHC.TypeNats -import Wetterhorn.Core.KeyEvent -import Wetterhorn.Core.W -import Wetterhorn.Dsl.Bind -import Wetterhorn.Dsl.Input -import Control.Monad.RWS (MonadTrans(lift)) -import Control.Monad.Trans.Maybe (MaybeT(..)) - -data MagicModifierProxy (keycode :: Natural) inputproxy - deriving (Typeable) - -newtype MagicModifierState (keycode :: Natural) = MagicModifierState {isPressed :: Bool} - deriving (Typeable, Eq, Show, Ord, Read) - -instance Default (MagicModifierState k) where - def = MagicModifierState False - -instance (KnownNat k) => ExtensionClass (MagicModifierState k) - -instance - (KnownNat keycode, InputProxy inputproxy) => - InputProxy (MagicModifierProxy keycode inputproxy) - where - onKeyEvent proxy ie = do - case ie of - (InputKeyEvent (KeyEvent {keycode = kc, state = state})) - | fromIntegral kc == natVal (keycodeProxy proxy) -> do - lift $ setMagicModifierPressed proxy (state == KeyPressed) - MaybeT (return Nothing) - _ -> do - pressed <- lift $ isMagicModifierPressed proxy - if pressed - then onKeyEvent (Proxy :: Proxy inputproxy) ie - else return ie - where - keycodeProxy :: Proxy (MagicModifierProxy kc a) -> Proxy kc - keycodeProxy _ = Proxy - - isMagicModifierPressed p = isPressed <$> getModState p - setMagicModifierPressed p = modifyModState p . const - - getModState :: (KnownNat kc) => Proxy (MagicModifierProxy kc a) -> W (MagicModifierState kc) - getModState _ = xget - - modifyModState :: (KnownNat kc) => Proxy (MagicModifierProxy kc a) -> (MagicModifierState kc -> Bool) -> W () - modifyModState _ fn = xmodify (MagicModifierState . fn) diff --git a/src/Wetterhorn/Layout/Combine.hs b/src/Wetterhorn/Layout/Combine.hs deleted file mode 100644 index 10a0208..0000000 --- a/src/Wetterhorn/Layout/Combine.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE ViewPatterns #-} - -module Wetterhorn.Layout.Combine where - -import Data.Typeable -import Wetterhorn.Constraints -import Wetterhorn.Core.W - -data (|||) a b = Comb LR a b - deriving (Typeable, Read, Show) - -data Next = Next - deriving (Typeable) - -data Reset = Reset - deriving (Typeable) - -(|||) :: a -> b -> (a ||| b) -a ||| b = Comb L a b - -data LR = L | R deriving (Read, Show, Ord, Eq, Enum) - -instance (HandleMessage a, HandleMessage b) => HandleMessage (a ||| b) where - handleMessage (fromMessage -> Just Next) (Comb L l r) = return (Comb R l r) - handleMessage (fromMessage -> Just Reset) (Comb _ l r) = return (Comb L l r) - handleMessage mesg (Comb L l r) = - Comb L <$> handleMessage mesg l <*> pure r - handleMessage mesg (Comb R l r) = - Comb L l <$> handleMessage mesg r - -instance (LayoutClass a, LayoutClass b) => LayoutClass (a ||| b) where - -- In order to use this layout class, the lay-out type 'a' must satisfy BOTH - -- the left and right constraints. - type LayoutConstraint (a ||| b) = LayoutConstraint a &&&& LayoutConstraint b - - runLayout as (Comb R r l) = do - (r', ret) <- runLayout as r - return (Comb R r' l, ret) - runLayout as (Comb L r l) = do - (l', ret) <- runLayout as l - return (Comb R r l', ret) - - serializeLayout (Comb lr l r) = show (Comb lr (serializeLayout l) (serializeLayout r)) - readLayout str = Comb lr <$> l <*> r - where - (Comb lr (readLayout -> l) (readLayout -> r)) = read str - - description (Comb _ l r) = description l ++ " ||| " ++ description r diff --git a/src/Wetterhorn/Layout/Full.hs b/src/Wetterhorn/Layout/Full.hs deleted file mode 100644 index b7e4d91..0000000 --- a/src/Wetterhorn/Layout/Full.hs +++ /dev/null @@ -1,23 +0,0 @@ -module Wetterhorn.Layout.Full where - -import Data.Data (Typeable) -import Data.Default.Class -import Wetterhorn.Constraints -import Wetterhorn.Core.W -import Wetterhorn.StackSet - -data Full = Full - deriving (Read, Show, Typeable) - -instance Default Full where - def = Full - -instance HandleMessage Full - -instance LayoutClass Full where - type LayoutConstraint Full = Unconstrained - - runLayout = pureLayout $ \l _ -> - case l of - (focused -> Just a) -> [(a, RationalRect 1 1 1 1)] - _ -> [] diff --git a/src/Wetterhorn/StackSet.hs b/src/Wetterhorn/StackSet.hs deleted file mode 100644 index 86d1b8e..0000000 --- a/src/Wetterhorn/StackSet.hs +++ /dev/null @@ -1,210 +0,0 @@ -module Wetterhorn.StackSet where - -import Control.Monad (void) -import Data.Monoid (First(..)) -import Control.Monad.Identity -import Control.Monad.Writer (MonadWriter (tell), execWriter) -import Data.Maybe (isJust, mapMaybe) -import Data.Maybe (isJust) - --- | The root datastructure for holding the state of the windows. -data StackSet s sd t l a = StackSet - { -- | The currently selected screen. - current :: Screen s sd t l a, - -- | Remaining visible screens. - visible :: [Screen s sd t l a], - -- | Workspaces that exist, but are not on a screen. - hidden :: [Workspace t l a] - } - deriving (Read, Show, Eq, Ord, Functor) - -class TraverseWorkspace f where - traverseWorkspaces :: - (Applicative m) => (Workspace t l a -> m (Workspace t' l' a')) -> f t l a -> m (f t' l' a') - -traverseWorkspaces_ :: (TraverseWorkspace f, Monad m) => (Workspace t l a -> m ()) -> f t l a -> m () -traverseWorkspaces_ f = void . traverseWorkspaces (\w -> f w >> pure w) - -foldMapWorkspaces :: - (Monoid m, TraverseWorkspace f) => (Workspace t l a -> m) -> f t l a -> m -foldMapWorkspaces fn = execWriter . traverseWorkspaces_ (tell . fn) - -mapWorkspaces :: - (TraverseWorkspace f) => - (Workspace t l a -> Workspace t' l' a') -> - f t l a -> - f t' l' a' -mapWorkspaces fn = runIdentity . traverseWorkspaces (pure . fn) - -instance TraverseWorkspace Workspace where - traverseWorkspaces f = f - -instance TraverseWorkspace (Screen s sd) where - traverseWorkspaces f scr = (\w' -> scr {workspace = w'}) <$> f (workspace scr) - -instance TraverseWorkspace (StackSet s sd) where - traverseWorkspaces f (StackSet cur vis hid) = - StackSet - <$> traverseWorkspaces f cur - <*> traverse (traverseWorkspaces f) vis - <*> traverse (traverseWorkspaces f) hid - -instance Traversable Stack where - traverse f (Stack u d) = - Stack <$> traverse f u <*> traverse f d - -instance (TraverseWorkspace f) => Foldable (f t l) where - foldMap fn = - execWriter - . traverseWorkspaces_ (\(Workspace _ _ s) -> tell (foldMap (fn . windowInSeat) s)) - -instance (Functor (f t l), TraverseWorkspace f) => Traversable (f t l) where - sequenceA = - traverseWorkspaces $ - \(Workspace t l sf) -> Workspace t l <$> traverse sequenceA sf - -class HasFocus f where - focused :: f a -> Maybe a - -data Rectangle = Rectangle Int Int Int Int - deriving (Read, Show, Eq, Ord) - -instance HasFocus (StackSet s sd t l) where - focused (StackSet c _ _) = focused c - -data Screen s sd t l a = Screen - { screenDetail :: sd, - screenId :: s, - workspace :: Workspace t l a - } - deriving (Read, Show, Eq, Ord, Functor) - -instance HasFocus (Screen s sd t l) where - focused (Screen _ _ w) = focused w - --- | Defines where a window should appear. -data WindowSeat a = Floating Rectangle a | Tiled a - deriving (Read, Show, Eq, Ord, Functor, Foldable) - -windowInSeat :: WindowSeat a -> a -windowInSeat (Floating _ a) = a -windowInSeat (Tiled a) = a - -instance Traversable WindowSeat where - sequenceA (Floating r fa) = Floating r <$> fa - sequenceA (Tiled fa) = Tiled <$> fa - -instance HasFocus WindowSeat where - focused (Floating _ a) = Just a - focused (Tiled a) = Just a - -data Workspace t l a = Workspace - { tag :: t, - layout :: l, - stack :: Stack (WindowSeat a) - } - deriving (Read, Show, Eq, Ord, Functor) - -instance HasFocus (Workspace t l) where - focused (Workspace _ _ s) = windowInSeat <$> focused s - -data Stack a = Stack - { -- | The elements above the focused one. - up :: ![a], - -- | The elements below the focused one including the focused one itself. - down :: ![a] - } - deriving (Read, Show, Eq, Ord, Functor, Foldable) - -instance HasFocus Stack where - focused (Stack _ (a : _)) = Just a - focused _ = Nothing - --- | Change the tag in a structure. -mapTag :: (TraverseWorkspace f) => (t -> t') -> f t l a -> f t' l a -mapTag fn = mapWorkspaces (\w -> w {tag = fn (tag w)}) - --- | Change the layout in a structure. -mapLayout :: (TraverseWorkspace f) => (l -> l') -> f t l a -> f t l' a -mapLayout fn = mapWorkspaces (\w -> w {layout = fn (layout w)}) - --- | Return all the tags in a structure. -tags :: (TraverseWorkspace f) => f t l a -> [t] -tags = foldMapWorkspaces ((: []) . tag) - --- | Insert a new window into the StackSet. The optional rectangle indicates if --- the window should be floating or tiled. --- --- The window is inserted just above the the currently focused window and is --- given focus. -insert :: a -> Maybe Rectangle -> StackSet s sd t l a -> StackSet s sd t l a -insert win rect = - runIdentity - . onCurrentStack - ( \(Stack u d) -> - return $ - (\w -> Stack u (w : d)) $ - maybe (Tiled win) (`Floating` win) rect - ) - --- | Find the tag associated with a window. -findTag :: (TraverseWorkspace f, Eq a) => a -> f t l a -> Maybe t -findTag a = - getFirst - . foldMapWorkspaces - ( \ws -> - foldMap - ( \a' -> - First $ if a' == a then Just (tag ws) else Nothing - ) - ws - ) - --- | Return true if the window exist in a structure -elem :: (TraverseWorkspace f, Eq a) => a -> f t l a -> Bool -elem a = isJust . findTag a - --- | Convenience function for inserting a window in stack set tiled. -insertTiled :: a -> StackSet s sd t l a -> StackSet s sd t l a -insertTiled win = insert win Nothing - -integrate :: Stack a -> [a] -integrate (Stack u d) = u ++ d - -differentiate :: [a] -> Stack a -differentiate = Stack [] - -applyStack :: - (Monad m) => - (Stack (WindowSeat a) -> m (Stack (WindowSeat a))) -> - Workspace t l a -> - m (Workspace t l a) -applyStack fn (Workspace t l s) = Workspace t l <$> fn s - --- | Apply a function to the currently focused stack. -onCurrentStack :: - (Monad m) => - (Stack (WindowSeat a) -> m (Stack (WindowSeat a))) -> - StackSet s sd t l a -> - m (StackSet s sd t l a) -onCurrentStack fn (StackSet cur vis hid) = - StackSet <$> cur' cur <*> pure vis <*> pure hid - where - cur' (Screen s sd ws) = Screen s sd <$> ws' ws - ws' (Workspace t l s) = Workspace t l <$> fn s - -catMaybes :: StackSet s sd t l (Maybe a) -> StackSet s sd t l a -catMaybes (StackSet cur hidden visible) = - StackSet (catMaybesS cur) (map catMaybesS hidden) (map catMaybesW visible) - where - catMaybesS (Screen a b ws) = Screen a b $ catMaybesW ws - catMaybesW (Workspace a b st) = Workspace a b $ catMaybesSt st - catMaybesSt (Stack up down) = - Stack (mapMaybe sequenceA up) (mapMaybe sequenceA down) - -filter :: (a -> Bool) -> StackSet s sd t l a -> StackSet s sd t l a -filter ffn = - Wetterhorn.StackSet.catMaybes . fmap (\a -> if ffn a then Just a else Nothing) - -delete :: (Eq a) => a -> StackSet s sd t l a -> StackSet s sd t l a -delete win = Wetterhorn.StackSet.filter (/=win) diff --git a/src/harness_adapter.c b/src/harness_adapter.c deleted file mode 100644 index 24b813c..0000000 --- a/src/harness_adapter.c +++ /dev/null @@ -1,81 +0,0 @@ -// This file provides functions for the wetterhorn harness that are not -// expressible directly in haskell. -// -// Currently these functions exclusively enable/disable the Haskell runtime. - -#include "HsFFI.h" -#include "plugin_interface.h" -#include -#include -#include - -const char *plugin_name = "Wetterhorn"; - -void* foreign_interface; - -void* get_foreign_interface() -{ - return foreign_interface; -} - -extern void performMajorGC(); - -void plugin_metaload(int argc, char** argv) -{ - // hs_init(&argc, &argv); -} - -void plugin_load(int argc, char **argv, foreign_interface_t* fintf) { - hs_init(&argc, &argv); - foreign_interface = fintf; -} - -void plugin_teardown(opqst_t st) { - hs_exit(); -} - -void shell_exec(const char* cmd) { - if (fork() == 0) { - execl("/bin/sh", "/bin/sh", "-c", cmd, NULL); - exit(1); - } -} - -static const char msg[] = - "Wetterhorn Plugin v 0.01\n\n" - "Welcome, and thank you for your interest.\n\n" - "This is merely a plugin to the Wetterhorn Compositor and not meant to be\n" - "executed as a standalone binary. This plugin requires a harness to run\n" - "To use this file, please use './wtr_harness [full-path-to-wtr.so]'\n" - "That will allow you to see how this compositor works in all its glory!\n"; -static const int msg_sz = sizeof(msg); - -/* - * Implemens a basic _start that prints inforamtion and exits for users on an - * x86_64 system. - */ -__attribute__((naked)) void _start() -{ - - // Make system call to print the message - asm( - // Load the address of the string into rsi - "mov %0, %%rsi\n" - // Load the string length into edx - "mov %1, %%edx\n" - // Load the file descriptor for stdout into edi - "mov $1, %%edi\n" - // Load the syscall number for sys_write into eax - "mov $1, %%eax\n" - // Make the syscall - "syscall\n" - - // Exit the program. - "mov $0, %%rdi\n" - "mov $60, %%rax\n" - "syscall\n" - : - : "r"(msg), "r"(msg_sz) // Input: address of msg - : "%rsi", "%edx", "%edi" // Clobbered registers - ); -} diff --git a/stack.yaml b/stack.yaml deleted file mode 100644 index b66ae37..0000000 --- a/stack.yaml +++ /dev/null @@ -1,67 +0,0 @@ -# This file was automatically generated by 'stack init' -# -# Some commonly used options have been documented as comments in this file. -# For advanced use and comprehensive documentation of the format, please see: -# https://docs.haskellstack.org/en/stable/yaml_configuration/ - -# Resolver to choose a 'specific' stackage snapshot or a compiler version. -# A snapshot resolver dictates the compiler version and the set of packages -# to be used for project dependencies. For example: -# -resolver: lts-22.12 -# ghc-9.6.4 -# lts-21.21 -# resolver: nightly-2023-09-24 -# resolver: ghc-9.6.2 -# -# The location of a snapshot can be provided as a file or url. Stack assumes -# a snapshot provided as a file might change, whereas a url resource does not. -# -# resolver: ./custom-snapshot.yaml -# resolver: https://example.com/snapshots/2023-01-01.yaml - -# User packages to be built. -# Various formats can be used as shown in the example below. -# -# packages: -# - some-directory -# - https://example.com/foo/bar/baz-0.0.2.tar.gz -# subdirs: -# - auto-update -# - wai -packages: -- . -# Dependency packages to be pulled from upstream that are not in the resolver. -# These entries can reference officially published versions as well as -# forks / in-progress versions pinned to a git hash. For example: -# -# extra-deps: -# - acme-missiles-0.3 -# - git: https://github.com/commercialhaskell/stack.git -# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# -# extra-deps: [] - -# Override default flag values for local packages and extra-deps -# flags: {} - -# Extra package databases containing global packages -# extra-package-dbs: [] - -# Control whether we use the GHC we find on the path -# system-ghc: true -# -# Require a specific version of Stack, using version ranges -# require-stack-version: -any # Default -# require-stack-version: ">=2.13" -# -# Override the architecture used by Stack, especially useful on Windows -# arch: i386 -# arch: x86_64 -# -# Extra directories used by Stack for building -# extra-include-dirs: [/path/to/dir] -# extra-lib-dirs: [/path/to/dir] -# -# Allow a newer minor version of GHC than the snapshot specifies -# compiler-check: newer-minor diff --git a/test/Spec.hs b/test/Spec.hs deleted file mode 100644 index cd4753f..0000000 --- a/test/Spec.hs +++ /dev/null @@ -1,2 +0,0 @@ -main :: IO () -main = putStrLn "Test suite not yet implemented" -- cgit