├── .clang-format ├── .dockerignore ├── .editorconfig ├── .github └── workflows │ └── test.yml ├── .gitignore ├── .gitmodules ├── .guix └── modules │ ├── mahogany-package.scm │ └── test-system.scm ├── CONTRIBUTING.md ├── Dockerfile ├── LICENSE ├── Makefile ├── README.org ├── build-mahogany.lisp ├── doc ├── configuration.org ├── default-apps.org ├── devel │ ├── features.md │ ├── frame-tree.org │ └── proposal │ │ ├── frames.org │ │ └── initial-plan.org └── focus.org ├── guix.scm ├── heart ├── .editorconfig ├── .gitignore ├── README.md ├── example │ ├── main.c │ └── meson.build ├── include │ ├── hrt │ │ ├── hrt_input.h │ │ ├── hrt_output.h │ │ ├── hrt_server.h │ │ └── hrt_view.h │ ├── meson.build │ ├── view_impl.h │ └── xdg_impl.h ├── meson.build ├── meson_options.txt ├── protocols │ ├── meson.build │ └── wlr-output-management-unstable-v1.xml └── src │ ├── cursor.c │ ├── input.c │ ├── keyboard.c │ ├── meson.build │ ├── output.c │ ├── output_methods.c │ ├── seat.c │ ├── server.c │ ├── view.c │ └── xdg_shell.c ├── lisp ├── bindings │ ├── hrt-bindings.lisp │ ├── hrt-bindings.yml │ ├── hrt-libs.lisp │ ├── package.lisp │ ├── wlr-bindings.lisp │ ├── wlr-bindings.yml │ └── wrappers.lisp ├── config │ └── config-system.lisp ├── globals.lisp ├── group.lisp ├── input.lisp ├── interfaces │ └── view-interface.lisp ├── key-bindings.lisp ├── keyboard │ ├── key.lisp │ ├── keytrans.lisp │ ├── kmap.lisp │ └── package.lisp ├── log.lisp ├── main.lisp ├── objects.lisp ├── output.lisp ├── package.lisp ├── ring-list │ └── ring-list.lisp ├── state.lisp ├── system.lisp ├── tree │ ├── frame.lisp │ ├── output-node.lisp │ ├── package.lisp │ ├── tree-interface.lisp │ └── view.lisp ├── util.lisp └── view.lisp ├── mahogany-test.asd ├── mahogany.asd ├── run-tests.lisp └── test ├── config-system-tests.lisp ├── keyboard-tests.lisp ├── log-tests.lisp ├── mahogany-test.lisp ├── ring-list.lisp └── tree-tests.lisp /.clang-format: -------------------------------------------------------------------------------- 1 | Language: Cpp 2 | BasedOnStyle: LLVM 3 | 4 | AccessModifierOffset: -2 5 | AlignAfterOpenBracket: Align 6 | AlignConsecutiveMacros: true 7 | AlignConsecutiveAssignments: true 8 | AlignEscapedNewlines: Right 9 | AlignOperands: false 10 | AlignTrailingComments: true 11 | AllowAllArgumentsOnNextLine: true 12 | AllowAllConstructorInitializersOnNextLine: true 13 | AllowAllParametersOfDeclarationOnNextLine: true 14 | AllowShortBlocksOnASingleLine: true 15 | AllowShortCaseLabelsOnASingleLine: true 16 | AllowShortFunctionsOnASingleLine: Empty 17 | AllowShortIfStatementsOnASingleLine: Never 18 | AllowShortLambdasOnASingleLine: All 19 | AllowShortLoopsOnASingleLine: false 20 | AlwaysBreakAfterDefinitionReturnType: None 21 | AlwaysBreakAfterReturnType: None 22 | AlwaysBreakBeforeMultilineStrings: false 23 | AlwaysBreakTemplateDeclarations: Yes 24 | BreakBeforeBraces: Attach 25 | BreakBeforeTernaryOperators: false 26 | BreakConstructorInitializers: AfterColon 27 | ColumnLimit: 80 28 | CompactNamespaces: false 29 | ConstructorInitializerAllOnOneLineOrOnePerLine: false 30 | ExperimentalAutoDetectBinPacking: false 31 | FixNamespaceComments: false 32 | IncludeBlocks: Preserve 33 | IndentCaseLabels: true 34 | IndentWidth: 4 35 | PointerAlignment: Right 36 | ReflowComments: false 37 | SortIncludes: false 38 | SortUsingDeclarations: false 39 | SpaceAfterCStyleCast: false 40 | SpaceAfterLogicalNot: false 41 | SpaceAfterTemplateKeyword: true 42 | SpaceBeforeCtorInitializerColon: true 43 | SpaceBeforeInheritanceColon: true 44 | SpaceBeforeParens: ControlStatements 45 | SpaceBeforeRangeBasedForLoopColon: true 46 | SpaceInEmptyParentheses: false 47 | SpacesBeforeTrailingComments: 1 48 | SpacesInAngles: false 49 | SpacesInCStyleCastParentheses: false 50 | SpacesInContainerLiterals: false 51 | SpacesInParentheses: false 52 | SpacesInSquareBrackets: false 53 | Standard: Auto 54 | TabWidth: 4 55 | UseTab: Never 56 | 57 | AllowShortEnumsOnASingleLine: false 58 | 59 | BraceWrapping: 60 | AfterEnum: false 61 | 62 | # AlignConsecutiveDeclarations: AcrossEmptyLines 63 | 64 | NamespaceIndentation: All -------------------------------------------------------------------------------- /.dockerignore: -------------------------------------------------------------------------------- 1 | build 2 | heart/build -------------------------------------------------------------------------------- /.editorconfig: -------------------------------------------------------------------------------- 1 | 2 | [*] 3 | end_of_line = lf 4 | charset = utf8 5 | trim_trailing_whitespace = true -------------------------------------------------------------------------------- /.github/workflows/test.yml: -------------------------------------------------------------------------------- 1 | name: Build and Test 2 | 3 | on: 4 | push: 5 | branches: master 6 | pull_request: 7 | 8 | jobs: 9 | build_and_test: 10 | runs-on: ubuntu-latest 11 | steps: 12 | - uses: actions/checkout@v2 13 | - name: build 14 | run: git submodule update --init --recursive && docker build . --file Dockerfile -t mahogany 15 | # - name: Test 16 | # run: docker run stumpwm make test 17 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # ignore some stuff generated by emacs: 2 | *~ 3 | \#*\# 4 | *.#* 5 | /.emacs.desktop 6 | /.emacs.desktop.lock 7 | 8 | # ignore generated files in the doc directory 9 | doc/*.tex 10 | doc/*.pdf 11 | 12 | # don't know what these files are, but we don't want them in the repo: 13 | *.whl 14 | 15 | # Build artifacts: 16 | build/ 17 | 18 | # C language Server cache: 19 | .ccls-cache 20 | .cache 21 | 22 | compile_commands.json -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "heart/wlroots"] 2 | path = heart/subprojects/wlroots 3 | url = https://gitlab.freedesktop.org/wlroots/wlroots.git 4 | [submodule "dependencies/cl-wayland"] 5 | path = dependencies/cl-wayland 6 | url = https://github.com/sdilts/cl-wayland.git 7 | [submodule "dependencies/cl-xkbcommon"] 8 | path = dependencies/cl-xkbcommon 9 | url = https://github.com/sdilts/cl-xkbcommon.git 10 | -------------------------------------------------------------------------------- /.guix/modules/mahogany-package.scm: -------------------------------------------------------------------------------- 1 | ;;; Mahogany --- StumpWM-like window manager written for Wayland 2 | ;;; Copyright © 2023 Raven Hallsby 3 | ;;; 4 | ;;; This file is part of Mahogany. 5 | ;;; 6 | 7 | ;;; Commentary: 8 | ;; 9 | ;; GNU Guix development package. To build and install, run: 10 | ;; 11 | ;; guix package -f guix.scm 12 | ;; 13 | ;; To use as the basis for a development environment, run: 14 | ;; 15 | ;; guix shell -D -f guix.scm 16 | ;; 17 | ;;; Code: 18 | 19 | (define-module (mahogany-package) 20 | #:use-module (guix packages) 21 | #:use-module (guix gexp) 22 | #:use-module (guix git-download) 23 | #:use-module (guix build-system meson) 24 | #:use-module (guix build-system asdf) 25 | #:use-module (guix utils) 26 | #:use-module ((guix licenses) #:prefix license:) 27 | #:use-module (gnu packages autotools) 28 | #:use-module (gnu packages pkg-config) 29 | #:use-module (gnu packages build-tools) 30 | #:use-module (gnu packages freedesktop) 31 | #:use-module (gnu packages lisp-check) 32 | #:use-module (gnu packages lisp-check) 33 | #:use-module (gnu packages lisp-xyz) 34 | #:use-module (gnu packages texinfo) 35 | #:use-module (gnu packages xdisorg) 36 | #:use-module (gnu packages wm)) 37 | 38 | (define vcs-file? 39 | ;; Return true if the given file is under version control. 40 | (or (git-predicate (string-append (current-source-directory) "/../..")) 41 | (const #t))) ;not in a Git checkout 42 | 43 | (define-public mahogany 44 | (package 45 | (name "mahogany") 46 | (version (git-version "0.0.0" "0" "000000000000000000000000000000000000000000")) 47 | (source (local-file "../.." "mahogany-checkout" 48 | #:recursive? #t 49 | #:select? vcs-file?)) 50 | (build-system asdf-build-system/sbcl) 51 | (native-inputs 52 | (list sbcl-fiasco 53 | sbcl-prove)) 54 | (inputs 55 | (list mahogany-heart 56 | sbcl-xkbcommon 57 | libxkbcommon 58 | sbcl-cl-wayland 59 | sbcl-alexandria 60 | sbcl-cl-ansi-text 61 | sbcl-terminfo 62 | sbcl-snakes 63 | sbcl-iterate 64 | sbcl-cffi ;; Provides cffi-grovel 65 | wayland 66 | wayland-protocols 67 | wlroots)) 68 | (outputs '("out" "lib")) 69 | (arguments 70 | (list 71 | #:phases 72 | #~(modify-phases %standard-phases 73 | (add-after 'unpack 'delete-submodules 74 | (lambda* (#:key outputs #:allow-other-keys) 75 | (delete-file-recursively "./dependencies") 76 | (delete-file-recursively "./heart"))) 77 | (add-after 'delete-submodules 'fix-paths 78 | (lambda* (#:key inputs #:allow-other-keys) 79 | (substitute* "lisp/bindings/hrt-libs.lisp" 80 | (("libheart.so") 81 | (search-input-file inputs 82 | "/lib/libheart.so")) 83 | (("libwlroots.so") 84 | (search-input-file inputs 85 | "/lib/libwlroots.so"))))) 86 | (add-after 'create-asdf-configuration 'build-program 87 | (lambda* (#:key outputs #:allow-other-keys) 88 | (build-program 89 | (string-append (assoc-ref outputs "out") "/bin/mahogany") 90 | outputs 91 | #:entry-program '((mahogany::run-server) 0)))) 92 | (add-after 'build-program 'create-desktop-file 93 | (lambda* (#:key outputs #:allow-other-keys) 94 | (let* ((out (assoc-ref outputs "out")) 95 | (xsessions (string-append out "/share/xsessions")) 96 | (wayland-sessions (string-append out "/share/wayland-sessions"))) 97 | (define (desktop-file file) 98 | (format file 99 | "[Desktop Entry]~@ 100 | Name=mahogany~@ 101 | Comment=The Mahogany Window Manager~@ 102 | Exec=~a/bin/mahogany~@ 103 | TryExec=~@*~a/bin/mahogany~@ 104 | Icon=~@ 105 | Type=Application~%" 106 | out)) 107 | (mkdir-p xsessions) 108 | (call-with-output-file 109 | (string-append xsessions "/mahogany.desktop") 110 | desktop-file) 111 | (mkdir-p wayland-sessions) 112 | (call-with-output-file 113 | (string-append wayland-sessions "/mahogany.desktop") 114 | desktop-file))))))) 115 | (synopsis "Window manager for Wayland written in Common Lisp") 116 | (description 117 | "Mahogany is a tiling window manager for Wayland modeled after StumpWM. 118 | While it is not a drop-in replacement for stumpwm, stumpwm users should be 119 | very comfortable with Mahogany.") 120 | (home-page "https://github.com/stumpwm/mahogany") 121 | (license license:gpl2+))) 122 | 123 | (define-public mahogany-heart 124 | (package 125 | (name "mahogany-heart") 126 | (version (package-version mahogany)) 127 | (source (package-source mahogany)) 128 | (build-system meson-build-system) 129 | (native-inputs 130 | (list pkg-config)) 131 | (inputs 132 | (list wlroots 133 | libxkbcommon)) 134 | (arguments 135 | (list 136 | #:phases 137 | #~(modify-phases %standard-phases 138 | (add-after 'unpack 'chdir 139 | (lambda _ (chdir "heart"))) 140 | (add-after 'chdir 'delete-submodules 141 | (lambda* (#:key outputs #:allow-other-keys) 142 | (delete-file-recursively "./subprojects")))))) 143 | (synopsis "An alternative C backend to a Wayland compositor to use with Mahogany") 144 | (description 145 | "Mahogany-heart's task is to setup the initial state of the 146 | compositor, render the output, and initially handle new connections to 147 | the compositor. If needed, the backend will also wrap some wlroots 148 | functions so that less foreign code needs to be called from the other 149 | language. is a tiling window manager for Wayland modeled after 150 | StumpWM.") 151 | (home-page (package-home-page mahogany)) 152 | (license (package-license mahogany)))) 153 | 154 | mahogany 155 | -------------------------------------------------------------------------------- /.guix/modules/test-system.scm: -------------------------------------------------------------------------------- 1 | (define-module (test-system) 2 | #:use-module (guix gexp) 3 | #:use-module (gnu) 4 | #:use-module (gnu packages base) 5 | #:use-module (gnu packages linux) 6 | #:use-module (gnu system) 7 | #:use-module (gnu tests) 8 | #:use-module (gnu services desktop) 9 | #:use-module (mahogany-package)) 10 | 11 | (operating-system 12 | (inherit %simple-os) 13 | (users (cons (user-account 14 | (name "alice") 15 | (comment "Bob's sister") 16 | (group "users") 17 | (supplementary-groups 18 | '("wheel" "audio" "video" 19 | ;; seatd needs the user to be part of seat group 20 | "seat"))) 21 | %base-user-accounts)) 22 | (packages 23 | (list coreutils ; Things like ls 24 | procps ; For ps 25 | grep ; For grep 26 | mahogany)) 27 | (services 28 | (append 29 | (list 30 | (service seatd-service-type)) 31 | %base-services))) 32 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributing to Mahogany 2 | 3 | Want to make a change? All you need to do is submit a pull request! 4 | This document provides some suggestions and recommendations that will 5 | make your contribution more successful. 6 | 7 | ## Git Commit messages 8 | 9 | Try to write a [good commit message](https://cbea.ms/git-commit/). 10 | In short: 11 | + The first line of the message shouldn't be more than 50 characters 12 | wide 13 | + The second line should be blank. 14 | + The message should complete the sentence "Applying this commit will ..." 15 | + Explain why the change is needed, not how it works, athough that 16 | can be helpful too. 17 | 18 | A useful trick to writing more consise messages is to include a prefix 19 | that indicates what part of the application you are working on. For 20 | example: 21 | + `Backend: rig up wayland protocol` 22 | + `frames: fix frame alignment` 23 | 24 | ## Submitting Pull Requests 25 | 26 | When submitting a pull request, try to do the following things: 27 | + Reference an issue if there is a relevant one. 28 | + For significant changes, create an issue first to discuss the 29 | implementation and how it fits in with the rest of the project. 30 | + Ensure your branch is rebased upon the lastest commit. 31 | 32 | ## Additional Tools 33 | 34 | If you are changing the C back end's user interface, you will need 35 | [cl-bindgen](https://github.com/sdilts/cl-bindgen) to generate the 36 | lisp interface. 37 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM fedora:latest 2 | 3 | ENV HOME /root/ 4 | 5 | RUN dnf -y install dnf-plugins-core sbcl curl make redhat-rpm-config 6 | RUN dnf -y builddep wlroots 7 | 8 | RUN curl -O https://beta.quicklisp.org/quicklisp.lisp \ 9 | && sbcl --noinform --load quicklisp.lisp --eval "(quicklisp-quickstart:install)" \ 10 | && sbcl --noinform --load "/root/quicklisp/setup.lisp" --eval "(progn (setf ql-util::*do-not-prompt* t)(ql:add-to-init-file))" \ 11 | && sbcl --noinform --eval "(ql:quickload '("alexandria" "cl-ansi-text" "terminfo" "snakes" "iterate" "cffi" "cffi-grovel" "closer-mop" "cl-argparse"))" \ 12 | && sbcl --noinform --eval "(ql:quickload '("fiasco"))" 13 | 14 | COPY . . 15 | 16 | # RUN git submodule init 17 | RUN make && make test 18 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | ccl = cat $(1) | ccl -b 2 | 3 | sbcl = sbcl --non-interactive --load $(1) 4 | 5 | LISP=sbcl 6 | 7 | ROOT := $(shell pwd) 8 | BUILD_DIR := $(shell pwd)/build 9 | # In order to not watch heart build files but still detect fresh builds, 10 | # use files in the internal directory as as placeholder: 11 | CACHE := $(BUILD_DIR)/internal 12 | 13 | # We actually want to watch the build output (build/include/hrt), but those files 14 | # might not exist 15 | HRT_INCLUDES = $(shell find $(ROOT)/heart/include/hrt/ -type f) 16 | # WLR_INCLUDES = $(shell find $(ROOT)/heart/subprojects/wlroots/include/wlr/ -type f) 17 | 18 | $(BUILD_DIR)/mahogany: $(BUILD_DIR)/heart/lib64/libheart.so lisp/bindings/hrt-bindings.lisp lisp/bindings/wlr-bindings.lisp build-mahogany.lisp FORCE 19 | $(call $(LISP), build-mahogany.lisp) 20 | 21 | lisp/bindings/hrt-bindings.lisp: $(ROOT)/lisp/bindings/hrt-bindings.yml $(HRT_INCLUDES) 22 | cl-bindgen b lisp/bindings/hrt-bindings.yml 23 | 24 | lisp/bindings/wlr-bindings.lisp: $(ROOT)/lisp/bindings/wlr-bindings.yml 25 | cl-bindgen b lisp/bindings/wlr-bindings.yml 26 | 27 | $(BUILD_DIR)/heart/lib64/libheart.so: $(CACHE)/wlroots-configured FORCE 28 | ninja -C $(BUILD_DIR)/heart 29 | # FIXME?: move the api headers into a separate directory and just use those instead of calling install: 30 | ninja -C $(BUILD_DIR)/heart install > $(BUILD_DIR)/install_output.txt 31 | 32 | $(CACHE)/wlroots-configured: 33 | mkdir -p $(BUILD_DIR)/heart && meson setup $(BUILD_DIR)/heart heart/ -Dprefix=$(BUILD_DIR) -Dlibdir=lib 34 | mkdir -p $(CACHE) 35 | touch $(CACHE)/wlroots-configured 36 | 37 | run: $(BUILD_DIR)/mahogany 38 | LD_LIBRARY_PATH=build/lib/ ./build/mahogany 39 | 40 | clean: FORCE 41 | ninja -C $(BUILD_DIR)/heart clean 42 | rm -f $(BUILD_DIR)/mahogany 43 | rm -rf $(BUILD_DIR)/lib64 44 | rm -rf $(BUILD_DIR)/include 45 | rm -rf $(BUILD_DIR)/install_output.txt 46 | 47 | test: $(BUILD_DIR)/heart/lib64/libheart.so 48 | $(call $(LISP),run-tests.lisp) 49 | 50 | FORCE: ; 51 | -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | * Mahogany 2 | Mahogany is a tiling window manager for Wayland modeled after 3 | StumpWM. While it is not a drop-in replacement for stumpwm, stumpwm 4 | users should be very comfortable with Mahogany. Its planned 5 | features are: 6 | + Easy extensibility: through the use of different modes, users can 7 | modify keybindings present in Mahogany. 8 | + Module system that allows users to load and use code at their 9 | discretion. 10 | + Programs to interact with other running services such as 11 | pulseaudio and alsamixer, as well as facilities to control screen 12 | brightness. These are module based, so they don't have to be 13 | loaded if your system doesn't use them. 14 | + Good support for floating windows. 15 | + A configuration system using Common Lisp. 16 | 17 | This branch contains a version of Mahogany using a backend written 18 | in C. The old version written entirely in Common Lisp can be found in 19 | the [[https://github.com/stumpwm/mahogany/tree/full-cl-old][full-cl-old]] branch. 20 | 21 | ** Contributing / Hacking 22 | 23 | Mahogany is still in an early stage of development. See the 24 | [[https://github.com/stumpwm/mahogany/milestones][list of milestones]] 25 | for features or work that is ready to be started. You can also browse the 26 | issue list for labels marked with 27 | [[https://github.com/stumpwm/mahogany/labels/good%20first%20issue][Good First Issue]]. 28 | 29 | In general, if it's in stumpwm and you want it, we will consider adding it. Create 30 | an issue for the issue tracker so we can plan on how to get it done. 31 | 32 | Before writing code, please look at [[CONTRIBUTING.md][CONTRIBUTING.md]] 33 | 34 | ** Building 35 | There are two parts to Mahogany: a backend library implemented in C, and 36 | the Common Lisp front end. Thus, you will need the following tools: 37 | + A C compiler (tested with GCC and clang) 38 | + Steel Bank Common Lisp 39 | + GNU Make 40 | + Meson 41 | 42 | Several dependencies are shipped with Mahogany as git 43 | submodules. To download them, run the following git command: 44 | 45 | #+BEGIN_SRC 46 | git submodule update --init 47 | #+END_SRC 48 | 49 | To see a full example of this process, see the 50 | [[https://github.com/stumpwm/mahogany/blob/master/Dockerfile][CI's Dockerfile]] 51 | 52 | *** Backend Library Dependencies 53 | The backend library requires wlroots 0.18.x. This 54 | version is included as a git submodule and is used by 55 | default. See the README in the submodule or consult 56 | the [[https://gitlab.freedesktop.org/wlroots/wlroots/-/tree/0.18.2?ref_type=tags][project's git repo]] 57 | on how to build it. 58 | 59 | While it is possible to use a prebuilt version of wlroots installed by 60 | other means, it is currently not supported by directly invoking =make= 61 | like these instructions suggest. (See [[https://github.com/stumpwm/mahogany/issues/80][#80]]) 62 | 63 | *** Common Lisp Dependencies 64 | You will need a Common Lisp implementation. While it should run on any 65 | version that the CFFI library supports, SBCL and CCL are supported. 66 | 67 | The recommended way to install the dependencies is using 68 | Quicklisp. Follow the instructions at https://www.quicklisp.org/ to 69 | install it. 70 | 71 | Once downloaded, install the dependencies: 72 | #+BEGIN_SRC lisp 73 | (ql:quickload '("alexandria" "cl-ansi-text" "terminfo" "cl-argparse" 74 | "snakes" "iterate" "cffi" "cffi-grovel" "closer-mop")) 75 | #+END_SRC 76 | 77 | *** Building And Running 78 | At this point, all of the dependencies should be installed. You can 79 | now run =make= in the root directory of the project to build the C 80 | backend and the mahogany executable. 81 | #+BEGIN_SRC sh 82 | make 83 | # if success, run the program! 84 | make run 85 | # Can also do: 86 | LD_LIBRARY_PATH=build/lib64:build/lib ./build/mahogany 87 | #+END_SRC 88 | 89 | If you want to build mahogany (or execute any of the other build 90 | commands) with CCL, you can do so by specifying CCL when invoking 91 | make: 92 | #+BEGIN_SRC sh 93 | make LISP=ccl 94 | #+END_SRC 95 | 96 | It is possible to run mahogany in an X11 or Wayland session, and is 97 | the recommended method of testing at this time. If you do choose to 98 | run the program in a TTY, press the =ESC= key to exit. 99 | -------------------------------------------------------------------------------- /build-mahogany.lisp: -------------------------------------------------------------------------------- 1 | (require 'asdf) 2 | 3 | ;; See https://asdf.common-lisp.dev/asdf.html#Configuration-DSL-1 4 | ;; for what this is doing. 5 | ;; Basically, we want our local copies of dependencies in the dependencies folder 6 | ;; to be used instead of anything that asdf can find in our environment 7 | (asdf:initialize-source-registry 8 | `(:source-registry 9 | (:directory ,(uiop/os:getcwd)) 10 | (:tree ,(merge-pathnames (uiop/os:getcwd) #P"dependencies")) 11 | ;; Use whatever the user has configured in their environment to find the rest. 12 | :inherit-configuration)) 13 | 14 | ;; (asdf:find-system "mahogany/executable") 15 | ;; (asdf:clear-configuration) 16 | 17 | (declaim (optimize (debug 3))) 18 | 19 | (asdf:make "mahogany/executable") 20 | -------------------------------------------------------------------------------- /doc/configuration.org: -------------------------------------------------------------------------------- 1 | #+TITLE: Configuration 2 | 3 | Mahogany is configured by setting various properties via Common Lisp 4 | code. To get the full list of available properties, evaluate the 5 | function =describe-all-config-info=: 6 | 7 | #+BEGIN_SRC lisp 8 | (config-system:describe-all-config-info) 9 | #+END_SRC 10 | 11 | You can specify a regex to search by name or package using keyword parameters: 12 | 13 | #+BEGIN_SRC lisp 14 | (config-system:describe-all-config-info :name-matches ".*" :package-matches ".*") 15 | #+END_SRC 16 | 17 | ** Setting Configuration Properties 18 | 19 | Mahogany configuration properties are regular dynamically-scoped 20 | variables, and can be set as such. However, they are strongly typed, 21 | and it is recommended to use the various setter macros that are 22 | available to avoid causing problems with the system. 23 | 24 | *** =set-config= 25 | The macro =set-config= works the same as =setf=, and sets each 26 | property given to it sequentially: 27 | 28 | #+BEGIN_SRC lisp 29 | (set-config property-1 val-1 30 | property-2 val-2) 31 | #+END_SRC 32 | 33 | *** =with-atomic-update= 34 | This macro will reset the given properties to their value before the 35 | form if an error occurs while it is being executed. 36 | 37 | #+BEGIN_SRC lisp 38 | (with-atomic-update (property-1 property-2) 39 | (set-config property-1 val-1)) 40 | ;; property-1 has the value val-1 here 41 | (with-atomic-update (property-1 property-2) 42 | (set-config property-1 val-2) 43 | (error "error")) 44 | ;; property-1 still has value val-1 here 45 | #+END_SRC 46 | 47 | *** =set-config-atomic= 48 | Sets the given variables to the given values, but set them back to 49 | their original values if an error occurs during the form's execution. 50 | 51 | #+BEGIN_SRC lisp 52 | (set-config-atomic prop-1 val-1 53 | prop-2 val-2) 54 | #+END_SRC 55 | 56 | ** Error Handling 57 | 58 | While setting a configuration property through the macros above, there 59 | are two possible errors that can occur. 60 | 61 | *** =config-not-found-error= 62 | This error is signaled when the specified configuration property does 63 | not exist. 64 | 65 | *** =invalid-datum-error= 66 | This error occurs when an attempt is made to set a configuration 67 | property to a value that is not allowed. 68 | -------------------------------------------------------------------------------- /doc/default-apps.org: -------------------------------------------------------------------------------- 1 | #+TITLE: Default Applications 2 | 3 | Mahogany assumes several applications are installed by default. This 4 | is a guide on how to customize those applications. 5 | 6 | ** Terminal Emulator 7 | 8 | Mahogany has a function called =open-terminal= that opens a terminal 9 | emulator. It uses the following scheme to find the right one to open: 10 | 1. Examines the =$TERMINAL= environment variable. If it has a value 11 | and a corresponding executable on =$PATH=, it uses that 12 | application. 13 | 2. Goes through the following list of common terminal apps and tries 14 | to open them in order: 15 | 1. konsole 16 | 2. gnome-terminal 17 | 3. wezterm 18 | 4. foot 19 | -------------------------------------------------------------------------------- /doc/devel/features.md: -------------------------------------------------------------------------------- 1 | # Features 2 | This document describes the planned features of Mahogany. If you would like to suggest 3 | something, please submit a pull request adding it to this document, or create a new issue. 4 | 5 | Please include the following information: 6 | 1. Is this feature already present in Stumpwm? 7 | + If so, is there anything about the functionality in Stumpwm that can be improved? 8 | + If not, does it replace one of StumpWM's features, or is it entirely new? 9 | 2. If it is a new or controversial feature, why should it be included? 10 | 11 | If there is something that is included in StumpWM that has caused problems in the past, it may also be worth adding under the 12 | [Features that shouldn't be included](#Features-that-shouldn't-be-included) section. 13 | 14 | ## Features that are in StumpWM 15 | + Tiling and Floating Windows 16 | + Automatically make some windows floating (see how i3/Sway does it) 17 | + Make switching between open tiled windows and floating windows better 18 | + Instead of the frame tree being binary, allow for some frames to have more than 2 children 19 | + Command system for implementing keybindings 20 | + Keyboard driven window managment 21 | + Input focus 22 | - Can options for`*mouse-focus-policy*` be improved? Should all existing options be implemented? 23 | Should new options be added? 24 | 25 | ## New Featuress 26 | + Default to a more usuable/beginner friendly initial configuration 27 | 28 | ## Features that shouldn't be included 29 | + User interaction features like menus, messages, and input boxes should be implemented as seperate applications, 30 | or already existing applications should be used. 31 | -------------------------------------------------------------------------------- /doc/devel/frame-tree.org: -------------------------------------------------------------------------------- 1 | * Frame Tree 2 | 3 | There are three general types of nodes in the frame tree: 4 | 5 | + Parent trees, represented by the =tree-frame= class 6 | + Leaf frames, represented by the =view-frame= class. These nodes 7 | contain application windows. 8 | + Output nodes, represented by the =output-node= class. 9 | 10 | =tree-frame= objects are broken into two further categories: 11 | + =binary-tree-frame=, which represents a tree frame that always has 12 | two children. 13 | + =poly-tree-frame=, which represents a tree frame that has two or 14 | more children. 15 | 16 | Each complete tree is grouped into a =tree-container=, which contains 17 | one tree for each output that is currently visible. 18 | 19 | The =output-node= class is the root of a frame tree, and has exactly 20 | one child, which is the actual tree graph. This class is here so that 21 | there is a fixed object that we can refer to when looking at the trees 22 | in the =tree-container= class; otherwise, operations like 23 | =replace-frame= and output manipulation become much more difficult to 24 | implement; without this, there is no fixed node to refer to instead of 25 | one that may be deleted or moved elsewhere in the tree. 26 | -------------------------------------------------------------------------------- /doc/devel/proposal/frames.org: -------------------------------------------------------------------------------- 1 | * Frames 2 | ** Focusing 3 | + A frame holds focus, not the window that is inside of it. 4 | ** Depth 5 | Frames have depth. This dictates which frames are shown overtop of 6 | one another. This depth is mainly used to layer floating windows and 7 | to make them feel more like a pile of papers on a desk, but tiling 8 | frames have this feature as well. 9 | + The layer closest to the user is 0, followed by layer 1. 10 | + Each time a frame is focused, its depth resets to zero. If a frame 11 | is focused that overlays another frame, those frames drop down a 12 | level. This is a recursive process, as frames that drop in level 13 | also need to check if they overlap any frames and lower their level 14 | as well. 15 | ** Frame types 16 | *** Frames 17 | *** Floating Frames 18 | + These frames have absoulte XY positioning. These are the type of 19 | frames present in ~frame-list~. 20 | *** Tree-frames 21 | + The tree-frame is a tree of frames. Tree-frames represent the 22 | internal nodes in the tree. 23 | *** Leaf-frames 24 | + Leaf frames in the tree that actually hold windows 25 | 26 | *** Child frames? 27 | -------------------------------------------------------------------------------- /doc/devel/proposal/initial-plan.org: -------------------------------------------------------------------------------- 1 | * Architecture 2 | ** Backends 3 | There are two parts to a backend: the portion of a backend that is 4 | responsible for generated events and handling devices, and the 5 | output backend, which is used for rendering items on screen. 6 | *** Event backend 7 | The event backend calls the various hooks that modes provide for 8 | managing windows. Its main responsibility is to manage sever 9 | aspect of Wayland: adding and removing displays, managing input 10 | devices, and handling keyboard/cursor/client events. 11 | *** Output backend 12 | The output backend provides an interface for placing windows, and 13 | providing compositor effects. It abstracts the calls needed to 14 | actually draw each window in the correct position. 15 | ** Base Mahogany structure 16 | In order for Mahogany to be customizable, there needs to be 17 | agreement on the objects that can be mainpulated and how they are 18 | stored. The objects and datastructures in this section will hold 19 | the state of Mahogany. It is up to each mode to figure out how it 20 | wants to interact with these datasctructures and objects, and how 21 | it uses them to layout each Wayland surface. 22 | *** Mahogany Objects 23 | There are a few objects that provide a container for wayland 24 | surfaces, or help organize what the user sees on screen. 25 | 26 | + Window :: An object that holds a wayland surface and keeps track 27 | of the program that corresponds to the surface as well 28 | as various states that are associated with said 29 | surface. There is one window per frame. 30 | + Frame :: Windows are displayed in frames. Frames can either be 31 | floating, or tiled. Frames dictate where windows appear 32 | on screen: # of frames \le # of windows. 33 | + Groups :: This is term used for virtual desktops in 34 | Mahogany. There is one window-list, frame-tree and 35 | frame-list per group. 36 | *** Mahogany Data structures 37 | There are a couple of datastructures that determine the overall 38 | state of what is shown to the user. These datastructures exist in 39 | a group, which is the virtual destops of Mahogany. Each of these 40 | structures hold the specific object mentioned in their name. 41 | 42 | + Group-list :: Holds the list of available groups. 43 | + Frame-list :: There is one frame-list per group. This list 44 | manages the floating windows in a group. 45 | + Frame-tree :: There is one frame-list per group. This tree 46 | managages the tiled windows in the group. 47 | + Visible-frame-list :: The frames that are currently visible to 48 | the user. This will generally hold all of the leaf nodes in 49 | the frame-tree, plus whichever frames are visible in the 50 | Frame-list. 51 | *** Mode-agnostic Items 52 | In order to display notifications and display a command prompt, 53 | certain windows are beyond the control of the modes, and are 54 | alway rendered if they are present. 55 | + Notification windows will always be shown on top. 56 | + Command windows that allow the user to issue textual commands 57 | to the window manager are also always shown. 58 | *** Detemining the events dispatching on the activated mode 59 | **** Major modes 60 | Modes are stored in a stack called ~*current-major-modes*~. When an 61 | event is recieved, the event will be passed to the mode on the top 62 | of the stack. The main use of the stack is to be able to 63 | activate/deactivate modes without having to worry which mode 64 | should be activated next. If you want to merge several modes 65 | together, you can use inherentance. Minor modes can affect the 66 | keybindings globally available within each major mode. 67 | **** Window Minor Modes 68 | 69 | ** Modes 70 | Modes allow the user to customize how the user interacts with 71 | Mahogany. 72 | *** Major Modes 73 | Major modes are responsible for directly deciding how the window-tree and 74 | window-list are displayed and interacted with. Each major mode can have 75 | a series of minor modes activated within it. ~mahogany-mode~, the 76 | default mode, should be used most often. Other modes allow for 3d 77 | desktop effects when switching windows, or special modes to raise windows. 78 | **** Minor Modes 79 | Minor Modes have two variants: window-minor modes and 80 | global minor modes. Window minor modes affect the behavor of a 81 | single window. They are mainly used to create different keymaps 82 | depending on the window. 83 | *** Window Minor Modes 84 | Window minor modes are used to customize keybindings and how the 85 | window is displayed without affecting any other part of 86 | Mahogany. For example, window minor modes can be used to implement 87 | "gaps" as seen in the popular extension for i3, or to scroll 88 | windows with different keys. 89 | *** Modules 90 | Modules represent a way to package and enable code that is not a 91 | part of Mahogany. Modules are mainly used to add additional modes 92 | and platform specificy functionality. For example, if someone uses 93 | pulseaudio, the may wish to install a module that handles volume 94 | and sink selection. 95 | * Undecided 96 | ** Mode line 97 | + see wlr-protocols and layer-shell 98 | ** Menu windows 99 | + see wlr-protocols and layer-shell 100 | + Menu windows that the user interacts with could be implemented as 101 | a major mode that puts all input into the menu instead of 102 | re-directing it to the windows. 103 | ** Notification windows 104 | Dunst for wayland? 105 | + see wlr-protocols and layer-shell 106 | ** IPC for modeline, testing 107 | -------------------------------------------------------------------------------- /doc/focus.org: -------------------------------------------------------------------------------- 1 | #+TITLE: Focusing windows in Mahogany 2 | 3 | There are two types of focus present in Mahogany: keyboard focus and 4 | cursor focus. When a surface is focused by an input device, it means 5 | that the device is sending events to the surface. Keyboard and cursor 6 | focus can be controlled seperately in Mahogany, and there are various 7 | settings that control how focus moves from one surface to another. 8 | 9 | * Keyboard focus 10 | Keyboard focus can be controlled either by actions taken by the 11 | cursor, or through various commands. 12 | 13 | ** Setting how focus is controlled 14 | + =(config-system:set-config *keyboard-focus-type* type)= :: Sets the way the keyboard 15 | focus is set. The valid values are: 16 | - =:click= :: /Default/ Switch the keyboard focus to 17 | windows that are clicked on in addition to wm commands. 18 | - =:click-and-wheel= :: Switch the keyboard focus when the cursor is clicked 19 | or scrolled. 20 | - =:ignore= :: Ignore the mouse, and just use commands. 21 | - =:sloppy= :: Set the keyboard focus to whatever surface the cursors is over. 22 | * Cursor focus (not yet implemented) 23 | Cursor focus has two different modes: following the keyboard, or 24 | having its own seperate focus. 25 | + =(set-mouse-focus-policy wm type)= :: Sets the way the keyboard 26 | focus is set. The value values are: 27 | - =:seperated= :: /Default/ The cursor focus is seperated from the keyboard 28 | focus. This means that the cursor can be focused on a different 29 | window than the keyboard. Surfaces are focused when the mouse 30 | moves over them, then movement events, clicks, and scroll events 31 | are sent to the surface. Scroll events are always sent to the 32 | surface,even if it isn't focused. 33 | - =:stumpwm= :: The cursor is locked to the keyboard focus. Mouse movement, 34 | clicks and scrolls are ignored if the keyboard isn't 35 | focused on the surface that the cursor is over. 36 | * Stumpwm focus 37 | Since Mahogany is decended from stumpwm, it is useful to note that 38 | in order to get the equivalent behavior of stumpwm, set the cursor 39 | focus to =:stumpwm=, and the keyboard focus settings will match up 40 | nicely with the stumpwm options. 41 | -------------------------------------------------------------------------------- /guix.scm: -------------------------------------------------------------------------------- 1 | .guix/modules/mahogany-package.scm -------------------------------------------------------------------------------- /heart/.editorconfig: -------------------------------------------------------------------------------- 1 | [*.c] 2 | indent_style = space 3 | trim_trailing_whitespace = true 4 | indent_size = 2 5 | 6 | [*.h] 7 | indent_style = space 8 | trim_trailing_whitespace = true 9 | indent_size = 2 -------------------------------------------------------------------------------- /heart/.gitignore: -------------------------------------------------------------------------------- 1 | .cache 2 | compile_commands.json -------------------------------------------------------------------------------- /heart/README.md: -------------------------------------------------------------------------------- 1 | This folder contains a potential C backend to a Wayland compositor 2 | written in a language besides C. 3 | 4 | Its task is to setup the initial state of the compositor, render the 5 | output, and initially handle new connections to the compositor. If 6 | needed, the backend will also wrap some wlroots functions so that less 7 | foreign code needs to be called from the other language. 8 | 9 | The foreign code will interface with this library through a series of 10 | callbacks, which are orgainized based on their purpose. 11 | 12 | ## Output callbacks 13 | This set of callbacks handls when outputs are added and 14 | removed. Outputs usually correspond to physical monitors, but they can 15 | also be VNC connections or other means of displaying a chunk of 16 | pixels. 17 | 18 | + **output_added**: Called when a new output is added. 19 | + **output_removed**: Called when an output is removed. 20 | 21 | ## Seat (input) callbacks 22 | This set of callbacks handles input events 23 | 24 | + **handle_key_event**: When a key is pressed, this callback is 25 | triggered. 26 | + **handle_cursor_key**: When a mouse button is pressed, this event is 27 | triggered. 28 | + **handle_cursor_axis**: When a mouse wheel is scrolled, this event is 29 | triggered. 30 | + **handle_cursor_motion**: When a mouse is moved, this callback is 31 | triggered. 32 | 33 | ## Client callbacks 34 | This set of callbacks handle client related callbacks, such as when a 35 | surface is added or removed. In the backend, this may be either a new 36 | XWayland window, or a client implementing the XDG shell protocol. 37 | -------------------------------------------------------------------------------- /heart/example/main.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | #include 4 | #include 5 | #include 6 | #include 7 | #include 8 | #include 9 | 10 | static void cursor_button_callback(struct hrt_seat *seat, struct wlr_pointer_button_event *event) { 11 | puts("Cursor callback called"); 12 | } 13 | 14 | static void cursor_wheel_callback(struct hrt_seat *seat, struct wlr_pointer_axis_event *event) { 15 | puts("Cursor callback called"); 16 | } 17 | 18 | static void output_callback(struct hrt_output *output) { 19 | puts("Output callback called"); 20 | } 21 | 22 | static void new_view_callback(struct hrt_view *view) { 23 | puts("New view callback called!"); 24 | } 25 | 26 | static void view_destroy_callback(struct hrt_view *view) { 27 | puts("View destroy callback called"); 28 | } 29 | 30 | static bool showNormalCursor = true; 31 | static bool keyboard_callback(struct hrt_seat *seat, struct hrt_keypress_info *info) { 32 | puts("Keyboard callback called"); 33 | printf("Modifiers: %d\n", info->modifiers); 34 | printf("Keys pressed:"); 35 | for(size_t i = 0; i < info->keysyms_len; ++i) { 36 | if (info->keysyms[i] == XKB_KEY_Escape) { 37 | puts("Exiting due to escape pressed"); 38 | hrt_server_stop(seat->server); 39 | } 40 | char buffer[20]; 41 | xkb_keysym_get_name(info->keysyms[i], buffer, sizeof(buffer)); 42 | printf(" %s", buffer); 43 | if(strcmp(buffer, "c") == 0) { 44 | hrt_seat_set_cursor_img(seat, showNormalCursor ? "crossed_circle" : "left_ptr"); 45 | showNormalCursor = !showNormalCursor; 46 | } 47 | } 48 | puts("\n\n"); 49 | return false; 50 | } 51 | 52 | static void layout_changed() { 53 | 54 | } 55 | 56 | static const struct hrt_output_callbacks output_callbacks = { 57 | .output_added = &output_callback, 58 | .output_removed = &output_callback, 59 | .output_layout_changed = &layout_changed, 60 | }; 61 | 62 | static const struct hrt_seat_callbacks seat_callbacks = { 63 | .button_event = &cursor_button_callback, 64 | .wheel_event = &cursor_wheel_callback, 65 | .keyboard_keypress_event = &keyboard_callback, 66 | }; 67 | 68 | static const struct hrt_view_callbacks view_callbacks = { 69 | .new_view = &new_view_callback, 70 | .view_destroyed = &view_destroy_callback, 71 | }; 72 | 73 | int main(int argc, char *argv[]) { 74 | wlr_log_init(WLR_DEBUG, NULL); 75 | 76 | struct hrt_server server; 77 | 78 | if(!hrt_server_init(&server, &output_callbacks, &seat_callbacks, &view_callbacks, WLR_DEBUG)) { 79 | return 1; 80 | } 81 | 82 | hrt_server_start(&server); 83 | hrt_server_finish(&server); 84 | return 0; 85 | } 86 | -------------------------------------------------------------------------------- /heart/example/meson.build: -------------------------------------------------------------------------------- 1 | executable( 2 | 'heart', 3 | files('main.c'), 4 | dependencies: heart, 5 | build_by_default: get_option('example') 6 | ) 7 | -------------------------------------------------------------------------------- /heart/include/hrt/hrt_input.h: -------------------------------------------------------------------------------- 1 | #ifndef HRT_HRT_INPUT_H 2 | #define HRT_HRT_INPUT_H 3 | 4 | #include 5 | #include 6 | #include 7 | #include 8 | #include 9 | #include 10 | 11 | #include 12 | 13 | struct hrt_server; 14 | struct hrt_seat_callbacks; 15 | 16 | struct hrt_seat { 17 | struct hrt_server *server; 18 | 19 | struct wlr_cursor *cursor; 20 | struct wlr_keyboard_group *keyboard_group; 21 | struct wlr_xcursor_manager *xcursor_manager; 22 | struct wlr_seat *seat; 23 | struct wl_list inputs; 24 | struct wl_listener new_input; 25 | 26 | // cursor events: 27 | struct wl_listener motion; 28 | struct wl_listener motion_absolute; 29 | struct wl_listener button; 30 | struct wl_listener axis; 31 | struct wl_listener frame; 32 | struct wl_listener request_cursor; 33 | // keyboard events: 34 | struct wl_listener keyboard_key; 35 | struct wl_listener keyboard_modifiers; 36 | 37 | const struct hrt_seat_callbacks *callbacks; 38 | char *cursor_image; 39 | }; 40 | 41 | struct hrt_keypress_info { 42 | const xkb_keysym_t *keysyms; 43 | uint32_t modifiers; 44 | size_t keysyms_len; 45 | enum wl_keyboard_key_state wl_key_state; 46 | }; 47 | 48 | struct hrt_seat_callbacks { 49 | // TODO: these probably need more parameters 50 | void (*button_event)(struct hrt_seat *seat, 51 | struct wlr_pointer_button_event *event); 52 | /** 53 | * This event triggers when the mouse wheel moves in any direction, 54 | * including left and right: 55 | **/ 56 | void (*wheel_event)(struct hrt_seat *seat, 57 | struct wlr_pointer_axis_event *event); 58 | /** 59 | * This callback is called whenever a non-modifier key is pressed (not 60 | * released) 61 | **/ 62 | bool (*keyboard_keypress_event)(struct hrt_seat *seat, 63 | struct hrt_keypress_info *info); 64 | }; 65 | 66 | struct hrt_input { 67 | struct wlr_input_device *wlr_input_device; 68 | struct hrt_seat *seat; 69 | struct wl_list link; 70 | 71 | struct wl_listener destroy; 72 | }; 73 | 74 | bool hrt_seat_init(struct hrt_seat *seat, struct hrt_server *server, 75 | const struct hrt_seat_callbacks *callbacks); 76 | void hrt_seat_destroy(struct hrt_seat *seat); 77 | 78 | bool hrt_cursor_init(struct hrt_seat *seat, struct hrt_server *server); 79 | void hrt_cursor_destroy(struct hrt_seat *seat); 80 | 81 | void hrt_keyboard_init(struct hrt_seat *seat); 82 | void hrt_keyboard_destroy(struct hrt_seat *seat); 83 | 84 | /** 85 | * Set the seat's default cursor image to the given cursor name. 86 | * 87 | * Does not take ownership of the string. 88 | * 89 | * See themes section of man xcursor(3) to find where to find valid cursor 90 | * names. 91 | */ 92 | void hrt_seat_set_cursor_img(struct hrt_seat *seat, char *img_name); 93 | 94 | void hrt_seat_notify_button(struct hrt_seat *seat, 95 | struct wlr_pointer_button_event *event); 96 | 97 | void hrt_seat_notify_axis(struct hrt_seat *seat, 98 | struct wlr_pointer_axis_event *event); 99 | 100 | double hrt_seat_cursor_lx(struct hrt_seat *seat); 101 | 102 | double hrt_seat_cursor_ly(struct hrt_seat *seat); 103 | 104 | #endif 105 | -------------------------------------------------------------------------------- /heart/include/hrt/hrt_output.h: -------------------------------------------------------------------------------- 1 | #ifndef HRT_HRT_OUTPUT_H 2 | #define HRT_HRT_OUTPUT_H 3 | 4 | #include 5 | 6 | #include 7 | 8 | #include 9 | 10 | struct hrt_output { 11 | struct wlr_output *wlr_output; 12 | struct hrt_server *server; 13 | 14 | struct wl_listener request_state; 15 | struct wl_listener frame; 16 | struct wl_listener destroy; 17 | 18 | // temp background color 19 | float color[4]; 20 | }; 21 | 22 | struct hrt_output_callbacks { 23 | void (*output_added)(struct hrt_output *output); 24 | void (*output_removed)(struct hrt_output *output); 25 | void (*output_layout_changed)(); 26 | }; 27 | 28 | bool hrt_output_init(struct hrt_server *server, 29 | const struct hrt_output_callbacks *callbacks); 30 | void hrt_output_destroy(struct hrt_server *server); 31 | /** 32 | * Get the effective output resolution of the output that can be used to 33 | * set the width and height of views. 34 | **/ 35 | void hrt_output_resolution(struct hrt_output *output, int *width, int *height); 36 | 37 | void hrt_output_position(struct hrt_output *output, int *x, int *y); 38 | 39 | char *hrt_output_name(struct hrt_output *output); 40 | 41 | char *hrt_output_make(struct hrt_output *output); 42 | 43 | char *hrt_output_model(struct hrt_output *output); 44 | 45 | char *hrt_output_serial(struct hrt_output *output); 46 | 47 | #endif 48 | -------------------------------------------------------------------------------- /heart/include/hrt/hrt_server.h: -------------------------------------------------------------------------------- 1 | #ifndef HRT_HRT_SERVER_H 2 | #define HRT_HRT_SERVER_H 3 | 4 | #include "wlr/backend/session.h" 5 | #include 6 | 7 | #include 8 | #include 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | #include 15 | #include 16 | 17 | #include 18 | 19 | struct hrt_server { 20 | struct wl_display *wl_display; 21 | struct wlr_backend *backend; 22 | struct wl_listener backend_destroy; 23 | struct wlr_session *session; 24 | struct wlr_renderer *renderer; 25 | struct wlr_compositor *compositor; 26 | struct wlr_allocator *allocator; 27 | 28 | struct wlr_scene *scene; 29 | struct wlr_scene_output_layout *scene_layout; 30 | struct wl_listener new_output; 31 | struct wlr_output_manager_v1 *output_manager; 32 | struct wlr_output_layout *output_layout; 33 | struct wl_listener output_layout_changed; 34 | struct wl_listener output_manager_apply; 35 | struct wl_listener output_manager_test; 36 | struct wl_listener output_manager_destroy; 37 | 38 | struct hrt_seat seat; 39 | 40 | struct wlr_xdg_shell *xdg_shell; 41 | struct wl_listener new_xdg_toplevel; 42 | struct wl_listener new_xdg_popup; 43 | 44 | const struct hrt_output_callbacks *output_callback; 45 | const struct hrt_view_callbacks *view_callbacks; 46 | }; 47 | 48 | bool hrt_server_init(struct hrt_server *server, 49 | const struct hrt_output_callbacks *output_callbacks, 50 | const struct hrt_seat_callbacks *seat_callbacks, 51 | const struct hrt_view_callbacks *view_callbacks, 52 | enum wlr_log_importance log_level); 53 | 54 | bool hrt_server_start(struct hrt_server *server); 55 | 56 | void hrt_server_stop(struct hrt_server *server); 57 | 58 | void hrt_server_finish(struct hrt_server *server); 59 | 60 | struct wlr_scene_tree *hrt_server_scene_tree(struct hrt_server *server); 61 | 62 | struct hrt_seat *hrt_server_seat(struct hrt_server *server); 63 | 64 | #endif 65 | -------------------------------------------------------------------------------- /heart/include/hrt/hrt_view.h: -------------------------------------------------------------------------------- 1 | #ifndef HRT_VIEW 2 | #define HRT_VIEW 3 | 4 | #include 5 | #include 6 | #include 7 | #include "hrt_input.h" 8 | 9 | struct hrt_view; 10 | 11 | typedef void (*view_destroy_handler)(struct hrt_view *view); 12 | typedef void (*new_view_handler)(struct hrt_view *view); 13 | 14 | struct hrt_view { 15 | int width, height; 16 | struct wlr_xdg_surface *xdg_surface; 17 | struct wlr_xdg_toplevel *xdg_toplevel; 18 | /* 19 | Contains the tree with the xdg surface tree 20 | plus decorations and that sort of thing. 21 | */ 22 | struct wlr_scene_tree *scene_tree; 23 | 24 | // internal state: 25 | struct wl_listener map; 26 | struct wl_listener unmap; 27 | struct wl_listener commit; 28 | struct wl_listener destroy; 29 | 30 | struct wl_listener request_maximize; 31 | struct wl_listener request_fullscreen; 32 | 33 | new_view_handler new_view_handler; 34 | view_destroy_handler destroy_handler; 35 | }; 36 | 37 | struct hrt_view_callbacks { 38 | /** 39 | * A new view has been created. Must call `hrt_view_init` for the 40 | * view to be displayed. 41 | **/ 42 | new_view_handler new_view; 43 | view_destroy_handler view_destroyed; 44 | }; 45 | 46 | /** 47 | * Fully initialize the view and place it in the given scene tree. 48 | **/ 49 | void hrt_view_init(struct hrt_view *view, struct wlr_scene_tree *tree); 50 | 51 | void hrt_view_info(struct hrt_view *view); 52 | 53 | /** 54 | * Request that this view be the given size. Returns the associated configure 55 | *serial. 56 | **/ 57 | uint32_t hrt_view_set_size(struct hrt_view *view, int width, int height); 58 | 59 | /** 60 | * Sets the view to the given coordinates relative to its parent. 61 | **/ 62 | void hrt_view_set_relative(struct hrt_view *view, int x, int y); 63 | 64 | /** 65 | * Focus the given view and perform the needed tasks to make 66 | * it visible to the user. 67 | **/ 68 | void hrt_view_focus(struct hrt_view *view, struct hrt_seat *seat); 69 | 70 | /** 71 | * Unfocus the given view. 72 | **/ 73 | void hrt_view_unfocus(struct hrt_view *view, struct hrt_seat *seat); 74 | 75 | /** 76 | * Stop the given view from being displayed 77 | **/ 78 | void hrt_view_set_hidden(struct hrt_view *view, bool hidden); 79 | 80 | void hrt_view_reparent(struct hrt_view *view, struct wlr_scene_tree *node); 81 | 82 | /** 83 | * Request that the view be closed. This is the "nice" version 84 | * that is the same as clicking the close button on window decorations. 85 | * It does not garentee that the application actually closes, but 86 | * well behaved ones should. 87 | **/ 88 | void hrt_view_request_close(struct hrt_view *view); 89 | 90 | #endif 91 | -------------------------------------------------------------------------------- /heart/include/meson.build: -------------------------------------------------------------------------------- 1 | install_subdir('hrt', 2 | install_dir: get_option('includedir') 3 | ) 4 | -------------------------------------------------------------------------------- /heart/include/view_impl.h: -------------------------------------------------------------------------------- 1 | #ifndef HRT_VIEW_IMPL 2 | #define HRT_VIEW_IMPL 3 | 4 | struct hrt_view; 5 | 6 | /** 7 | * Cleanup the data initizlized during the hrt_view_init function 8 | * This is internal, as it doesn't clean up everything and relies on 9 | * other internal code to completely cleanup after a view. 10 | */ 11 | void hrt_view_cleanup(struct hrt_view *view); 12 | 13 | #endif 14 | -------------------------------------------------------------------------------- /heart/include/xdg_impl.h: -------------------------------------------------------------------------------- 1 | #pragma once 2 | 3 | #include 4 | #include 5 | #include "hrt/hrt_server.h" 6 | 7 | struct hrt_xdg_popup { 8 | struct wlr_xdg_popup *xdg_popup; 9 | struct wl_listener commit; 10 | struct wl_listener destroy; 11 | }; 12 | 13 | bool hrt_xdg_shell_init(struct hrt_server *server); 14 | -------------------------------------------------------------------------------- /heart/meson.build: -------------------------------------------------------------------------------- 1 | project( 2 | 'heart', 3 | 'c', 4 | version: '0.1', 5 | license: 'GPL', 6 | default_options: [ 7 | 'c_std=c11', 8 | 'warning_level=2', 9 | 'werror=true', 10 | ], 11 | ) 12 | 13 | add_project_arguments( 14 | [ 15 | '-DWLR_USE_UNSTABLE', 16 | '-D_POSIX_C_SOURCE=200112L', 17 | '-Wno-unused-parameter', 18 | '-Wno-unused-result', 19 | ], 20 | language: 'c', 21 | ) 22 | 23 | cc = meson.get_compiler('c') 24 | 25 | wayland_server = dependency('wayland-server') 26 | wayland_protos = dependency('wayland-protocols', version: '>=1.14') 27 | xkbcommon = dependency('xkbcommon') 28 | xcb = dependency('xcb', required: get_option('xwayland')) 29 | 30 | wlroots_version = ['>=0.18.0', '<0.19.0'] 31 | wlroots_proj = subproject( 32 | 'wlroots', 33 | default_options: ['examples=false'], 34 | required: false, 35 | version: wlroots_version, 36 | ) 37 | if wlroots_proj.found() 38 | wlroots = wlroots_proj.get_variable('wlroots') 39 | wlroots_conf = wlroots_proj.get_variable('conf_data') 40 | wlroots_has_xwayland = wlroots_conf.get('WLR_HAS_XWAYLAND') == 1 41 | else 42 | wlroots = dependency('wlroots', version: wlroots_version) 43 | wlroots_has_xwayland = cc.get_define('WLR_HAS_XWAYLAND', prefix: '#include ', dependencies: wlroots) == '1' 44 | endif 45 | 46 | if get_option('xwayland').enabled() and not wlroots_has_xwayland 47 | error('Cannot enable Xwayland in heart: wlroots has been built without Xwayland support') 48 | endif 49 | 50 | have_xwayland = xcb.found() and wlroots_has_xwayland 51 | 52 | conf_data = configuration_data() 53 | conf_data.set10('HAVE_XWAYLAND', have_xwayland) 54 | 55 | hrt_source_files = [] 56 | 57 | subdir('include') 58 | subdir('protocols') 59 | subdir('src') 60 | 61 | hrt_deps = [ 62 | server_protos, 63 | wayland_server, 64 | wlroots, 65 | xkbcommon, 66 | ] 67 | 68 | hrt_inc = include_directories('include') 69 | proto_inc = include_directories('protocols') 70 | 71 | lib_hrt = library( 72 | meson.project_name(), hrt_source_files, 73 | dependencies: hrt_deps, 74 | include_directories: [hrt_inc, proto_inc], 75 | install: true 76 | ) 77 | 78 | heart = declare_dependency( 79 | link_with: lib_hrt, 80 | dependencies: hrt_deps, 81 | include_directories: hrt_inc, 82 | ) 83 | 84 | pkg = import('pkgconfig') 85 | pkg.generate(lib_hrt, 86 | version: meson.project_version(), 87 | filebase: meson.project_name(), 88 | name: meson.project_name(), 89 | description: 'Core package for mahogany wm') 90 | 91 | if get_option('example') 92 | subdir('example') 93 | endif 94 | -------------------------------------------------------------------------------- /heart/meson_options.txt: -------------------------------------------------------------------------------- 1 | option('xwayland', type: 'feature', value: 'auto', description: 'Enable support for X11 applications') 2 | option('example', type: 'boolean', value: true, description: 'Build example C application') 3 | -------------------------------------------------------------------------------- /heart/protocols/meson.build: -------------------------------------------------------------------------------- 1 | #### 2 | # Code taken from https://git.sr.ht/~sircmpwn/sedna 3 | # Copyright Drew Default, GPL 4 | #### 5 | 6 | wl_protocol_dir = wayland_protos.get_pkgconfig_variable('pkgdatadir') 7 | wlr_protocol_dir = meson.current_source_dir() 8 | 9 | wayland_scanner_dep = dependency('wayland-scanner', required: false, native: true) 10 | if wayland_scanner_dep.found() 11 | wayland_scanner = find_program( 12 | wayland_scanner_dep.get_pkgconfig_variable('wayland_scanner'), 13 | native: true, 14 | ) 15 | else 16 | wayland_scanner = find_program('wayland-scanner', native: true) 17 | endif 18 | 19 | protocols = [ 20 | [wl_protocol_dir, 'stable/xdg-shell/xdg-shell.xml'], 21 | [wlr_protocol_dir, 'wlr-output-management-unstable-v1.xml'], 22 | ] 23 | 24 | wl_protos_src = [] 25 | wl_protos_headers = [] 26 | 27 | foreach p : protocols 28 | xml = join_paths(p) 29 | wl_protos_src += custom_target( 30 | xml.underscorify() + '_server_c', 31 | input: xml, 32 | output: '@BASENAME@-protocol.c', 33 | command: [wayland_scanner, 'private-code', '@INPUT@', '@OUTPUT@'], 34 | ) 35 | wl_protos_headers += custom_target( 36 | xml.underscorify() + '_server_h', 37 | input: xml, 38 | output: '@BASENAME@-protocol.h', 39 | command: [wayland_scanner, 'server-header', '@INPUT@', '@OUTPUT@'], 40 | ) 41 | endforeach 42 | 43 | lib_server_protos = static_library( 44 | 'server_protos', 45 | wl_protos_src + wl_protos_headers, 46 | dependencies: wayland_server.partial_dependency(compile_args: true), 47 | ) 48 | 49 | server_protos = declare_dependency( 50 | link_with: lib_server_protos, 51 | sources: wl_protos_headers, 52 | ) 53 | -------------------------------------------------------------------------------- /heart/src/cursor.c: -------------------------------------------------------------------------------- 1 | #include "hrt/hrt_view.h" 2 | #include 3 | #include 4 | #include 5 | 6 | #include 7 | #include 8 | 9 | // This function is shamelessly ripped from the tinywl implementation: 10 | static struct hrt_view *find_view_at(struct hrt_server *server, double lx, 11 | double ly, struct wlr_surface **surface, 12 | double *sx, double *sy) { 13 | /* This returns the topmost node in the scene at the given layout coords. 14 | * We only care about surface nodes as we are specifically looking for a 15 | * surface in the surface tree of a tinywl_toplevel. */ 16 | struct wlr_scene_node *node = 17 | wlr_scene_node_at(&server->scene->tree.node, lx, ly, sx, sy); 18 | if (node == NULL || node->type != WLR_SCENE_NODE_BUFFER) { 19 | return NULL; 20 | } 21 | struct wlr_scene_buffer *scene_buffer = wlr_scene_buffer_from_node(node); 22 | struct wlr_scene_surface *scene_surface = 23 | wlr_scene_surface_try_from_buffer(scene_buffer); 24 | if (!scene_surface) { 25 | return NULL; 26 | } 27 | 28 | *surface = scene_surface->surface; 29 | /* Find the node corresponding to the toplevel at the root of this 30 | * surface tree, it is the only one for which we set the data field. */ 31 | struct wlr_scene_tree *tree = node->parent; 32 | while (tree != NULL && tree->node.data == NULL) { 33 | tree = tree->node.parent; 34 | } 35 | return tree->node.data; 36 | } 37 | 38 | static void handle_cursor_motion(struct hrt_seat *seat, uint32_t time) { 39 | double sx, sy; 40 | struct wlr_surface *found_surface = NULL; 41 | struct hrt_view *view = 42 | find_view_at(seat->server, seat->cursor->x, seat->cursor->y, 43 | &found_surface, &sx, &sy); 44 | if (!view) { 45 | wlr_cursor_set_xcursor(seat->cursor, seat->xcursor_manager, 46 | seat->cursor_image); 47 | } 48 | if (found_surface) { 49 | wlr_seat_pointer_notify_enter(seat->seat, found_surface, sx, sy); 50 | wlr_seat_pointer_notify_motion(seat->seat, time, sx, sy); 51 | } else { 52 | wlr_seat_pointer_clear_focus(seat->seat); 53 | } 54 | } 55 | 56 | static void seat_motion(struct wl_listener *listener, void *data) { 57 | struct hrt_seat *seat = wl_container_of(listener, seat, motion); 58 | struct wlr_pointer_motion_event *ev = data; 59 | 60 | wlr_cursor_move(seat->cursor, &ev->pointer->base, ev->delta_x, ev->delta_y); 61 | handle_cursor_motion(seat, ev->time_msec); 62 | } 63 | 64 | static void seat_motion_absolute(struct wl_listener *listener, void *data) { 65 | struct hrt_seat *seat = wl_container_of(listener, seat, motion_absolute); 66 | struct wlr_pointer_motion_absolute_event *ev = data; 67 | 68 | wlr_cursor_warp_absolute(seat->cursor, &ev->pointer->base, ev->x, ev->y); 69 | handle_cursor_motion(seat, ev->time_msec); 70 | } 71 | 72 | static void seat_button(struct wl_listener *listener, void *data) { 73 | struct hrt_seat *seat = wl_container_of(listener, seat, button); 74 | struct wlr_pointer_button_event *event = data; 75 | /* Notify the client with pointer focus that a button press has occurred */ 76 | 77 | seat->callbacks->button_event(seat, event); 78 | } 79 | 80 | static void seat_axis(struct wl_listener *listener, void *data) { 81 | struct hrt_seat *seat = wl_container_of(listener, seat, axis); 82 | struct wlr_pointer_axis_event *ev = data; 83 | 84 | seat->callbacks->wheel_event(seat, ev); 85 | } 86 | 87 | static void seat_frame(struct wl_listener *listener, void *data) { 88 | struct hrt_seat *seat = wl_container_of(listener, seat, frame); 89 | wlr_seat_pointer_notify_frame(seat->seat); 90 | } 91 | 92 | bool hrt_cursor_init(struct hrt_seat *seat, struct hrt_server *server) { 93 | seat->cursor = wlr_cursor_create(); 94 | if (!seat->cursor) { 95 | return false; 96 | } 97 | wlr_cursor_attach_output_layout(seat->cursor, server->output_layout); 98 | 99 | seat->xcursor_manager = wlr_xcursor_manager_create(NULL, 24); 100 | if (!seat->xcursor_manager) { 101 | return false; 102 | } 103 | wlr_xcursor_manager_load(seat->xcursor_manager, 1); 104 | 105 | seat->motion.notify = seat_motion; 106 | wl_signal_add(&seat->cursor->events.motion, &seat->motion); 107 | seat->motion_absolute.notify = seat_motion_absolute; 108 | wl_signal_add(&seat->cursor->events.motion_absolute, 109 | &seat->motion_absolute); 110 | seat->button.notify = seat_button; 111 | wl_signal_add(&seat->cursor->events.button, &seat->button); 112 | seat->axis.notify = seat_axis; 113 | wl_signal_add(&seat->cursor->events.axis, &seat->axis); 114 | seat->frame.notify = seat_frame; 115 | wl_signal_add(&seat->cursor->events.frame, &seat->frame); 116 | 117 | return true; 118 | } 119 | 120 | void hrt_cursor_destroy(struct hrt_seat *seat) { 121 | wlr_xcursor_manager_destroy(seat->xcursor_manager); 122 | wlr_cursor_destroy(seat->cursor); 123 | } 124 | -------------------------------------------------------------------------------- /heart/src/input.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | 7 | #include 8 | #include 9 | 10 | #include 11 | #include 12 | 13 | static void add_new_keyboard(struct hrt_input *input, struct hrt_seat *seat) { 14 | struct wlr_keyboard *kb = 15 | wlr_keyboard_from_input_device(input->wlr_input_device); 16 | wlr_keyboard_set_keymap(kb, seat->keyboard_group->keyboard.keymap); 17 | if (!wlr_keyboard_group_add_keyboard(seat->keyboard_group, kb)) { 18 | wlr_log(WLR_ERROR, "Could not add keyboard to keyboard group!"); 19 | exit(1); 20 | } 21 | } 22 | 23 | static void remove_keyboard(struct hrt_input *input, struct hrt_seat *seat) { 24 | struct wlr_keyboard *kb = 25 | wlr_keyboard_from_input_device(input->wlr_input_device); 26 | wlr_keyboard_group_remove_keyboard(seat->keyboard_group, kb); 27 | } 28 | 29 | static void add_new_pointer(struct hrt_input *input, struct hrt_seat *seat) { 30 | wlr_cursor_attach_input_device(seat->cursor, input->wlr_input_device); 31 | } 32 | 33 | static void remove_pointer(struct hrt_input *input, struct hrt_seat *seat) { 34 | wlr_cursor_detach_input_device(seat->cursor, input->wlr_input_device); 35 | } 36 | 37 | static uint32_t find_input_caps(struct hrt_seat *seat, 38 | struct hrt_input *input) { 39 | uint32_t caps = 0; 40 | wl_list_for_each(input, &seat->inputs, link) { 41 | switch (input->wlr_input_device->type) { 42 | case WLR_INPUT_DEVICE_KEYBOARD: 43 | caps |= WL_SEAT_CAPABILITY_KEYBOARD; 44 | break; 45 | case WLR_INPUT_DEVICE_POINTER: 46 | caps |= WL_SEAT_CAPABILITY_POINTER; 47 | break; 48 | case WLR_INPUT_DEVICE_TOUCH: 49 | caps |= WL_SEAT_CAPABILITY_TOUCH; 50 | break; 51 | default: 52 | /* This space deliberately left blank */ 53 | break; 54 | } 55 | } 56 | return caps; 57 | } 58 | 59 | static void input_device_destroy(struct wl_listener *listener, void *data) { 60 | wlr_log(WLR_DEBUG, "input device destroyed"); 61 | 62 | struct hrt_input *input = wl_container_of(listener, input, destroy); 63 | 64 | switch (input->wlr_input_device->type) { 65 | case WLR_INPUT_DEVICE_KEYBOARD: 66 | remove_keyboard(input, input->seat); 67 | break; 68 | case WLR_INPUT_DEVICE_POINTER: 69 | remove_pointer(input, input->seat); 70 | break; 71 | default: break; 72 | } 73 | 74 | // Signals 75 | wl_list_remove(&input->destroy.link); 76 | 77 | wl_list_remove(&input->link); 78 | 79 | uint32_t caps = find_input_caps(input->seat, input); 80 | wlr_seat_set_capabilities(input->seat->seat, caps); 81 | 82 | free(input); 83 | } 84 | 85 | static void new_input_notify(struct wl_listener *listener, void *data) { 86 | wlr_log(WLR_DEBUG, "New input device added"); 87 | 88 | struct hrt_seat *seat = wl_container_of(listener, seat, new_input); 89 | struct wlr_input_device *dev = data; 90 | struct hrt_input *input = calloc(1, sizeof(struct hrt_input)); 91 | input->wlr_input_device = dev; 92 | input->seat = seat; 93 | 94 | /// Signals 95 | input->destroy.notify = input_device_destroy; 96 | wl_signal_add(&dev->events.destroy, &input->destroy); 97 | 98 | wl_list_insert(&seat->inputs, &input->link); 99 | 100 | switch (dev->type) { 101 | case WLR_INPUT_DEVICE_KEYBOARD: add_new_keyboard(input, seat); break; 102 | case WLR_INPUT_DEVICE_POINTER: add_new_pointer(input, seat); break; 103 | default: break; 104 | } 105 | 106 | uint32_t caps = find_input_caps(seat, input); 107 | wlr_seat_set_capabilities(seat->seat, caps); 108 | } 109 | 110 | static void handle_request_set_cursor(struct wl_listener *listener, 111 | void *data) { 112 | struct hrt_seat *seat = wl_container_of(listener, seat, request_cursor); 113 | struct wlr_seat_pointer_request_set_cursor_event *event = data; 114 | 115 | struct wlr_seat_client *focused = seat->seat->pointer_state.focused_client; 116 | if (focused == event->seat_client) { 117 | wlr_cursor_set_surface(seat->cursor, event->surface, event->hotspot_x, 118 | event->hotspot_y); 119 | } 120 | } 121 | 122 | bool hrt_seat_init(struct hrt_seat *seat, struct hrt_server *server, 123 | const struct hrt_seat_callbacks *callbacks) { 124 | seat->callbacks = callbacks; 125 | seat->server = server; 126 | seat->new_input.notify = new_input_notify; 127 | wl_signal_add(&server->backend->events.new_input, &seat->new_input); 128 | 129 | seat->seat = wlr_seat_create(server->wl_display, "seat-0"); 130 | if (!seat->seat) { 131 | return false; 132 | } 133 | wl_list_init(&seat->inputs); 134 | 135 | seat->request_cursor.notify = handle_request_set_cursor; 136 | wl_signal_add(&seat->seat->events.request_set_cursor, 137 | &seat->request_cursor); 138 | 139 | if (!hrt_cursor_init(seat, server)) { 140 | return false; 141 | } 142 | 143 | hrt_keyboard_init(seat); 144 | 145 | seat->cursor_image = "left_ptr"; 146 | 147 | return true; 148 | } 149 | 150 | void hrt_seat_destroy(struct hrt_seat *seat) { 151 | wlr_seat_destroy(seat->seat); 152 | hrt_keyboard_destroy(seat); 153 | hrt_cursor_destroy(seat); 154 | } 155 | -------------------------------------------------------------------------------- /heart/src/keyboard.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | // Temp: needed for exiting on escape key pressed: 6 | #include 7 | #include 8 | #include 9 | #include 10 | #include 11 | 12 | #include 13 | #include 14 | #include 15 | 16 | #include 17 | #include 18 | 19 | static size_t seat_translate_keysyms(struct hrt_seat *seat, 20 | xkb_keycode_t keycode, 21 | const xkb_keysym_t **keysyms, 22 | uint32_t *modifiers) { 23 | struct wlr_keyboard *keyboard = &seat->keyboard_group->keyboard; 24 | *modifiers = wlr_keyboard_get_modifiers(keyboard); 25 | xkb_mod_mask_t consumed = xkb_state_key_get_consumed_mods2( 26 | keyboard->xkb_state, keycode, XKB_CONSUMED_MODE_XKB); 27 | *modifiers = *modifiers & ~consumed; 28 | 29 | return xkb_state_key_get_syms(keyboard->xkb_state, keycode, keysyms); 30 | } 31 | 32 | static bool execute_hardcoded_bindings(struct hrt_server *server, 33 | const xkb_keysym_t *pressed_keysyms, 34 | uint32_t modifiers, size_t keysyms_len) { 35 | for (size_t i = 0; i < keysyms_len; ++i) { 36 | xkb_keysym_t keysym = pressed_keysyms[i]; 37 | 38 | if (keysym >= XKB_KEY_XF86Switch_VT_1 && 39 | keysym <= XKB_KEY_XF86Switch_VT_12) { 40 | if (wlr_backend_is_multi(server->backend)) { 41 | struct wlr_session *session = server->session; 42 | if (session) { 43 | wlr_log(WLR_DEBUG, "Changing session"); 44 | unsigned vt = keysym - XKB_KEY_XF86Switch_VT_1 + 1; 45 | wlr_session_change_vt(session, vt); 46 | } 47 | } 48 | return true; 49 | } 50 | } 51 | return false; 52 | } 53 | 54 | static void seat_handle_key(struct wl_listener *listener, void *data) { 55 | struct hrt_seat *seat = wl_container_of(listener, seat, keyboard_key); 56 | struct wlr_keyboard_key_event *event = data; 57 | struct hrt_server *server = seat->server; 58 | 59 | xkb_keycode_t keycode = event->keycode + 8; 60 | 61 | const xkb_keysym_t *translated_keysyms; 62 | uint32_t translated_modifiers; 63 | size_t translated_keysyms_len = seat_translate_keysyms( 64 | seat, keycode, &translated_keysyms, &translated_modifiers); 65 | 66 | bool handled = false; 67 | 68 | if (event->state == WL_KEYBOARD_KEY_STATE_PRESSED) { 69 | struct hrt_keypress_info key_info = {.keysyms = translated_keysyms, 70 | .keysyms_len = 71 | translated_keysyms_len, 72 | .modifiers = translated_modifiers, 73 | .wl_key_state = event->state}; 74 | handled = seat->callbacks->keyboard_keypress_event(seat, &key_info); 75 | } 76 | 77 | if (!handled && event->state == WL_KEYBOARD_KEY_STATE_PRESSED) { 78 | handled = execute_hardcoded_bindings(server, translated_keysyms, 79 | translated_modifiers, 80 | translated_keysyms_len); 81 | } 82 | 83 | // TODO: I don't know if this condition is correct 84 | if (!handled) { 85 | wlr_seat_keyboard_notify_key(seat->seat, event->time_msec, 86 | event->keycode, event->state); 87 | } else { 88 | wlr_log(WLR_DEBUG, "Keypress handled by keybinding"); 89 | } 90 | } 91 | 92 | static void seat_handle_modifiers(struct wl_listener *listener, void *data) { 93 | wlr_log(WLR_DEBUG, "Keyboard modifier pressed"); 94 | struct hrt_seat *seat = wl_container_of(listener, seat, keyboard_modifiers); 95 | 96 | wlr_seat_keyboard_notify_modifiers( 97 | seat->seat, &seat->keyboard_group->keyboard.modifiers); 98 | } 99 | 100 | void hrt_keyboard_init(struct hrt_seat *seat) { 101 | seat->keyboard_group = wlr_keyboard_group_create(); 102 | struct wlr_keyboard *kb = &seat->keyboard_group->keyboard; 103 | 104 | struct xkb_rule_names rules = {0}; 105 | struct xkb_context *context = xkb_context_new(XKB_CONTEXT_NO_FLAGS); 106 | struct xkb_keymap *keymap = 107 | xkb_map_new_from_names(context, &rules, XKB_KEYMAP_COMPILE_NO_FLAGS); 108 | wlr_keyboard_set_keymap(kb, keymap); 109 | xkb_keymap_unref(keymap); 110 | xkb_context_unref(context); 111 | 112 | seat->keyboard_key.notify = seat_handle_key; 113 | wl_signal_add(&kb->events.key, &seat->keyboard_key); 114 | seat->keyboard_modifiers.notify = seat_handle_modifiers; 115 | wl_signal_add(&kb->events.modifiers, &seat->keyboard_modifiers); 116 | 117 | wlr_seat_set_keyboard(seat->seat, kb); 118 | } 119 | 120 | void hrt_keyboard_destroy(struct hrt_seat *seat) { 121 | wlr_keyboard_group_destroy(seat->keyboard_group); 122 | } 123 | -------------------------------------------------------------------------------- /heart/src/meson.build: -------------------------------------------------------------------------------- 1 | hrt_source_files += files( 2 | 'cursor.c', 3 | 'input.c', 4 | 'keyboard.c', 5 | 'output.c', 6 | 'output_methods.c', 7 | 'seat.c', 8 | 'server.c', 9 | 'view.c', 10 | 'xdg_shell.c', 11 | ) 12 | -------------------------------------------------------------------------------- /heart/src/output.c: -------------------------------------------------------------------------------- 1 | #include "hrt/hrt_server.h" 2 | #include "wlr/util/log.h" 3 | #include 4 | #include 5 | #include 6 | 7 | #include 8 | #include 9 | #include 10 | 11 | #include 12 | 13 | static void handle_request_state(struct wl_listener *listener, void *data) { 14 | wlr_log(WLR_DEBUG, "Request State Handled"); 15 | struct hrt_output *output = 16 | wl_container_of(listener, output, request_state); 17 | const struct wlr_output_event_request_state *event = data; 18 | wlr_output_commit_state(output->wlr_output, event->state); 19 | } 20 | 21 | static void handle_frame_notify(struct wl_listener *listener, void *data) { 22 | struct hrt_output *output = wl_container_of(listener, output, frame); 23 | struct wlr_scene *scene = output->server->scene; 24 | 25 | struct wlr_scene_output *scene_output = 26 | wlr_scene_get_scene_output(scene, output->wlr_output); 27 | wlr_scene_output_commit(scene_output, NULL); 28 | 29 | struct timespec now; 30 | clock_gettime(CLOCK_MONOTONIC, &now); 31 | wlr_scene_output_send_frame_done(scene_output, &now); 32 | } 33 | 34 | static void handle_output_destroy(struct wl_listener *listener, void *data) { 35 | wlr_log(WLR_DEBUG, "Output destroyed"); 36 | struct hrt_output *output = wl_container_of(listener, output, destroy); 37 | struct hrt_server *server = output->server; 38 | server->output_callback->output_removed(output); 39 | 40 | wl_list_remove(&output->frame.link); 41 | wl_list_remove(&output->request_state.link); 42 | wl_list_remove(&output->destroy.link); 43 | 44 | // wlr_output_layout removes the output by itself. 45 | 46 | free(output); 47 | } 48 | 49 | // temp random float generator 50 | static float float_rand() { 51 | return (float)(rand() / (double)RAND_MAX); /* [0, 1.0] */ 52 | } 53 | 54 | static struct hrt_output *hrt_output_create(struct hrt_server *server, 55 | struct wlr_output *wlr_output) { 56 | struct hrt_output *output = calloc(1, sizeof(struct hrt_output)); 57 | output->wlr_output = wlr_output; 58 | output->server = server; 59 | 60 | output->frame.notify = handle_frame_notify; 61 | wl_signal_add(&wlr_output->events.frame, &output->frame); 62 | output->request_state.notify = handle_request_state; 63 | wl_signal_add(&wlr_output->events.request_state, &output->request_state); 64 | 65 | // temp background color: 66 | // {0.730473, 0.554736, 0.665036, 1.000000} is really pretty. 67 | output->color[0] = float_rand(); 68 | output->color[1] = float_rand(); 69 | output->color[2] = float_rand(); 70 | output->color[3] = 1.0; 71 | 72 | printf("Output color: {%f, %f, %f, %f}\n", output->color[0], 73 | output->color[1], output->color[2], output->color[3]); 74 | 75 | return output; 76 | } 77 | 78 | static void handle_new_output(struct wl_listener *listener, void *data) { 79 | wlr_log(WLR_DEBUG, "New output detected"); 80 | struct hrt_server *server = wl_container_of(listener, server, new_output); 81 | 82 | struct wlr_output *wlr_output = data; 83 | 84 | wlr_output_init_render(wlr_output, server->allocator, server->renderer); 85 | 86 | struct wlr_output_state state; 87 | wlr_output_state_init(&state); 88 | wlr_output_state_set_enabled(&state, true); 89 | 90 | struct wlr_output_mode *mode = wlr_output_preferred_mode(wlr_output); 91 | if (mode != NULL) { 92 | wlr_output_state_set_mode(&state, mode); 93 | } 94 | 95 | if (!wlr_output_commit_state(wlr_output, &state)) { 96 | // FIXME: Actually do some error handling instead of just logging: 97 | wlr_log(WLR_ERROR, "Output state could not be commited"); 98 | } 99 | wlr_output_state_finish(&state); 100 | 101 | struct wlr_output_layout_output *l_output = 102 | wlr_output_layout_add_auto(server->output_layout, wlr_output); 103 | struct wlr_scene_output *scene_output = 104 | wlr_scene_output_create(server->scene, wlr_output); 105 | wlr_scene_output_layout_add_output(server->scene_layout, l_output, 106 | scene_output); 107 | 108 | struct hrt_output *output = hrt_output_create(server, wlr_output); 109 | 110 | output->destroy.notify = handle_output_destroy; 111 | wl_signal_add(&wlr_output->events.destroy, &output->destroy); 112 | 113 | server->output_callback->output_added(output); 114 | } 115 | 116 | static void handle_output_manager_destroy(struct wl_listener *listener, 117 | void *data) { 118 | wlr_log(WLR_DEBUG, "Output Manager destroyed"); 119 | 120 | struct hrt_server *server = 121 | wl_container_of(listener, server, output_manager_destroy); 122 | 123 | wl_list_remove(&server->output_manager_apply.link); 124 | wl_list_remove(&server->output_manager_test.link); 125 | wl_list_remove(&server->output_manager_destroy.link); 126 | } 127 | 128 | static void handle_output_manager_apply(struct wl_listener *listener, 129 | void *data) {} 130 | 131 | static void handle_output_manager_test(struct wl_listener *listener, 132 | void *data) {} 133 | 134 | static void handle_output_layout_changed(struct wl_listener *listener, 135 | void *data) { 136 | struct hrt_server *server = 137 | wl_container_of(listener, server, output_layout_changed); 138 | // struct wlr_output_layout *output_layout = data; 139 | 140 | server->output_callback->output_layout_changed(); 141 | } 142 | 143 | bool hrt_output_init(struct hrt_server *server, 144 | const struct hrt_output_callbacks *callbacks) { 145 | server->output_callback = callbacks; 146 | server->new_output.notify = handle_new_output; 147 | wl_signal_add(&server->backend->events.new_output, &server->new_output); 148 | 149 | server->output_layout = wlr_output_layout_create(server->wl_display); 150 | server->scene = wlr_scene_create(); 151 | server->scene_layout = 152 | wlr_scene_attach_output_layout(server->scene, server->output_layout); 153 | 154 | server->output_layout_changed.notify = handle_output_layout_changed; 155 | wl_signal_add(&server->output_layout->events.change, 156 | &server->output_layout_changed); 157 | 158 | server->output_manager = wlr_output_manager_v1_create(server->wl_display); 159 | 160 | if (!server->output_manager) { 161 | return false; 162 | } 163 | server->output_manager_apply.notify = handle_output_manager_apply; 164 | wl_signal_add(&server->output_manager->events.apply, 165 | &server->output_manager_apply); 166 | server->output_manager_test.notify = handle_output_manager_test; 167 | wl_signal_add(&server->output_manager->events.apply, 168 | &server->output_manager_test); 169 | server->output_manager_destroy.notify = handle_output_manager_destroy; 170 | wl_signal_add(&server->output_manager->events.destroy, 171 | &server->output_manager_destroy); 172 | 173 | // temporary random seed: 174 | srand(time(0)); 175 | 176 | return true; 177 | } 178 | 179 | void hrt_output_destroy(struct hrt_server *server) { 180 | wlr_scene_node_destroy(&server->scene->tree.node); 181 | wl_list_remove(&server->output_layout_changed.link); 182 | // The output layout gets destroyed when the display does: 183 | // wlr_output_layout_destroy(server->output_layout); 184 | } 185 | -------------------------------------------------------------------------------- /heart/src/output_methods.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | void hrt_output_resolution(struct hrt_output *output, int *width, int *height) { 4 | wlr_output_effective_resolution(output->wlr_output, width, height); 5 | } 6 | 7 | void hrt_output_position(struct hrt_output *output, int *x, int *y) { 8 | struct wlr_output_layout_output *l_output = wlr_output_layout_get( 9 | output->server->output_layout, output->wlr_output); 10 | *x = l_output->x; 11 | *y = l_output->y; 12 | } 13 | 14 | char *hrt_output_name(struct hrt_output *output) { 15 | return output->wlr_output->name; 16 | } 17 | 18 | char *hrt_output_make(struct hrt_output *output) { 19 | return output->wlr_output->make; 20 | } 21 | 22 | char *hrt_output_model(struct hrt_output *output) { 23 | return output->wlr_output->model; 24 | } 25 | 26 | char *hrt_output_serial(struct hrt_output *output) { 27 | return output->wlr_output->serial; 28 | } 29 | -------------------------------------------------------------------------------- /heart/src/seat.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | #include 4 | #include 5 | #include 6 | 7 | void hrt_seat_set_cursor_img(struct hrt_seat *seat, char *img_name) { 8 | seat->cursor_image = img_name; 9 | wlr_cursor_set_xcursor(seat->cursor, seat->xcursor_manager, 10 | seat->cursor_image); 11 | } 12 | 13 | void hrt_seat_notify_button(struct hrt_seat *seat, 14 | struct wlr_pointer_button_event *event) { 15 | wlr_seat_pointer_notify_button(seat->seat, event->time_msec, event->button, 16 | event->state); 17 | } 18 | 19 | void hrt_seat_notify_axis(struct hrt_seat *seat, 20 | struct wlr_pointer_axis_event *event) { 21 | wlr_seat_pointer_notify_axis( 22 | seat->seat, event->time_msec, event->orientation, event->delta, 23 | event->delta_discrete, event->source, event->relative_direction); 24 | } 25 | 26 | double hrt_seat_cursor_lx(struct hrt_seat *seat) { 27 | return seat->cursor->x; 28 | } 29 | 30 | double hrt_seat_cursor_ly(struct hrt_seat *seat) { 31 | return seat->cursor->y; 32 | } 33 | -------------------------------------------------------------------------------- /heart/src/server.c: -------------------------------------------------------------------------------- 1 | #include "wlr/util/log.h" 2 | #include "xdg_impl.h" 3 | #include 4 | #include 5 | #include 6 | #include 7 | #include 8 | #include 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | 15 | #include 16 | #include 17 | #include 18 | 19 | static void handle_backend_destroyed(struct wl_listener *listener, void *data) { 20 | struct hrt_server *server = 21 | wl_container_of(listener, server, backend_destroy); 22 | wl_display_terminate(server->wl_display); 23 | } 24 | 25 | bool hrt_server_init(struct hrt_server *server, 26 | const struct hrt_output_callbacks *output_callbacks, 27 | const struct hrt_seat_callbacks *seat_callbacks, 28 | const struct hrt_view_callbacks *view_callbacks, 29 | enum wlr_log_importance log_level) { 30 | wlr_log_init(log_level, NULL); 31 | server->wl_display = wl_display_create(); 32 | server->backend = wlr_backend_autocreate( 33 | wl_display_get_event_loop(server->wl_display), &server->session); 34 | 35 | server->backend_destroy.notify = &handle_backend_destroyed; 36 | wl_signal_add(&server->backend->events.destroy, &server->backend_destroy); 37 | 38 | if (!server->backend) { 39 | return false; 40 | } 41 | 42 | server->renderer = wlr_renderer_autocreate(server->backend); 43 | if (!server->renderer) { 44 | return false; 45 | } 46 | wlr_renderer_init_wl_display(server->renderer, server->wl_display); 47 | 48 | server->allocator = 49 | wlr_allocator_autocreate(server->backend, server->renderer); 50 | if (!server->allocator) { 51 | return false; 52 | } 53 | 54 | server->compositor = 55 | wlr_compositor_create(server->wl_display, 5, server->renderer); 56 | wlr_subcompositor_create(server->wl_display); 57 | wlr_data_device_manager_create(server->wl_display); 58 | 59 | wlr_export_dmabuf_manager_v1_create(server->wl_display); 60 | wlr_screencopy_manager_v1_create(server->wl_display); 61 | wlr_data_control_manager_v1_create(server->wl_display); 62 | wlr_gamma_control_manager_v1_create(server->wl_display); 63 | 64 | server->output_layout = wlr_output_layout_create(server->wl_display); 65 | 66 | server->view_callbacks = view_callbacks; 67 | 68 | if (!hrt_xdg_shell_init(server)) { 69 | return false; 70 | } 71 | 72 | if (!hrt_output_init(server, output_callbacks)) { 73 | return false; 74 | } 75 | if (!hrt_seat_init(&server->seat, server, seat_callbacks)) { 76 | return false; 77 | } 78 | 79 | return true; 80 | } 81 | 82 | static char *prev_wayland_display; 83 | 84 | bool hrt_server_start(struct hrt_server *server) { 85 | const char *socket = wl_display_add_socket_auto(server->wl_display); 86 | 87 | if (!socket) { 88 | goto cleanup; 89 | } 90 | 91 | if (!wlr_backend_start(server->backend)) { 92 | goto cleanup; 93 | } 94 | 95 | prev_wayland_display = getenv("WAYLAND_DISPLAY"); 96 | setenv("WAYLAND_DISPLAY", socket, true); 97 | wlr_log(WLR_INFO, "Running on Wayland socket: %s", socket); 98 | 99 | wl_display_run(server->wl_display); 100 | return true; 101 | 102 | cleanup: 103 | wlr_backend_destroy(server->backend); 104 | return false; 105 | } 106 | 107 | void hrt_server_stop(struct hrt_server *server) { 108 | wl_display_terminate(server->wl_display); 109 | 110 | if (prev_wayland_display) { 111 | setenv("WAYLAND_DISPLAY", prev_wayland_display, true); 112 | } else { 113 | unsetenv("WAYLAND_DISPLAY"); 114 | } 115 | } 116 | 117 | void hrt_server_finish(struct hrt_server *server) { 118 | wl_display_destroy_clients(server->wl_display); 119 | hrt_output_destroy(server); 120 | 121 | wlr_allocator_destroy(server->allocator); 122 | wlr_renderer_destroy(server->renderer); 123 | wlr_backend_destroy(server->backend); 124 | wl_display_destroy(server->wl_display); 125 | } 126 | 127 | struct wlr_scene_tree *hrt_server_scene_tree(struct hrt_server *server) { 128 | return &server->scene->tree; 129 | } 130 | 131 | struct hrt_seat *hrt_server_seat(struct hrt_server *server) { 132 | return &server->seat; 133 | } 134 | -------------------------------------------------------------------------------- /heart/src/view.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | 7 | #include "hrt/hrt_input.h" 8 | #include "hrt/hrt_view.h" 9 | #include "wlr/util/log.h" 10 | 11 | void hrt_view_info(struct hrt_view *view) { 12 | wlr_log(WLR_DEBUG, "New view: %s", view->xdg_toplevel->app_id); 13 | } 14 | 15 | void hrt_view_init(struct hrt_view *view, struct wlr_scene_tree *tree) { 16 | assert(view->scene_tree == NULL && "View already initialized"); 17 | view->scene_tree = wlr_scene_tree_create(tree); 18 | view->width = 0; 19 | view->height = 0; 20 | 21 | struct wlr_scene_tree *xdg_tree = wlr_scene_xdg_surface_create( 22 | view->scene_tree, view->xdg_toplevel->base); 23 | xdg_tree->node.data = view; 24 | view->xdg_surface->data = xdg_tree; 25 | hrt_view_info(view); 26 | } 27 | 28 | void hrt_view_cleanup(struct hrt_view *view) { 29 | if (view->xdg_surface->data) { 30 | // TODO: There's no obvious documentation 31 | // on if the xdg_scene_tree gets cleaned up automatically. 32 | // If it does, this might cause problems: 33 | wlr_scene_node_destroy(view->xdg_surface->data); 34 | } 35 | if (view->scene_tree) { 36 | wlr_scene_node_destroy(&view->scene_tree->node); 37 | } 38 | } 39 | 40 | uint32_t hrt_view_set_size(struct hrt_view *view, int width, int height) { 41 | view->width = width; 42 | view->height = height; 43 | if (view->xdg_surface->initialized) { 44 | return wlr_xdg_toplevel_set_size(view->xdg_toplevel, width, height); 45 | } 46 | return 0; 47 | } 48 | 49 | void hrt_view_set_relative(struct hrt_view *view, int x, int y) { 50 | wlr_scene_node_set_position(&view->scene_tree->node, x, y); 51 | } 52 | 53 | void hrt_view_focus(struct hrt_view *view, struct hrt_seat *seat) { 54 | wlr_log(WLR_DEBUG, "view focused!"); 55 | struct wlr_seat *wlr_seat = seat->seat; 56 | struct wlr_surface *prev_surface = wlr_seat->keyboard_state.focused_surface; 57 | struct wlr_xdg_toplevel *toplevel = view->xdg_toplevel; 58 | 59 | if (prev_surface == toplevel->base->surface) { 60 | // Don't re-focus an already focused surface: 61 | return; 62 | } 63 | struct wlr_keyboard *keyboard = wlr_seat_get_keyboard(wlr_seat); 64 | 65 | wlr_xdg_toplevel_set_activated(toplevel, true); 66 | 67 | if (keyboard != NULL) { 68 | wlr_log(WLR_DEBUG, "Keyboard enter!"); 69 | wlr_seat_keyboard_notify_enter( 70 | wlr_seat, toplevel->base->surface, keyboard->keycodes, 71 | keyboard->num_keycodes, &keyboard->modifiers); 72 | } 73 | } 74 | 75 | void hrt_view_unfocus(struct hrt_view *view, struct hrt_seat *seat) { 76 | struct wlr_xdg_toplevel *toplevel = view->xdg_toplevel; 77 | wlr_xdg_toplevel_set_activated(toplevel, false); 78 | wlr_seat_keyboard_notify_clear_focus(seat->seat); 79 | } 80 | 81 | void hrt_view_set_hidden(struct hrt_view *view, bool hidden) { 82 | wlr_scene_node_set_enabled(&view->scene_tree->node, !hidden); 83 | } 84 | 85 | void hrt_view_reparent(struct hrt_view *view, struct wlr_scene_tree *node) { 86 | wlr_scene_node_reparent(&view->scene_tree->node, node); 87 | } 88 | 89 | void hrt_view_request_close(struct hrt_view *view) { 90 | wlr_xdg_toplevel_send_close(view->xdg_toplevel); 91 | } 92 | -------------------------------------------------------------------------------- /heart/src/xdg_shell.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | #include 5 | #include 6 | #include 7 | 8 | #include "hrt/hrt_input.h" 9 | #include "xdg_impl.h" 10 | #include "hrt/hrt_view.h" 11 | #include "view_impl.h" 12 | 13 | #include 14 | 15 | static void send_dummy_configure(struct hrt_view *view) { 16 | if (view->xdg_toplevel->base->initialized) { 17 | wlr_xdg_surface_schedule_configure(view->xdg_toplevel->base); 18 | } 19 | } 20 | 21 | static void handle_xdg_toplevel_map(struct wl_listener *listener, void *data) { 22 | wlr_log(WLR_DEBUG, "XDG Toplevel Mapped!"); 23 | struct hrt_view *view = wl_container_of(listener, view, map); 24 | send_dummy_configure(view); 25 | } 26 | 27 | static void handle_xdg_toplevel_unmap(struct wl_listener *listener, 28 | void *data) { 29 | wlr_log(WLR_DEBUG, "XDG Toplevel unmapped!"); 30 | } 31 | 32 | static void handle_xdg_toplevel_request_maximize(struct wl_listener *listener, 33 | void *data) { 34 | wlr_log(WLR_DEBUG, "XDG Toplevel request maximize"); 35 | struct hrt_view *view = wl_container_of(listener, view, request_maximize); 36 | // The protocol specifies that after this request is made, we must 37 | // send a configure event. Since we don't support this, 38 | // send one that keeps the previous configuration: 39 | send_dummy_configure(view); 40 | } 41 | 42 | static void handle_xdg_toplevel_request_fullscreen(struct wl_listener *listener, 43 | void *data) { 44 | wlr_log(WLR_DEBUG, "XDG Toplevel request fullscreen"); 45 | struct hrt_view *view = wl_container_of(listener, view, request_maximize); 46 | // The protocol specifies that after this request is made, we must 47 | // send a configure event. Since we don't support this, 48 | // send one that keeps the previous configuration: 49 | send_dummy_configure(view); 50 | } 51 | 52 | static void handle_xdg_toplevel_destroy(struct wl_listener *listener, 53 | void *data) { 54 | wlr_log(WLR_DEBUG, "XDG Toplevel Destroyed!"); 55 | struct hrt_view *view = wl_container_of(listener, view, destroy); 56 | 57 | view->destroy_handler(view); 58 | 59 | wl_list_remove(&view->map.link); 60 | wl_list_remove(&view->unmap.link); 61 | wl_list_remove(&view->destroy.link); 62 | wl_list_remove(&view->commit.link); 63 | wl_list_remove(&view->request_fullscreen.link); 64 | wl_list_remove(&view->request_maximize.link); 65 | 66 | hrt_view_cleanup(view); 67 | free(view); 68 | } 69 | 70 | static void handle_xdg_toplevel_commit(struct wl_listener *listener, 71 | void *data) { 72 | struct hrt_view *view = wl_container_of(listener, view, commit); 73 | if (view->xdg_toplevel->base->initial_commit) { 74 | view->new_view_handler(view); 75 | } 76 | } 77 | 78 | static struct hrt_view * 79 | create_view_from_xdg_surface(struct wlr_xdg_toplevel *xdg_toplevel, 80 | const struct hrt_view_callbacks *callbacks) { 81 | struct hrt_view *view = calloc(1, sizeof(struct hrt_view)); 82 | view->xdg_toplevel = xdg_toplevel; 83 | struct wlr_xdg_surface *xdg_surface = xdg_toplevel->base; 84 | // TODO: Maybe remove view->xdg_surface? We can get to it via the toplevel. 85 | view->xdg_surface = xdg_surface; 86 | // Should we just put struct hrt_view_callbacks in view objects? 87 | view->destroy_handler = callbacks->view_destroyed; 88 | view->new_view_handler = callbacks->new_view; 89 | 90 | view->map.notify = handle_xdg_toplevel_map; 91 | wl_signal_add(&xdg_surface->surface->events.map, &view->map); 92 | view->unmap.notify = handle_xdg_toplevel_unmap; 93 | wl_signal_add(&xdg_surface->surface->events.unmap, &view->unmap); 94 | view->destroy.notify = handle_xdg_toplevel_destroy; 95 | wl_signal_add(&xdg_surface->events.destroy, &view->destroy); 96 | view->commit.notify = handle_xdg_toplevel_commit; 97 | wl_signal_add(&xdg_toplevel->base->surface->events.commit, &view->commit); 98 | 99 | view->request_fullscreen.notify = handle_xdg_toplevel_request_fullscreen; 100 | wl_signal_add(&xdg_toplevel->events.request_fullscreen, 101 | &view->request_fullscreen); 102 | view->request_maximize.notify = &handle_xdg_toplevel_request_maximize; 103 | wl_signal_add(&xdg_toplevel->events.request_maximize, 104 | &view->request_maximize); 105 | // TODO: We need to listen to the commit event so we can send the configure 106 | // message on first commit 107 | 108 | return view; 109 | } 110 | 111 | static void handle_xdg_popup_commit(struct wl_listener *listener, void *data) { 112 | struct hrt_xdg_popup *popup = wl_container_of(listener, popup, commit); 113 | if (popup->xdg_popup->base->initial_commit) { 114 | wlr_xdg_surface_schedule_configure(popup->xdg_popup->base); 115 | } 116 | } 117 | 118 | static void handle_xdg_popup_destroy(struct wl_listener *listener, void *data) { 119 | struct hrt_xdg_popup *popup = wl_container_of(listener, popup, destroy); 120 | 121 | wl_list_remove(&popup->destroy.link); 122 | wl_list_remove(&popup->commit.link); 123 | 124 | free(popup); 125 | } 126 | 127 | static void handle_new_xdg_popup(struct wl_listener *listener, void *data) { 128 | wlr_log(WLR_DEBUG, "New xdg popup received"); 129 | struct hrt_server *server = 130 | wl_container_of(listener, server, new_xdg_popup); 131 | struct wlr_xdg_popup *xdg_popup = data; 132 | 133 | // The front end doesn't need to know about popups; wlroots handles it for 134 | // us. we do need to set some internal data so that they can be rendered 135 | // though. 136 | struct wlr_xdg_surface *parent = 137 | wlr_xdg_surface_try_from_wlr_surface(xdg_popup->parent); 138 | struct wlr_scene_tree *parent_tree = parent->data; 139 | 140 | // The parent view might not have been initizlized properly. In that case, 141 | // it isn't being displayed, so we just ignore it: 142 | if (parent_tree) { 143 | xdg_popup->base->data = 144 | wlr_scene_xdg_surface_create(parent_tree, xdg_popup->base); 145 | struct hrt_xdg_popup *popup = calloc(1, sizeof(*popup)); 146 | popup->xdg_popup = xdg_popup; 147 | 148 | popup->commit.notify = handle_xdg_popup_commit; 149 | wl_signal_add(&xdg_popup->base->surface->events.commit, &popup->commit); 150 | 151 | popup->destroy.notify = handle_xdg_popup_destroy; 152 | wl_signal_add(&xdg_popup->events.destroy, &popup->destroy); 153 | 154 | } else { 155 | wlr_log(WLR_ERROR, 156 | "Encountered XDG Popup without properly configured parent"); 157 | } 158 | } 159 | 160 | static void handle_new_xdg_toplevel(struct wl_listener *listener, void *data) { 161 | wlr_log(WLR_DEBUG, "New XDG Toplevel received"); 162 | struct hrt_server *server = 163 | wl_container_of(listener, server, new_xdg_toplevel); 164 | struct wlr_xdg_toplevel *toplevel = data; 165 | // Initialization occurs in two steps so the consumer can place the view 166 | // where it needs to go; in order to create a scene tree node, it must have 167 | // a parent. We don't have it until the callback. 168 | create_view_from_xdg_surface(toplevel, server->view_callbacks); 169 | } 170 | 171 | bool hrt_xdg_shell_init(struct hrt_server *server) { 172 | server->xdg_shell = wlr_xdg_shell_create(server->wl_display, 3); 173 | server->new_xdg_popup.notify = handle_new_xdg_popup; 174 | wl_signal_add(&server->xdg_shell->events.new_popup, &server->new_xdg_popup); 175 | 176 | server->new_xdg_toplevel.notify = handle_new_xdg_toplevel; 177 | wl_signal_add(&server->xdg_shell->events.new_toplevel, 178 | &server->new_xdg_toplevel); 179 | return true; 180 | } 181 | -------------------------------------------------------------------------------- /lisp/bindings/hrt-bindings.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:hrt) 2 | 3 | ;; next section imported from file build/include/hrt/hrt_input.h 4 | 5 | (cffi:defcstruct hrt-server) 6 | 7 | (cffi:defcstruct hrt-seat-callbacks) 8 | 9 | (cffi:defcstruct hrt-seat 10 | (server (:pointer (:struct hrt-server))) 11 | (cursor :pointer #| (:struct wlr-cursor) |# ) 12 | (keyboard-group :pointer #| (:struct wlr-keyboard-group) |# ) 13 | (xcursor-manager :pointer #| (:struct wlr-xcursor-manager) |# ) 14 | (seat :pointer #| (:struct wlr-seat) |# ) 15 | (inputs (:struct wl-list)) 16 | (new-input (:struct wl-listener)) 17 | (motion (:struct wl-listener)) 18 | (motion-absolute (:struct wl-listener)) 19 | (button (:struct wl-listener)) 20 | (axis (:struct wl-listener)) 21 | (frame (:struct wl-listener)) 22 | (request-cursor (:struct wl-listener)) 23 | (keyboard-key (:struct wl-listener)) 24 | (keyboard-modifiers (:struct wl-listener)) 25 | (callbacks (:pointer (:struct hrt-seat-callbacks))) 26 | (cursor-image (:pointer :char))) 27 | 28 | (cffi:defcstruct hrt-keypress-info 29 | (keysyms :pointer #| xkb-keysym-t |# ) 30 | (modifiers :uint32) 31 | (keysyms-len :size) 32 | (wl-key-state :int #| enum wl-keyboard-key-state |#)) 33 | 34 | (cffi:defcstruct hrt-seat-callbacks 35 | (button-event :pointer #| function ptr void (struct hrt_seat *, struct wlr_pointer_button_event *) |#) 36 | (wheel-event :pointer #| function ptr void (struct hrt_seat *, struct wlr_pointer_axis_event *) |#) 37 | (keyboard-keypress-event :pointer #| function ptr _Bool (struct hrt_seat *, struct hrt_keypress_info *) |#)) 38 | 39 | (cffi:defcstruct hrt-input 40 | (wlr-input-device :pointer #| (:struct wlr-input-device) |# ) 41 | (seat (:pointer (:struct hrt-seat))) 42 | (link (:struct wl-list)) 43 | (destroy (:struct wl-listener))) 44 | 45 | (cffi:defcfun ("hrt_seat_init" hrt-seat-init) :bool 46 | (seat (:pointer (:struct hrt-seat))) 47 | (server (:pointer (:struct hrt-server))) 48 | (callbacks (:pointer (:struct hrt-seat-callbacks)))) 49 | 50 | (cffi:defcfun ("hrt_seat_destroy" hrt-seat-destroy) :void 51 | (seat (:pointer (:struct hrt-seat)))) 52 | 53 | (cffi:defcfun ("hrt_cursor_init" hrt-cursor-init) :bool 54 | (seat (:pointer (:struct hrt-seat))) 55 | (server (:pointer (:struct hrt-server)))) 56 | 57 | (cffi:defcfun ("hrt_cursor_destroy" hrt-cursor-destroy) :void 58 | (seat (:pointer (:struct hrt-seat)))) 59 | 60 | (cffi:defcfun ("hrt_keyboard_init" hrt-keyboard-init) :void 61 | (seat (:pointer (:struct hrt-seat)))) 62 | 63 | (cffi:defcfun ("hrt_keyboard_destroy" hrt-keyboard-destroy) :void 64 | (seat (:pointer (:struct hrt-seat)))) 65 | 66 | (cffi:defcfun ("hrt_seat_set_cursor_img" hrt-seat-set-cursor-img) :void 67 | "Set the seat's default cursor image to the given cursor name. 68 | 69 | Does not take ownership of the string. 70 | 71 | See themes section of man xcursor(3) to find where to find valid cursor 72 | names." 73 | (seat (:pointer (:struct hrt-seat))) 74 | (img-name (:pointer :char))) 75 | 76 | (cffi:defcfun ("hrt_seat_notify_button" hrt-seat-notify-button) :void 77 | (seat (:pointer (:struct hrt-seat))) 78 | (event :pointer #| (:struct wlr-pointer-button-event) |# )) 79 | 80 | (cffi:defcfun ("hrt_seat_notify_axis" hrt-seat-notify-axis) :void 81 | (seat (:pointer (:struct hrt-seat))) 82 | (event :pointer #| (:struct wlr-pointer-axis-event) |# )) 83 | 84 | (cffi:defcfun ("hrt_seat_cursor_lx" hrt-seat-cursor-lx) :double 85 | (seat (:pointer (:struct hrt-seat)))) 86 | 87 | (cffi:defcfun ("hrt_seat_cursor_ly" hrt-seat-cursor-ly) :double 88 | (seat (:pointer (:struct hrt-seat)))) 89 | 90 | ;; next section imported from file build/include/hrt/hrt_view.h 91 | 92 | (cffi:defcstruct hrt-view) 93 | 94 | (cffi:defctype view-destroy-handler :pointer #| function ptr void (struct hrt_view *) |#) 95 | 96 | (cffi:defctype new-view-handler :pointer #| function ptr void (struct hrt_view *) |#) 97 | 98 | (cffi:defcstruct hrt-view 99 | (width :int) 100 | (height :int) 101 | (xdg-surface :pointer #| (:struct wlr-xdg-surface) |# ) 102 | (xdg-toplevel :pointer #| (:struct wlr-xdg-toplevel) |# ) 103 | (scene-tree :pointer #| (:struct wlr-scene-tree) |# ) 104 | (map (:struct wl-listener)) 105 | (unmap (:struct wl-listener)) 106 | (commit (:struct wl-listener)) 107 | (destroy (:struct wl-listener)) 108 | (request-maximize (:struct wl-listener)) 109 | (request-fullscreen (:struct wl-listener)) 110 | (new-view-handler new-view-handler) 111 | (destroy-handler view-destroy-handler)) 112 | 113 | (cffi:defcstruct hrt-view-callbacks 114 | (new-view new-view-handler) 115 | (view-destroyed view-destroy-handler)) 116 | 117 | (cffi:defcfun ("hrt_view_init" hrt-view-init) :void 118 | "Fully initialize the view and place it in the given scene tree." 119 | (view (:pointer (:struct hrt-view))) 120 | (tree :pointer #| (:struct wlr-scene-tree) |# )) 121 | 122 | (cffi:defcfun ("hrt_view_info" hrt-view-info) :void 123 | (view (:pointer (:struct hrt-view)))) 124 | 125 | (cffi:defcfun ("hrt_view_set_size" hrt-view-set-size) :uint32 126 | "Request that this view be the given size. Returns the associated configure 127 | serial." 128 | (view (:pointer (:struct hrt-view))) 129 | (width :int) 130 | (height :int)) 131 | 132 | (cffi:defcfun ("hrt_view_set_relative" hrt-view-set-relative) :void 133 | "Sets the view to the given coordinates relative to its parent." 134 | (view (:pointer (:struct hrt-view))) 135 | (x :int) 136 | (y :int)) 137 | 138 | (cffi:defcfun ("hrt_view_focus" hrt-view-focus) :void 139 | "Focus the given view and perform the needed tasks to make 140 | it visible to the user." 141 | (view (:pointer (:struct hrt-view))) 142 | (seat (:pointer (:struct hrt-seat)))) 143 | 144 | (cffi:defcfun ("hrt_view_unfocus" hrt-view-unfocus) :void 145 | "Unfocus the given view." 146 | (view (:pointer (:struct hrt-view))) 147 | (seat (:pointer (:struct hrt-seat)))) 148 | 149 | (cffi:defcfun ("hrt_view_set_hidden" hrt-view-set-hidden) :void 150 | "Stop the given view from being displayed" 151 | (view (:pointer (:struct hrt-view))) 152 | (hidden :bool)) 153 | 154 | (cffi:defcfun ("hrt_view_reparent" hrt-view-reparent) :void 155 | (view (:pointer (:struct hrt-view))) 156 | (node :pointer #| (:struct wlr-scene-tree) |# )) 157 | 158 | (cffi:defcfun ("hrt_view_request_close" hrt-view-request-close) :void 159 | "Request that the view be closed. This is the \"nice\" version 160 | that is the same as clicking the close button on window decorations. 161 | It does not garentee that the application actually closes, but 162 | well behaved ones should." 163 | (view (:pointer (:struct hrt-view)))) 164 | 165 | ;; next section imported from file build/include/hrt/hrt_output.h 166 | 167 | (cffi:defcstruct hrt-output 168 | (wlr-output :pointer #| (:struct wlr-output) |# ) 169 | (server (:pointer (:struct hrt-server))) 170 | (request-state (:struct wl-listener)) 171 | (frame (:struct wl-listener)) 172 | (destroy (:struct wl-listener)) 173 | (color :float :count 4)) 174 | 175 | (cffi:defcstruct hrt-output-callbacks 176 | (output-added :pointer #| function ptr void (struct hrt_output *) |#) 177 | (output-removed :pointer #| function ptr void (struct hrt_output *) |#) 178 | (output-layout-changed :pointer #| function ptr void () |#)) 179 | 180 | (cffi:defcfun ("hrt_output_init" hrt-output-init) :bool 181 | (server (:pointer (:struct hrt-server))) 182 | (callbacks (:pointer (:struct hrt-output-callbacks)))) 183 | 184 | (cffi:defcfun ("hrt_output_destroy" hrt-output-destroy) :void 185 | (server (:pointer (:struct hrt-server)))) 186 | 187 | (cffi:defcfun ("hrt_output_resolution" hrt-output-resolution) :void 188 | "Get the effective output resolution of the output that can be used to 189 | set the width and height of views." 190 | (output (:pointer (:struct hrt-output))) 191 | (width (:pointer :int)) 192 | (height (:pointer :int))) 193 | 194 | (cffi:defcfun ("hrt_output_position" hrt-output-position) :void 195 | (output (:pointer (:struct hrt-output))) 196 | (x (:pointer :int)) 197 | (y (:pointer :int))) 198 | 199 | (cffi:defcfun ("hrt_output_name" hrt-output-name) :string 200 | (output (:pointer (:struct hrt-output)))) 201 | 202 | (cffi:defcfun ("hrt_output_make" hrt-output-make) :string 203 | (output (:pointer (:struct hrt-output)))) 204 | 205 | (cffi:defcfun ("hrt_output_model" hrt-output-model) :string 206 | (output (:pointer (:struct hrt-output)))) 207 | 208 | (cffi:defcfun ("hrt_output_serial" hrt-output-serial) :string 209 | (output (:pointer (:struct hrt-output)))) 210 | 211 | ;; next section imported from file build/include/hrt/hrt_server.h 212 | 213 | (cffi:defcstruct hrt-server 214 | (wl-display :pointer #| (:struct wl-display) |# ) 215 | (backend :pointer #| (:struct wlr-backend) |# ) 216 | (backend-destroy (:struct wl-listener)) 217 | (session :pointer #| (:struct wlr-session) |# ) 218 | (renderer :pointer #| (:struct wlr-renderer) |# ) 219 | (compositor :pointer #| (:struct wlr-compositor) |# ) 220 | (allocator :pointer #| (:struct wlr-allocator) |# ) 221 | (scene :pointer #| (:struct wlr-scene) |# ) 222 | (scene-layout :pointer #| (:struct wlr-scene-output-layout) |# ) 223 | (new-output (:struct wl-listener)) 224 | (output-manager :pointer #| (:struct wlr-output-manager-v1) |# ) 225 | (output-layout :pointer #| (:struct wlr-output-layout) |# ) 226 | (output-layout-changed (:struct wl-listener)) 227 | (output-manager-apply (:struct wl-listener)) 228 | (output-manager-test (:struct wl-listener)) 229 | (output-manager-destroy (:struct wl-listener)) 230 | (seat (:struct hrt-seat)) 231 | (xdg-shell :pointer #| (:struct wlr-xdg-shell) |# ) 232 | (new-xdg-toplevel (:struct wl-listener)) 233 | (new-xdg-popup (:struct wl-listener)) 234 | (output-callback (:pointer (:struct hrt-output-callbacks))) 235 | (view-callbacks (:pointer (:struct hrt-view-callbacks)))) 236 | 237 | (cffi:defcfun ("hrt_server_init" hrt-server-init) :bool 238 | (server (:pointer (:struct hrt-server))) 239 | (output-callbacks (:pointer (:struct hrt-output-callbacks))) 240 | (seat-callbacks (:pointer (:struct hrt-seat-callbacks))) 241 | (view-callbacks (:pointer (:struct hrt-view-callbacks))) 242 | (log-level :int #| enum wlr-log-importance |#)) 243 | 244 | (cffi:defcfun ("hrt_server_start" hrt-server-start) :bool 245 | (server (:pointer (:struct hrt-server)))) 246 | 247 | (cffi:defcfun ("hrt_server_stop" hrt-server-stop) :void 248 | (server (:pointer (:struct hrt-server)))) 249 | 250 | (cffi:defcfun ("hrt_server_finish" hrt-server-finish) :void 251 | (server (:pointer (:struct hrt-server)))) 252 | 253 | (cffi:defcfun ("hrt_server_scene_tree" hrt-server-scene-tree) :pointer #| (:struct wlr-scene-tree) |# 254 | (server (:pointer (:struct hrt-server)))) 255 | 256 | (cffi:defcfun ("hrt_server_seat" hrt-server-seat) (:pointer (:struct hrt-seat)) 257 | (server (:pointer (:struct hrt-server)))) 258 | -------------------------------------------------------------------------------- /lisp/bindings/hrt-bindings.yml: -------------------------------------------------------------------------------- 1 | output: lisp/bindings/hrt-bindings.lisp 2 | package: hrt 3 | pkg-config: 4 | - wlroots 5 | arguments: 6 | - "-DWLR_USE_UNSTABLE" 7 | - "-Iheart/include" 8 | files: 9 | - build/include/hrt/hrt_input.h 10 | - build/include/hrt/hrt_view.h 11 | - build/include/hrt/hrt_output.h 12 | - build/include/hrt/hrt_server.h 13 | pointer-expansion: 14 | include: 15 | match: "hrt.*" 16 | -------------------------------------------------------------------------------- /lisp/bindings/hrt-libs.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:hrt) 2 | 3 | (cffi:define-foreign-library libheart 4 | (:unix "libheart.so")) 5 | 6 | (cffi:define-foreign-library libwlroots 7 | (:unix "libwlroots-0.18.so")) 8 | 9 | (defun load-foreign-libraries () 10 | (cffi:use-foreign-library libwlroots) 11 | (cffi:use-foreign-library libheart)) 12 | -------------------------------------------------------------------------------- /lisp/bindings/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:mahogany/core 2 | (:use :cl #:wayland-server-core #:xkb) 3 | (:local-nicknames (#:mh/interface #:mahogany/wm-interface)) 4 | (:nicknames #:hrt) 5 | (:export #:hrt-output-callbacks 6 | #:hrt-seat-callbacks 7 | #:hrt-view-callbacks 8 | #:new-view 9 | #:hrt-view 10 | #:view-destroyed 11 | #:hrt-seat 12 | #:hrt-seat-notify-button 13 | #:hrt-seat-notify-axis 14 | #:hrt-seat-cursor-lx 15 | #:hrt-seat-cursor-ly 16 | #:hrt-output 17 | #:hrt-output-name 18 | #:hrt-output-make 19 | #:hrt-output-model 20 | #:hrt-output-serial 21 | #:hrt-keypress-info 22 | ;; output callbacks 23 | #:output-added 24 | #:output-removed 25 | #:output-layout-changed 26 | ;; output methods: 27 | #:output-resolution 28 | #:output-position 29 | ;; view-methods 30 | #:view 31 | #:view-init 32 | #:view-reparent 33 | #:view-request-close 34 | #:view-hrt-view 35 | #:focus-view 36 | #:unfocus-view 37 | #:view-set-hidden 38 | ;; seat callbacks 39 | #:button-event #:wheel-event #:keyboard-keypress-event 40 | #:hrt-server 41 | #:hrt-server-scene-tree 42 | #:hrt-server-seat 43 | #:hrt-server-init 44 | #:hrt-server-start 45 | #:hrt-server-stop 46 | #:hrt-server-finish 47 | ;; keypress info slots: 48 | #:keysyms 49 | #:modifiers 50 | #:keysyms-len 51 | #:wl-key-state 52 | #:load-foreign-libraries)) 53 | 54 | (defpackage #:wlr 55 | (:use :cl #:wayland-server-core) 56 | (:export 57 | #:scene-tree-create 58 | #:scene-node-destroy 59 | #:scene-node-set-position 60 | #:scene-node-reparent 61 | #:scene-node-set-enabled 62 | ;; scene node slot: 63 | #:node)) 64 | -------------------------------------------------------------------------------- /lisp/bindings/wlr-bindings.yml: -------------------------------------------------------------------------------- 1 | output: lisp/bindings/wlr-bindings.lisp 2 | package: wlr 3 | pkg-config: 4 | - wlroots 5 | arguments: 6 | - "-DWLR_USE_UNSTABLE" 7 | - "-Ibuild/include/wlroots-0.18/" 8 | files: 9 | - heart/subprojects/wlroots/include/wlr/util/addon.h 10 | - heart/subprojects/wlroots/include/wlr/util/box.h 11 | - heart/subprojects/wlroots/include/wlr/types/wlr_scene.h 12 | pointer-expansion: 13 | exclude: 14 | match: 15 | - ".*" 16 | -------------------------------------------------------------------------------- /lisp/bindings/wrappers.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:hrt) 2 | 3 | (defmacro with-return-by-value (variables &body body) 4 | `(cffi:with-foreign-objects ,variables 5 | ,@body 6 | (values ,@(loop for pair in variables 7 | collect `(cffi:mem-ref ,(first pair) ,(second pair)))))) 8 | 9 | (defun output-resolution (output) 10 | (declare (type cffi:foreign-pointer output)) 11 | (with-return-by-value ((width :int) (height :int)) 12 | (hrt-output-resolution output width height))) 13 | 14 | (defun output-position (output) 15 | (declare (type cffi:foreign-pointer output)) 16 | (with-return-by-value ((x :int) (y :int)) 17 | (hrt-output-position output x y))) 18 | 19 | (defstruct (view (:constructor %make-view (hrt-view))) 20 | (hrt-view (cffi:null-pointer) :type cffi:foreign-pointer :read-only t)) 21 | 22 | (defun view-init (hrt-view scene-tree) 23 | (let ((view (%make-view hrt-view))) 24 | (hrt-view-init hrt-view scene-tree) 25 | (the view view))) 26 | 27 | (declaim (inline focus-view)) 28 | (defun focus-view (view seat) 29 | (declare (type view view)) 30 | (hrt-view-focus (view-hrt-view view) seat)) 31 | 32 | (declaim (inline unfocus-view)) 33 | (defun unfocus-view (view seat) 34 | (declare (type view view)) 35 | (hrt-view-unfocus (view-hrt-view view) seat)) 36 | 37 | (declaim (inline view-set-hidden)) 38 | (defun view-set-hidden (view hidden) 39 | (declare (type view view) 40 | (type boolean hidden)) 41 | (hrt-view-set-hidden (view-hrt-view view) hidden)) 42 | 43 | (declaim (inline view-reparent)) 44 | (defun view-reparent (view new-parent) 45 | (declare (type view view)) 46 | (hrt-view-reparent (view-hrt-view view) new-parent)) 47 | 48 | (declaim (inline view-request-close)) 49 | (defun view-request-close (view) 50 | (declare (type view view)) 51 | (hrt-view-request-close (view-hrt-view view))) 52 | 53 | (defmethod mh/interface:set-dimensions ((view view) width height) 54 | (hrt-view-set-size (view-hrt-view view) width height)) 55 | 56 | (defmethod mh/interface:set-position ((view view) x y) 57 | (hrt-view-set-relative (view-hrt-view view) x y)) 58 | -------------------------------------------------------------------------------- /lisp/config/config-system.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:config-system 2 | (:use :cl #:alexandria) 3 | (:export config-info 4 | config-info-name 5 | config-info-type 6 | config-info-default 7 | config-info-doc 8 | config-info-value 9 | describe-all-config-info 10 | describe-config-info 11 | config-error 12 | config-not-found-error 13 | invalid-datum-error 14 | define-config-enum 15 | defconfig 16 | all-config-info 17 | get-config-info 18 | set-config 19 | set-config-atomic 20 | reset-config 21 | with-atomic-update)) 22 | 23 | (in-package #:config-system) 24 | 25 | (defparameter *config-vars* (make-hash-table) 26 | "Map that holds all of the configuration variables for the system") 27 | 28 | (defstruct config-info 29 | (name t :type symbol :read-only t) 30 | (type nil :read-only t) ; this is a type specifier 31 | (default nil :read-only t) 32 | (value nil) 33 | (doc "" :type string :read-only t)) 34 | 35 | (defun %full-symbol-string (symb) 36 | "Get the full name of the symbol complete with the package name" 37 | (declare (type symbol symb)) 38 | (let* ((pkg (symbol-package symb)) 39 | (pkg-name (package-name pkg)) 40 | (symb-name (symbol-name symb))) 41 | (concatenate 'string pkg-name 42 | (multiple-value-bind (symb status) (find-symbol symb-name pkg-name) 43 | (declare (ignore symb)) 44 | (if (eql status :internal) 45 | "::" 46 | ":")) 47 | symb-name))) 48 | 49 | (defun describe-config-info (info &optional (stream *standard-output*)) 50 | (declare (type config-info info)) 51 | (format stream "Setting Name: ~A~% Documentation:~% ~A~% Default value: ~S~%Current value: ~S~%" 52 | (%full-symbol-string (config-info-name info)) 53 | (config-info-doc info) 54 | (config-info-default info) 55 | (config-info-value info)) 56 | (alexandria:when-let ((type-specifier (config-info-type info))) 57 | (format stream "Type designator: ~A~%" type-specifier))) 58 | 59 | (defun %make-match-readtable (str) 60 | "Try to make the given string have the correct case for a symbol" 61 | (declare (type string str)) 62 | (ccase (readtable-case *readtable*) 63 | ;; we are missing :invert, but I don't feel like implementing that. 64 | (:upcase (string-upcase str)) 65 | (:downcase (string-downcase str)) 66 | (:preserve str))) 67 | 68 | (defun %map-config-matching (name-matches package-matches function) 69 | (let ((name-scanner (ppcre:create-scanner (%make-match-readtable name-matches))) 70 | (pkg-scanner (ppcre:create-scanner (%make-match-readtable package-matches)))) 71 | (maphash (lambda (key value) 72 | (declare (ignorable key)) 73 | (let ((pkg-name (package-name (symbol-package (config-info-name value)))) 74 | (symb-name (symbol-name (config-info-name value)))) 75 | (when (and (funcall name-scanner symb-name 0 (length symb-name)) 76 | (funcall pkg-scanner pkg-name 0 (length pkg-name))) 77 | (funcall function value)))) 78 | *config-vars*))) 79 | 80 | (defun describe-all-config-info (&key (stream *standard-output*) (name-matches ".*") (package-matches ".*")) 81 | (%map-config-matching name-matches package-matches 82 | (lambda (info) 83 | (describe-config-info info stream) 84 | (format stream "~%")))) 85 | 86 | (define-condition config-error (error) ()) 87 | 88 | (define-condition invalid-datum-error (config-error) 89 | ((place-symbol :initarg :place :initform nil 90 | :accessor invalid-datum-error-place 91 | :type symbol) 92 | (value :initarg :value :initform nil 93 | :accessor invalid-datum-error-value)) 94 | (:report 95 | (lambda (c s) 96 | (with-slots (place-symbol value) c 97 | (format s "The value ~S is invalid for variable ~S." value place-symbol))))) 98 | 99 | (define-condition config-not-found-error (config-error) 100 | ((place-symbol :initarg :place :initform nil 101 | :accessor config-not-found-error-place 102 | :type symbol) 103 | (alternatives :initarg :alternatives :initform nil 104 | :accessor config-not-found-alternatives 105 | :type list)) 106 | (:report 107 | (lambda (c s) 108 | (with-slots (place-symbol alternatives) c 109 | (if alternatives 110 | (format s "Setting ~A not found. Did you mean one of these? ~A" 111 | (%full-symbol-string place-symbol) alternatives) 112 | (format s "Setting ~A not found." (%full-symbol-string place-symbol))))))) 113 | 114 | (defun %add-config-info (name default-value type-specifier documentation) 115 | (setf (gethash name *config-vars*) 116 | (make-config-info :name name :default default-value 117 | :type type-specifier :doc documentation))) 118 | 119 | (defmacro defconfig (name default type-specifier documentation) 120 | "Create and register a configurable variable with the given default value, 121 | type specifier, and documentation" 122 | (check-type documentation string) 123 | (check-type name symbol) 124 | (with-gensyms (default-value) 125 | `(progn 126 | (let* ((,default-value ,default)) 127 | (if (typep ,default-value (quote ,type-specifier)) 128 | (progn 129 | (%add-config-info (quote ,name) ,default (quote ,type-specifier) ,documentation) 130 | (declaim (type ,type-specifier ,name)) 131 | (defvar ,name ,default-value ,@(when documentation 132 | (list documentation)))) 133 | (error 'invalid-datum-error :place (quote ,name) :value ,default-value)))))) 134 | 135 | (defun all-config-info (&key (name-matches ".*") (package-matches ".*")) 136 | "List all of the available customizable settings matching the given criteria." 137 | (let ((accumulate (list))) 138 | (%map-config-matching name-matches package-matches 139 | (lambda (info) 140 | (push info accumulate))) 141 | accumulate)) 142 | 143 | (defun %find-possible-settings (setting-name table) 144 | "Find the settings that have the same symbol name of SETTING-NAME but are in a different package" 145 | (declare (type hash-table table) 146 | (type symbol setting-name)) 147 | (let ((name (symbol-name setting-name))) 148 | ;; for some reason, the package isn't always included with the symbol name even 149 | ;; if the top level isn't in the symbol's package, so we need to manually get the symbol name. 150 | (mapcar #'%full-symbol-string 151 | (remove-if-not (lambda (x) (string-equal (symbol-name x) name)) 152 | (mapcar #'config-info-name (hash-table-values table)))))) 153 | 154 | (defun get-config-info (setting-name) 155 | "Find the info for the config variable stored in the symbol SETTING-NAME." 156 | (declare (type symbol setting-name)) 157 | (if-let ((info (gethash setting-name *config-vars*))) 158 | (progn 159 | ;; Since the setting values can be changed outside of the API, 160 | ;; we need to update the value of the varible here. 161 | (setf (config-info-value info) (symbol-value setting-name)) 162 | info))) 163 | 164 | (defmacro %set-config (setting-name value) 165 | (with-gensyms (actual-value info) 166 | `(let ((,actual-value ,value)) 167 | (if-let ((,info (get-config-info (quote ,setting-name)))) 168 | (if (typep ,actual-value (config-info-type ,info)) 169 | (setf ,setting-name ,actual-value) 170 | (error 'invalid-datum-error :place (quote ,setting-name) :value ,actual-value)) 171 | (error 'config-not-found-error 172 | :place (quote ,setting-name) 173 | :alternatives (%find-possible-settings (quote ,setting-name) *config-vars*)))))) 174 | 175 | (defmacro set-config (&rest settings) 176 | "Set the given configuration variables to the given values. Used like setf" 177 | (assert (= (mod (length settings) 2) 0)) 178 | (let ((accumulate (list 'progn))) 179 | (do ((cur settings (cddr cur))) 180 | ((not cur)) 181 | (push (list '%set-config (first cur) (second cur)) accumulate)) 182 | (nreverse accumulate))) 183 | 184 | (defmacro reset-config (&rest settings) 185 | "Reset the list of settings to their default values" 186 | (let ((accumulate (list))) 187 | ;; add everything backwards, as the list is built in reverse 188 | (dolist (setting-name settings) 189 | (check-type setting-name symbol) 190 | (push `(config-info-default (get-config-info (quote ,setting-name))) accumulate) 191 | (push setting-name accumulate)) 192 | (push 'setf accumulate) 193 | accumulate)) 194 | 195 | (defun %make-storage-pair (symbol) 196 | (declare (type symbol symbol)) 197 | (cons (gensym (symbol-name symbol)) symbol)) 198 | 199 | (defmacro with-atomic-update (settings &body body) 200 | "If an error occurs during the execution of BODY, reset the provided variables to their original value" 201 | (let ((setting-pairs (mapcar #'%make-storage-pair settings))) 202 | `(let ,(let ((settings-list (list))) 203 | (dolist (item setting-pairs (nreverse settings-list)) 204 | (push (list (car item) (cdr item)) settings-list))) 205 | (handler-case 206 | (progn 207 | ,@body) 208 | (warning (w) 209 | (warn w)) 210 | (error (condition) 211 | (setf ,@(loop for pair in setting-pairs 212 | append (list (cdr pair) (car pair)))) 213 | (error condition)) 214 | (t (c) 215 | (signal c)))))) 216 | 217 | (defmacro set-config-atomic (&rest settings) 218 | "Set the listed settings to the provided values. If an error signal is raised during execution, 219 | all of the settings are set back to their original value" 220 | (assert (= (mod (length settings) 2) 0)) 221 | (let ((setting-vars (do ((cur settings (cddr cur)) 222 | (vars (list))) 223 | ((not cur) (nreverse vars)) 224 | (push (first cur) vars)))) 225 | `(with-atomic-update ,setting-vars 226 | (set-config ,@settings)))) 227 | -------------------------------------------------------------------------------- /lisp/globals.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:mahogany) 2 | 3 | (declaim (type mahogany-state *compositor-state*)) 4 | (defglobal *compositor-state* (make-instance 'mahogany-state)) 5 | -------------------------------------------------------------------------------- /lisp/group.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:mahogany) 2 | 3 | (defun make-mahogany-group (name number scene-tree) 4 | (let ((scene-node (wlr:scene-tree-create scene-tree))) 5 | (wlr:scene-node-set-enabled scene-node nil) 6 | (log-string :debug "Created group ~A" name) 7 | (%make-mahogany-group name number scene-node))) 8 | 9 | (defun destroy-mahogany-group (group scene-tree) 10 | (alexandria:when-let ((views (mahogany-group-views group))) 11 | (log-string :error "The following views are associated with a group that is being deleted. They will be orphaned:~%~4T ~S" views) 12 | (dolist (v views) 13 | (hrt:view-reparent v scene-tree))) 14 | (wlr:scene-node-destroy (mahogany-group-scene-tree group)) 15 | (log-string :debug "Destroyed group ~A" (mahogany-group-name group))) 16 | 17 | (defun group-suspend (group seat) 18 | (declare (type mahogany-group group)) 19 | (with-accessors ((focused-frame mahogany-group-current-frame) 20 | (scene-tree mahogany-group-scene-tree)) 21 | group 22 | (log-string :debug "Suspending group ~A" (mahogany-group-name group)) 23 | (when focused-frame 24 | (tree:unmark-frame-focused focused-frame seat)) 25 | (wlr:scene-node-set-enabled scene-tree nil))) 26 | 27 | (defun group-wakeup (group seat) 28 | (declare (type mahogany-group group)) 29 | (with-accessors ((focused-frame mahogany-group-current-frame) 30 | (scene-tree mahogany-group-scene-tree)) 31 | group 32 | (log-string :debug "Waking up group ~A" (mahogany-group-name group)) 33 | (when focused-frame 34 | (tree:mark-frame-focused focused-frame seat)) 35 | (wlr:scene-node-set-enabled scene-tree t))) 36 | 37 | (defun group-transfer-views (group to-transfer) 38 | (declare (type mahogany-group group to-transfer)) 39 | (let ((scene-tree (mahogany-group-scene-tree group)) 40 | (hidden-list (mahogany-group-hidden-views group))) 41 | (dolist (other-view (mahogany-group-views to-transfer)) 42 | (group-remove-view to-transfer other-view scene-tree) 43 | (push other-view (mahogany-group-views group)) 44 | (%add-hidden hidden-list other-view)))) 45 | 46 | (defun group-focus-frame (group frame seat) 47 | (with-accessors ((current-frame mahogany-group-current-frame)) group 48 | (unless (eql current-frame frame) 49 | (when current-frame 50 | (group-unfocus-frame group current-frame seat)) 51 | (tree:mark-frame-focused frame seat) 52 | (setf current-frame frame)))) 53 | 54 | (defun group-unfocus-frame (group frame seat) 55 | (with-accessors ((current-frame mahogany-group-current-frame)) group 56 | (tree:unmark-frame-focused frame seat) 57 | (setf current-frame nil))) 58 | 59 | (defun group-add-output (group output seat) 60 | (declare (type mahogany-output output) 61 | (type mahogany-group group)) 62 | (with-accessors ((output-map mahogany-group-output-map) 63 | (tree-container mahogany-group-tree-container) 64 | (current-frame mahogany-group-current-frame)) 65 | group 66 | (multiple-value-bind (x y) (hrt:output-position (mahogany-output-hrt-output output)) 67 | (multiple-value-bind (width height) (hrt:output-resolution (mahogany-output-hrt-output output)) 68 | (let ((new-tree (tree:tree-container-add tree-container 69 | :x x :y y :width width :height height))) 70 | (setf (gethash (mahogany-output-full-name output) output-map) new-tree) 71 | (when (not current-frame) 72 | (group-focus-frame group (tree:find-first-leaf new-tree) seat))))) 73 | (log-string :trace "Group map: ~S" output-map))) 74 | 75 | (defun group-reconfigure-outputs (group outputs) 76 | "Re-examine where the outputs are and adjust the trees that are associated with them 77 | to match." 78 | (with-accessors ((output-map mahogany-group-output-map)) group 79 | (loop for mh-output across outputs 80 | do (with-accessors ((full-name mahogany-output-full-name) 81 | (hrt-output mahogany-output-hrt-output)) 82 | mh-output 83 | (alexandria:when-let ((tree (gethash full-name output-map))) 84 | (multiple-value-bind (x y) (hrt:output-position hrt-output) 85 | (set-position tree x y)) 86 | (multiple-value-bind (width height) (hrt:output-resolution hrt-output) 87 | (set-dimensions tree width height))))))) 88 | 89 | (defun %first-hash-table-value (table) 90 | (declare (type hash-table table) 91 | (optimize (speed 3) (safety 0))) 92 | (with-hash-table-iterator (iter table) 93 | (multiple-value-bind (found key value) (iter) 94 | (declare (ignore found key)) 95 | value))) 96 | 97 | (defun group-remove-output (group output seat) 98 | (declare (type mahogany-output output) 99 | (type mahogany-group group)) 100 | (with-accessors ((output-map mahogany-group-output-map)) group 101 | (let* ((output-name (mahogany-output-full-name output)) 102 | (tree (gethash output-name output-map))) 103 | (remhash output-name output-map) 104 | (when (equalp tree (tree:find-root-frame (mahogany-group-current-frame group))) 105 | (group-unfocus-frame group (mahogany-group-current-frame group) seat) 106 | (alexandria:when-let ((other-tree (%first-hash-table-value output-map))) 107 | (group-focus-frame group (tree:find-first-leaf other-tree) seat))) 108 | (when (and (mahogany-group-current-frame group) (= 0 (hash-table-count output-map))) 109 | (group-unfocus-frame group (mahogany-group-current-frame group) seat)) 110 | (tree:remove-frame tree)))) 111 | 112 | (defun %add-hidden (hidden-list view) 113 | (log-string :trace "Hiding view ~S" view) 114 | (ring-list:add-item hidden-list view) 115 | (hrt:view-set-hidden view t)) 116 | 117 | (defun %swap-next-hidden (hidden-list view) 118 | (let ((swapped (ring-list:swap-next hidden-list view))) 119 | (hrt:view-set-hidden view t) 120 | (hrt:view-set-hidden swapped nil) 121 | swapped)) 122 | 123 | (defun %swap-prev-hidden (hidden-list view) 124 | (let ((swapped (ring-list:swap-previous hidden-list view))) 125 | (hrt:view-set-hidden view t) 126 | (hrt:view-set-hidden swapped nil) 127 | swapped)) 128 | 129 | (defun %pop-hidden-item (hidden-list) 130 | (alexandria:when-let ((popped (ring-list:pop-item hidden-list))) 131 | (hrt:view-set-hidden popped nil) 132 | popped)) 133 | 134 | (defun %group-add-view (group view) 135 | (declare (type mahogany-group group) 136 | (type hrt:view view)) 137 | (with-accessors ((views mahogany-group-views) 138 | (outputs mahogany-group-output-map) 139 | (hidden mahogany-group-hidden-views)) 140 | group 141 | (push view (mahogany-group-views group)) 142 | (alexandria:when-let ((current-frame (mahogany-group-current-frame group))) 143 | (alexandria:when-let ((view (tree:frame-view current-frame))) 144 | (%add-hidden hidden view)) 145 | (setf (tree:frame-view current-frame) view)))) 146 | 147 | (defun group-add-initialize-view (group view-ptr) 148 | (declare (type mahogany-group group) 149 | (type cffi:foreign-pointer view-ptr)) 150 | (let ((view (hrt:view-init view-ptr (mahogany-group-scene-tree group)))) 151 | (%group-add-view group view) 152 | view)) 153 | 154 | (defun group-remove-view (group view &optional new-scene-tree) 155 | (declare (type mahogany-group group)) 156 | (with-accessors ((view-list mahogany-group-views) 157 | (output-map mahogany-group-output-map) 158 | (hidden mahogany-group-hidden-views)) 159 | group 160 | (dolist (tree (tree:tree-children (mahogany-group-tree-container group))) 161 | (dolist (f (mahogany/tree:get-populated-frames tree)) 162 | (when (equalp (tree:frame-view f) view) 163 | (setf (tree:frame-view f) nil) 164 | (alexandria:when-let ((new-view (%pop-hidden-item hidden))) 165 | (setf (tree:frame-view f) new-view))))) 166 | (when new-scene-tree 167 | (hrt:view-reparent view new-scene-tree)) 168 | (ring-list:remove-item hidden view) 169 | (setf view-list (remove view view-list :test #'equalp)))) 170 | 171 | (defmethod tree:find-empty-frame ((group mahogany-group)) 172 | (with-hash-table-iterator (iter (mahogany-group-output-map group)) 173 | (tagbody 174 | :top (multiple-value-bind (found name frame) (iter) 175 | (declare (ignore name)) 176 | (when found 177 | (alexandria:if-let ((view-frame (tree:find-empty-frame frame))) 178 | (return-from tree:find-empty-frame view-frame) 179 | (go :top))))))) 180 | 181 | (defun group-maximize-current-frame (group) 182 | "Remove all of the splits in the current window tree and replae it with the 183 | currently focused frame" 184 | (declare (type mahogany-group group)) 185 | (let* ((current-frame (mahogany-group-current-frame group)) 186 | (tree-root (mahogany/tree:find-root-frame current-frame))) 187 | (flet ((hide-and-disable (view-frame) 188 | (alexandria:when-let ((view (tree:frame-view view-frame))) 189 | (%add-hidden (mahogany-group-hidden-views group) view)))) 190 | (tree:replace-frame tree-root current-frame #'hide-and-disable)))) 191 | 192 | (defun group-next-hidden (group) 193 | (declare (type mahogany-group group)) 194 | (let ((current-frame (mahogany-group-current-frame group)) 195 | (hidden-views (mahogany-group-hidden-views group)) 196 | (next-view)) 197 | (when (> (ring-list:ring-list-size hidden-views) 0) 198 | (alexandria:if-let ((view (tree:frame-view current-frame))) 199 | (setf next-view (%swap-next-hidden hidden-views view)) 200 | (setf next-view (%pop-hidden-item hidden-views))) 201 | (setf (tree:frame-view current-frame) next-view)))) 202 | 203 | (defun group-previous-hidden (group) 204 | (declare (type mahogany-group group)) 205 | (let ((current-frame (mahogany-group-current-frame group)) 206 | (hidden-views (mahogany-group-hidden-views group)) 207 | (next-view)) 208 | (when (> (ring-list:ring-list-size hidden-views) 0) 209 | (alexandria:if-let ((view (tree:frame-view current-frame))) 210 | (setf next-view (%swap-prev-hidden hidden-views view)) 211 | (setf next-view (%pop-hidden-item hidden-views))) 212 | (setf (tree:frame-view current-frame) next-view)))) 213 | 214 | (defun group-next-frame (group seat) 215 | (declare (type mahogany-group group)) 216 | (let* ((current-frame (mahogany-group-current-frame group)) 217 | (next-frame (tree:frame-next current-frame))) 218 | (group-focus-frame group next-frame seat))) 219 | 220 | (defun group-prev-frame (group seat) 221 | (declare (type mahogany-group group)) 222 | (let* ((current-frame (mahogany-group-current-frame group)) 223 | (prev-frame (tree:frame-prev current-frame))) 224 | (group-focus-frame group prev-frame seat))) 225 | -------------------------------------------------------------------------------- /lisp/input.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:mahogany) 2 | 3 | (config-system:defconfig *keyboard-focus-type* :click 4 | (member :click-and-wheel :click :ignore :sloppy) 5 | "How keyboard focus is controlled by the mouse") 6 | 7 | (defun execute-command (function key-sequence seat) 8 | (funcall function key-sequence seat)) 9 | 10 | (defun check-and-run-keybinding (key seat key-state) 11 | (declare (type key key) (optimize (speed 3))) 12 | (when (not (key-modifier-key-p key)) 13 | (let* ((handling-keybinding (key-state-active-p key-state))) 14 | (log-string :trace "Already handling keybinding: ~A" handling-keybinding) 15 | (flet ((reset-state () 16 | (log-string :trace "Reseting keyboard state") 17 | (server-keystate-reset *compositor-state*))) 18 | (prog1 19 | (multiple-value-bind (matched result) (key-state-advance key key-state) 20 | (cond 21 | (;; A known keybinding was pressed: 22 | matched 23 | (when result 24 | (execute-command result (key-state-sequence key-state) seat) 25 | (reset-state)) 26 | t) 27 | (;; No keybinding was pressed but we were expecting one. 28 | ;; Since this is canceling the keybinding, we still behave like we found somthing 29 | handling-keybinding 30 | (reset-state) 31 | t) 32 | ;; No action was taken, return nil 33 | (t nil)))))))) 34 | 35 | (defun handle-key-event (state key seat event-state) 36 | (declare (type key key) 37 | (type bit event-state) 38 | (optimize(speed 3))) 39 | (let ((key-state (mahogany-state-key-state state))) 40 | (declare (type key-state key-state)) 41 | (if (= event-state 1) 42 | (or (check-and-run-keybinding key seat key-state) 43 | (when (eql 65307 (key-keysym key)) 44 | (server-stop *compositor-state*) 45 | t)) 46 | (key-state-active-p key-state)))) 47 | 48 | (defun %focus-frame-under-cursor (seat) 49 | (let* ((group (mahogany-current-group *compositor-state*)) 50 | (found (tree:frame-at (mahogany-group-tree-container group) 51 | (hrt:hrt-seat-cursor-lx seat) 52 | (hrt:hrt-seat-cursor-ly seat)))) 53 | (group-focus-frame group found seat))) 54 | 55 | (cffi:defcallback handle-mouse-wheel-event :void ((seat (:pointer (:struct hrt:hrt-seat))) 56 | (event :pointer)) 57 | (when (eq *keyboard-focus-type* :click-and-wheel) 58 | (%focus-frame-under-cursor seat)) 59 | (hrt:hrt-seat-notify-axis seat event)) 60 | 61 | (cffi:defcallback handle-mouse-button-event :void ((seat (:pointer (:struct hrt:hrt-seat))) 62 | (event :pointer)) 63 | (when (or (eq *keyboard-focus-type* :click) (eq *keyboard-focus-type* :click-and-wheel)) 64 | (%focus-frame-under-cursor seat)) 65 | (hrt:hrt-seat-notify-button seat event)) 66 | 67 | (cffi:defcallback keyboard-callback :bool 68 | ((seat (:pointer (:struct hrt:hrt-seat))) 69 | (info (:pointer (:struct hrt:hrt-keypress-info)))) 70 | (cffi:with-foreign-slots ((hrt:keysyms hrt:modifiers hrt:keysyms-len hrt:wl-key-state) 71 | info (:struct hrt:hrt-keypress-info)) 72 | ;; I'm not sure why this is an array, but it's what tinywl does: 73 | (dotimes (i hrt:keysyms-len) 74 | (let ((key (make-key (cffi:mem-aref hrt:keysyms :uint32 i) hrt:modifiers))) 75 | (when (handle-key-event *compositor-state* key seat hrt:wl-key-state) 76 | (return t)))))) 77 | -------------------------------------------------------------------------------- /lisp/interfaces/view-interface.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:mahogany/wm-interface 2 | (:use :cl) 3 | (:export #:set-position 4 | #:set-dimensions)) 5 | 6 | (in-package #:mahogany/wm-interface) 7 | 8 | (defgeneric set-position (object x y) 9 | (:documentation "Set the x-y position of the object. If the object 10 | is part of a scene tree, this sets the position relative to the 11 | parent object.")) 12 | 13 | (defgeneric set-dimensions (object width height) 14 | (:documentation "Set the dimensions of the the object.")) 15 | -------------------------------------------------------------------------------- /lisp/key-bindings.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:mahogany) 2 | 3 | (defun handle-server-stop (sequence seat) 4 | (declare (ignore sequence seat)) 5 | (server-stop *compositor-state*)) 6 | 7 | (defun open-terminal (sequence seat) 8 | (declare (ignore sequence seat)) 9 | (sys:open-terminal)) 10 | 11 | (defun open-kcalc (sequence seat) 12 | (declare (ignore sequence seat)) 13 | (uiop:launch-program (sys:find-program "kcalc"))) 14 | 15 | (defun split-frame-h (sequence seat) 16 | (declare (ignore sequence seat)) 17 | (let ((frame (mahogany-current-frame *compositor-state*))) 18 | (when frame 19 | (tree:split-frame-h frame :direction :right)))) 20 | 21 | (defun split-frame-v (sequence seat) 22 | (declare (ignore sequence seat)) 23 | (let ((frame (mahogany-current-frame *compositor-state*))) 24 | (when frame 25 | (tree:split-frame-v frame :direction :bottom)))) 26 | 27 | (defun maximize-current-frame (sequence seat) 28 | (declare (ignore sequence seat)) 29 | (let ((group (mahogany-current-group *compositor-state*))) 30 | (group-maximize-current-frame group))) 31 | 32 | (defun close-current-view (sequence seat) 33 | (declare (ignore sequence seat)) 34 | (let ((frame (mahogany-current-frame *compositor-state*))) 35 | (alexandria:when-let ((view (mahogany/tree:frame-view frame))) 36 | (hrt:view-request-close view)))) 37 | 38 | (defun next-view (sequence seat) 39 | "Raise the next hidden view in the current group" 40 | (declare (ignore sequence seat)) 41 | (let ((group (mahogany-current-group *compositor-state*))) 42 | (group-next-hidden group))) 43 | 44 | (defun previous-view (sequence seat) 45 | "Raise the next hidden view in the current group" 46 | (declare (ignore sequence seat)) 47 | (let ((group (mahogany-current-group *compositor-state*))) 48 | (group-previous-hidden group))) 49 | 50 | (defun next-frame (sequence seat) 51 | (declare (ignore sequence)) 52 | (let ((group (mahogany-current-group *compositor-state*))) 53 | (group-next-frame group seat))) 54 | 55 | (defun prev-frame (sequence seat) 56 | (declare (ignore sequence)) 57 | (let ((group (mahogany-current-group *compositor-state*))) 58 | (group-prev-frame group seat))) 59 | 60 | (defun gnew (sequence seat) 61 | (declare (ignore sequence seat)) 62 | (mahogany-state-group-add *compositor-state*)) 63 | 64 | (defun gkill (sequence seat) 65 | (declare (ignore sequence seat)) 66 | (let ((current-group (mahogany-current-group *compositor-state*))) 67 | (mahogany-state-group-remove *compositor-state* current-group))) 68 | 69 | (defun gnext (sequence seat) 70 | (declare (ignore sequence seat)) 71 | (state-next-hidden-group *compositor-state*)) 72 | 73 | (defun gprev (sequence seat) 74 | (declare (ignore sequence seat)) 75 | (state-next-hidden-group *compositor-state*)) 76 | 77 | 78 | (let* ((group-map (define-kmap 79 | (kbd "c") #'gnew 80 | (kbd "k") #'gkill 81 | (kbd "n") #'gnext 82 | (kbd "p") #'gprev)) 83 | (root-map (define-kmap 84 | (kbd "o") #'next-frame 85 | (kbd "O") #'prev-frame 86 | (kbd "q") #'handle-server-stop 87 | (kbd "k") #'close-current-view 88 | (kbd "c") #'open-terminal 89 | (kbd "s") #'split-frame-v 90 | (kbd "S") #'split-frame-h 91 | (kbd "Q") #'maximize-current-frame 92 | (kbd "n") #'next-view 93 | (kbd "p") #'previous-view 94 | (kbd "+") #'open-kcalc 95 | (kbd "g") group-map))) 96 | (setf (mahogany-state-keybindings *compositor-state*) 97 | (list (define-kmap 98 | (kbd "C-t") root-map)))) 99 | -------------------------------------------------------------------------------- /lisp/keyboard/key.lisp: -------------------------------------------------------------------------------- 1 | ;; A large part of this file is taken directly from stumpwm: 2 | 3 | ;; Copyright (C) 2003-2008 Shawn Betts 4 | ;; 5 | ;; This file is part of stumpwm. 6 | ;; 7 | ;; stumpwm is free software; you can redistribute it and/or modify 8 | ;; it under the terms of the GNU General Public License as published by 9 | ;; the Free Software Foundation; either version 2, or (at your option) 10 | ;; any later version. 11 | 12 | ;; stumpwm is distributed in the hope that it will be useful, 13 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | ;; GNU General Public License for more details. 16 | 17 | ;; You should have received a copy of the GNU General Public License 18 | ;; along with this software; see the file COPYING. If not, see 19 | ;; . 20 | 21 | ;; Commentary: 22 | ;; 23 | ;; This file handles keymaps 24 | ;; 25 | ;; Code: 26 | 27 | (in-package #:mahogany/keyboard) 28 | 29 | (defstruct (key (:constructor make-key (keysym modifier-mask))) 30 | (keysym 0 :read-only t :type (unsigned-byte 32)) 31 | (modifier-mask 0 :read-only t :type (unsigned-byte 32))) 32 | 33 | (declaim (type (unsigned-byte 32) 34 | +modifier-shift+ 35 | +modifier-caps+ 36 | +modifier-ctrl+ 37 | +modifier-alt+ 38 | +modifier-mod2+ 39 | +modifier-mod3+ 40 | +modifier-super+ 41 | +modifier-mod5+)) 42 | (defconstant +modifier-shift+ (ash 1 0)) 43 | (defconstant +modifier-caps+ (ash 1 1)) 44 | (defconstant +modifier-ctrl+ (ash 1 2)) 45 | (defconstant +modifier-alt+ (ash 1 3)) 46 | (defconstant +modifier-mod2+ (ash 1 4)) 47 | (defconstant +modifier-mod3+ (ash 1 5)) 48 | (defconstant +modifier-super+ (ash 1 6)) 49 | (defconstant +modifier-mod5+ (ash 1 7)) 50 | 51 | (defun print-key (key &optional (stream *standard-output*)) 52 | (declare (type key key) (type stream stream) 53 | (optimize (safety 1))) 54 | (let ((mod (key-modifier-mask key))) 55 | (format stream "(Keycode: ~A Modifiers: (" (key-keysym key)) 56 | (when (not (= mod 0)) 57 | (when (/= 0 (logand +modifier-shift+ mod)) 58 | (format stream "SHIFT")) 59 | (when (/= 0 (logand +modifier-caps+ mod)) 60 | (format stream "CAPS")) 61 | (when (/= 0 (logand +modifier-ctrl+ mod)) 62 | (format stream "CONTROL")) 63 | (when (/= 0 (logand +modifier-alt+ mod)) 64 | (format stream "ALT")) 65 | ;; FIXME: one of these modifiers is probably the hyper key 66 | (when (/= 0 (logand +modifier-mod2+ mod)) 67 | (format stream "MOD2")) 68 | (when (/= 0 (logand +modifier-mod3+ mod)) 69 | (format stream "MOD3")) 70 | (when (/= 0 (logand +modifier-super+ mod)) 71 | (format stream "SUPER")) 72 | (when (/= 0 (logand +modifier-mod5+ mod)) 73 | (format stream "MOD5")))) 74 | (format stream "))")) 75 | 76 | (defun %report-kbd-parse-error (c stream) 77 | (format stream "Failed to parse key string: ~s." (kbd-parse-error-string c)) 78 | (when-let ((reason (kbd-parse-error-reason c))) 79 | (format stream "~%Reason: ~A" reason))) 80 | 81 | (define-condition kbd-parse-error (mahogany-error) 82 | ((string :initarg :string 83 | :reader kbd-parse-error-string) 84 | (reason :initarg :reason :reader kbd-parse-error-reason 85 | :initform nil)) 86 | (:report %report-kbd-parse-error) 87 | (:documentation "Raised when a kbd string failed to parse.")) 88 | 89 | (defun %parse-mods (mods end) 90 | "MODS is a sequence of #\- pairs. Returns a bitfield with 91 | the appropriate bits set for the given modifiers chars" 92 | (unless (evenp end) 93 | (error 'kbd-parse-error :string mods 94 | :reason "Did you forget to separate modifier characters with '-'?")) 95 | (let ((mod-mask 0)) 96 | (declare (type (unsigned-byte 32) mod-mask)) 97 | (loop for i from 0 below end by 2 98 | when (char/= (char mods (1+ i)) #\-) 99 | do (error 'kbd-parse-error :string mods) 100 | do (setf mod-mask (logior mod-mask 101 | (case (char mods i) 102 | (#\M +modifier-alt+) 103 | (#\A +modifier-alt+) 104 | (#\C +modifier-ctrl+) 105 | (#\H (error 'kbd-parse-error 106 | :string mods 107 | :reason 108 | "Fixme: don't know which key is the Hyper modifier.")) 109 | (#\s +modifier-super+) 110 | (#\S +modifier-shift+) 111 | (t (error 'kbd-parse-error :string mods 112 | :reason (format nil "Unknown modifer character ~A" (char mods i)))))))) 113 | mod-mask)) 114 | 115 | (defun key-modifier-key-p (key) 116 | "Check if the given key is a modifier key like Shift or Control" 117 | (declare (type key key)) 118 | ;; FIXME: don't hardcode these values. 119 | ;; Using a cleverer datastructure might be good too. 120 | (find (key-keysym key) #(65515 ; super 121 | 65507 ; Control_L 122 | 65508 ; Control_R 123 | 65513 ; alt 124 | 65505 ; Shift_L 125 | 65506 ; Shilf_R 126 | ))) 127 | 128 | 129 | (defun parse-key (string) 130 | "Parse STRING and return a key structure. Raise an error of type 131 | kbd-parse if the key failed to parse." 132 | (let* ((p (when (> (length string) 2) 133 | (position #\- string :from-end t :end (- (length string) 1)))) 134 | (mod-mask (if p (%parse-mods string (1+ p)) 0)) 135 | (key-part (subseq string (if p (1+ p) 0))) 136 | (keysym (stumpwm-name->keysym key-part))) 137 | (if keysym 138 | (make-key keysym mod-mask) 139 | (error 'kbd-parse-error :string string)))) 140 | 141 | ;; The stumpwm version can take key specs split by a newline, 142 | ;; but since only the first value is returned out of those, 143 | ;; it should be okay to just accept a single spec here for now: 144 | (defun kbd (key) 145 | "This compiles a key string into a key structure." 146 | ;; TODO: make this function accept a list of strings or 147 | ;; a string of keyspecs separated by spaces 148 | (parse-key key)) 149 | -------------------------------------------------------------------------------- /lisp/keyboard/keytrans.lisp: -------------------------------------------------------------------------------- 1 | ;; A large portion of this file was taken from Stumpwm's keytrans.lisp file: 2 | 3 | ;; Copyright (C) 2006-2008 Matthew Kennedy 4 | ;; 5 | ;; This file is part of stumpwm. 6 | ;; 7 | ;; stumpwm is free software; you can redistribute it and/or modify 8 | ;; it under the terms of the GNU General Public License as published by 9 | ;; the Free Software Foundation; either version 2, or (at your option) 10 | ;; any later version. 11 | 12 | ;; stumpwm is distributed in the hope that it will be useful, 13 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | ;; GNU General Public License for more details. 16 | 17 | ;; You should have received a copy of the GNU General Public License 18 | ;; along with this software; see the file COPYING. If not, see 19 | ;; . 20 | 21 | ;; Commentary: 22 | ;; 23 | ;; Translate between stumpwm key names and keysym names. 24 | ;; 25 | ;; Code: 26 | 27 | (in-package #:mahogany/keyboard) 28 | 29 | (defvar *stumpwm-name->keysym-name-translations* (make-hash-table :test #'equal) 30 | "Hashtable mapping from stumpwm key names to keysym names.") 31 | 32 | (defun define-keysym-name (stumpwm-name keysym-name) 33 | "Define a mapping from a STUMPWM-NAME to KEYSYM-NAME. 34 | This function is used to translate Emacs-like names to keysym 35 | names." 36 | (setf (gethash stumpwm-name *stumpwm-name->keysym-name-translations*) 37 | keysym-name)) 38 | 39 | (defun stumpwm-name->keysym-name (stumpwm-name) 40 | (multiple-value-bind (value present-p) 41 | (gethash stumpwm-name *stumpwm-name->keysym-name-translations*) 42 | (declare (ignore present-p)) 43 | value)) 44 | 45 | (defun keysym-name->stumpwm-name (keysym-name) 46 | (maphash (lambda (k v) 47 | (when (equal v keysym-name) 48 | (return-from keysym-name->stumpwm-name k))) 49 | *stumpwm-name->keysym-name-translations*)) 50 | 51 | (defun stumpwm-name->keysym (stumpwm-name) 52 | "Return the keysym corresponding to STUMPWM-NAME. 53 | If no mapping for STUMPWM-NAME exists, then fallback by calling 54 | XKB:KEYSYM-FROM-NAME." 55 | (let ((keysym-name (stumpwm-name->keysym-name stumpwm-name))) 56 | (xkb:keysym-from-name (or keysym-name stumpwm-name) :no-flags))) 57 | 58 | (defun keysym->stumpwm-name (keysym) 59 | "Return the stumpwm key name corresponding to KEYSYM. 60 | If no mapping for the stumpwm key name exists, then fall back by 61 | callying XKB:KEYSYM-GET-NAME." 62 | (let ((keysym-name (xkb:keysym-get-name keysym))) 63 | (or (keysym-name->stumpwm-name keysym-name) 64 | keysym-name))) 65 | 66 | (define-keysym-name "RET" "Return") 67 | (define-keysym-name "ESC" "Escape") 68 | (define-keysym-name "TAB" "Tab") 69 | (define-keysym-name "DEL" "BackSpace") 70 | (define-keysym-name "SPC" "space") 71 | (define-keysym-name "!" "exclam") 72 | (define-keysym-name "\"" "quotedbl") 73 | (define-keysym-name "$" "dollar") 74 | (define-keysym-name "£" "sterling") 75 | (define-keysym-name "%" "percent") 76 | (define-keysym-name "&" "ampersand") 77 | (define-keysym-name "'" "quoteright") ;deprecated 78 | (define-keysym-name "'" "apostrophe") 79 | (define-keysym-name "`" "quoteleft") ;deprecated 80 | (define-keysym-name "`" "grave") 81 | (define-keysym-name "&" "ampersand") 82 | (define-keysym-name "(" "parenleft") 83 | (define-keysym-name ")" "parenright") 84 | (define-keysym-name "*" "asterisk") 85 | (define-keysym-name "+" "plus") 86 | (define-keysym-name "," "comma") 87 | (define-keysym-name "-" "minus") 88 | (define-keysym-name "." "period") 89 | (define-keysym-name "/" "slash") 90 | (define-keysym-name ":" "colon") 91 | (define-keysym-name ";" "semicolon") 92 | (define-keysym-name "<" "less") 93 | (define-keysym-name "=" "equal") 94 | (define-keysym-name ">" "greater") 95 | (define-keysym-name "?" "question") 96 | (define-keysym-name "@" "at") 97 | (define-keysym-name "[" "bracketleft") 98 | (define-keysym-name "\\" "backslash") 99 | (define-keysym-name "]" "bracketright") 100 | (define-keysym-name "^" "asciicircum") 101 | (define-keysym-name "_" "underscore") 102 | (define-keysym-name "#" "numbersign") 103 | (define-keysym-name "{" "braceleft") 104 | (define-keysym-name "|" "bar") 105 | (define-keysym-name "}" "braceright") 106 | (define-keysym-name "~" "asciitilde") 107 | (define-keysym-name "<" "quoteleft") 108 | (define-keysym-name ">" "quoteright") 109 | (define-keysym-name "«" "guillemotleft") 110 | (define-keysym-name "»" "guillemotright") 111 | (define-keysym-name "À" "Agrave") 112 | (define-keysym-name "à" "agrave") 113 | (define-keysym-name "Ç" "Ccedilla") 114 | (define-keysym-name "ç" "ccedilla") 115 | (define-keysym-name "É" "Eacute") 116 | (define-keysym-name "é" "eacute") 117 | (define-keysym-name "È" "Egrave") 118 | (define-keysym-name "è" "egrave") 119 | (define-keysym-name "Ê" "Ecircumflex") 120 | (define-keysym-name "ê" "ecircumflex") 121 | -------------------------------------------------------------------------------- /lisp/keyboard/kmap.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:mahogany/keyboard) 2 | 3 | (defstruct (binding (:constructor make-binding (key command))) 4 | (key nil :type key) 5 | command) 6 | 7 | (defstruct kmap 8 | ;; TODO: Maybe this should just be a hash table instead? 9 | (bindings (make-array 0 :element-type 'binding :adjustable t :fill-pointer t) 10 | :type (vector binding) 11 | :read-only t)) 12 | 13 | (defun define-key (map key cmd) 14 | "Add a binding from the given key to the given command in the keymap. If the command 15 | is nil, remove the binding for the given key." 16 | (declare (type kmap map) 17 | (type key key)) 18 | (let ((bindings (kmap-bindings map)) 19 | (new-binding (make-binding key cmd))) 20 | (dotimes (i (length bindings)) 21 | (let ((val (binding-key (aref bindings i)))) 22 | (when (equalp val key) 23 | (setf (aref bindings i) new-binding) 24 | (return-from define-key new-binding)))) 25 | (vector-push-extend new-binding bindings 1)) 26 | map) 27 | 28 | (defmacro define-kmap (&body body) 29 | "Create a keymap and add the given bindings to it. 30 | 31 | Example: 32 | (define-kmap 33 | (kbd \"C-s\") 'foo 34 | (kbd \"M-;\") 'bar)" 35 | (let* ((map-var (gensym "kmap"))) 36 | `(let ((,map-var (make-kmap))) 37 | ,@(do* ((next body (cddr next)) 38 | (key (car body) (car next)) 39 | (binding (cadr body) (cadr next)) 40 | (forms nil forms)) 41 | ((null next) (nreverse forms)) 42 | (push `(define-key ,map-var ,key ,binding) forms)) 43 | ,map-var))) 44 | 45 | (declaim (inline %kmap-symbol-p)) 46 | (defun %kmap-symbol-p (x) 47 | (and (symbolp x) 48 | (boundp x) 49 | (kmap-p (symbol-value x)))) 50 | 51 | (declaim (inline %kmap-symbol-p)) 52 | (defun kmap-or-kmap-symbol-p (x) 53 | (or (kmap-p x) 54 | (%kmap-symbol-p x))) 55 | 56 | (defun kmap-lookup (keymap key) 57 | "Find the command associated with the given key in the keymap" 58 | (declare (type key key) 59 | (type kmap keymap)) 60 | (let ((ret (find key (kmap-bindings keymap) :key 'binding-key :test 'equalp))) 61 | (when ret 62 | (binding-command ret)))) 63 | 64 | (defstruct (key-state (:constructor make-key-state (kmaps))) 65 | (sequence nil :type list) 66 | (kmaps nil :type list)) 67 | 68 | (declaim (inline key-state-active-p)) 69 | (defun key-state-active-p (key-state) 70 | "Return a truthy value if the key state has advanced beyond it's 71 | initial state." 72 | (declare (type key-state key-state)) 73 | (car (key-state-sequence key-state))) 74 | 75 | (defun key-state-advance (key bindings-state) 76 | "Advance the key state with the given key by destructively modifying the 77 | given state and its properties. 78 | Arguments: 79 | KEY: The key object to advance the state with 80 | BINDINGS-STATE: The key-state object to advance 81 | 82 | Returns: 83 | First value: T if something was matched, nil otherwise. 84 | Second value: The value of the leaf node if one was found." 85 | (declare (type key-state bindings-state) 86 | (type key key) 87 | (optimize speed)) 88 | (with-accessors ((kmaps key-state-kmaps) 89 | (key-seq key-state-sequence)) 90 | bindings-state 91 | (let* ((matching-values (mapcar (lambda (m) 92 | (kmap-lookup (if (%kmap-symbol-p m) 93 | (symbol-value m) 94 | m) 95 | key)) 96 | kmaps)) 97 | (match (find-if-not #'null matching-values))) 98 | (cond 99 | ((kmap-or-kmap-symbol-p match) 100 | (push key key-seq) 101 | (setf (key-state-kmaps bindings-state) (delete-if-not 'kmap-or-kmap-symbol-p matching-values)) 102 | (values t nil)) 103 | (match 104 | (push key key-seq) 105 | (setf (key-state-kmaps bindings-state) nil) 106 | (values t match)) 107 | (t 108 | (values nil)))))) 109 | -------------------------------------------------------------------------------- /lisp/keyboard/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:mahogany/keyboard 2 | (:use :cl 3 | #:alexandria 4 | #:mahogany/log 5 | #:mahogany/util) 6 | (:export #:key 7 | #:make-key 8 | #:print-key 9 | #:key-keysym 10 | #:key-modifier-mask 11 | #:key-modifier-key-p 12 | #:parse-key 13 | #:kbd 14 | #:kbd-parse-error 15 | #:define-kmap 16 | #:define-key 17 | #:kmap-p 18 | #:kmap 19 | #:kmap-lookup 20 | #:key-state 21 | #:make-key-state 22 | #:key-state-sequence 23 | #:key-state-advance 24 | #:key-state-active-p)) 25 | -------------------------------------------------------------------------------- /lisp/log.lisp: -------------------------------------------------------------------------------- 1 | ;; an alternative to this package is vom. However, it doesn't 2 | ;; support color, and is unlikely to, so this will stay. 3 | (defpackage #:mahogany/log 4 | (:use :cl #:cl-ansi-text) 5 | (:export #:log-level 6 | #:log-colored-p 7 | #:log-string 8 | #:log-stream 9 | #:log-init 10 | #:with-log-level 11 | #:with-log-color-enabled 12 | #:with-logging-to-file 13 | #:*log-output-file*) 14 | (:local-nicknames (#:alex #:alexandria))) 15 | 16 | 17 | (in-package #:mahogany/log) 18 | 19 | (deftype debug-specifier () 20 | '(member :trace :debug :info :warn :error :fatal :ignore)) 21 | 22 | (defvar *log-output-file* *standard-output* 23 | "The file to print log messages") 24 | (declaim (type stream *log-output-file*)) 25 | 26 | ;; log-string is used in this file, so get-print-data needs to 27 | ;; be availabe at compile time: 28 | (eval-when (:compile-toplevel :load-toplevel :execute) 29 | (defun get-log-level-data (level) 30 | (declare (type debug-specifier level)) 31 | (ecase level 32 | ;; higher values mean less importance 33 | (:trace (values 6 :white)) 34 | (:debug (values 5 :cyan)) 35 | (:info (values 4 :blue)) 36 | (:warn (values 3 :yellow)) 37 | (:error (values 2 :red)) 38 | (:fatal (values 1 :red)) 39 | (:ignore (values 0))))) 40 | 41 | ;; if you need to add more log levels, you may need to recompile, as 42 | ;; the level is translated to a number at read time. See log-string. 43 | (defvar *log-level* (get-log-level-data :info)) 44 | (declaim (type (integer 0 6) *log-level*)) 45 | 46 | (defun readable-log-level (level) 47 | (ecase level 48 | (6 (values :trace :white)) 49 | (5 (values :debug :cyan)) 50 | (4 (values :info :blue)) 51 | (3 (values :warn :yellow)) 52 | (2 (values :error :red)) 53 | (1 (values :fatal :red)) 54 | (0 (values :ignore)))) 55 | 56 | (defun %log-stream (lvl color stream-fn) 57 | (declare (optimize speed) 58 | (type fixnum lvl) 59 | (type (function (stream) (values &optional)) stream-fn)) 60 | (when (>= *log-level* lvl) 61 | (let ((output *log-output-file*)) 62 | (with-color (color :effect :bright :stream output) 63 | (funcall stream-fn output)) 64 | (finish-output output)))) 65 | 66 | (defun log-stream (log-lvl stream-fn) 67 | "Call the given function with *log-output-file* as its argument if the 68 | log level allows for logging" 69 | (declare (type debug-specifier log-lvl) 70 | (type (function (stream) (values &optional)) stream-fn)) 71 | (unless (eql :ignore log-lvl) 72 | (multiple-value-bind (lvl color) (get-log-level-data log-lvl) 73 | (%log-stream lvl color stream-fn)))) 74 | 75 | (define-compiler-macro log-stream (&whole form log-lvl stream-fn) 76 | (if (constantp log-lvl) 77 | (unless (eql :ignore log-lvl) 78 | (multiple-value-bind (lvl color) (get-log-level-data log-lvl) 79 | `(%log-stream ,lvl ,color ,stream-fn))) 80 | (progn 81 | (alex:simple-style-warning 82 | "Missed optimization in log-stream: the log level is not specificed as a constant") 83 | form))) 84 | 85 | (defmacro log-string (log-lvl string &rest fmt) 86 | "Log the input to *log-output-file* based on the current value of *log-level*. 87 | The string argument as well as the format args will not be evaluated if the current log 88 | level is not high enough." 89 | `(log-stream ,log-lvl (lambda (s) 90 | (declare (type stream s)) 91 | (format s ,string ,@fmt) (format s "~%") 92 | (values)))) 93 | 94 | (defun term-colorable-p () 95 | (and (interactive-stream-p *standard-input*) 96 | (member :max-colors (terminfo:capabilities 97 | (terminfo:set-terminal (uiop:getenv "TERM")))))) 98 | 99 | (defun check-valid-log-level (level) 100 | ;; TODO: make this something with a use-value restart? 101 | (check-type level debug-specifier)) 102 | 103 | (defun log-level () 104 | (values (readable-log-level *log-level*))) 105 | 106 | (defun (setf log-level) (new-level) 107 | "The amount of information printed when logging to the output file. The accepted values are: 108 | :ignore Print nothing to stdout 109 | :trace this should be used for 'tracing' the code, such as when doing deep debugging. 110 | :debug Information that is diagnostically helpful to people who are not project developers 111 | :info Useful, general information that is shown by default 112 | :warn Will signal a warning condition with the supplied text as well as print to 113 | *log-output-file*. Use if something is wrong, but the app can still continue. 114 | :error Something went wrong... 115 | :fatal Bye bye compositor..." 116 | (check-valid-log-level new-level) 117 | (setf *log-level* (get-log-level-data new-level)) 118 | new-level) 119 | 120 | (defun log-colored-p () 121 | cl-ansi-text:*enabled*) 122 | 123 | (defun (setf log-colored) (enablep) 124 | (setf cl-ansi-text:*enabled* enablep)) 125 | 126 | (defun log-init (&key (level *log-level*) (output *standard-output*) (color t)) 127 | "Initialize logging. Call this to setup colorized output, ect. 128 | It is not necessary to call this for logging to work properly, but coloring may be messed up. 129 | If *log-output-file* is changed, it is a good idea to call this function again. 130 | LVL: see *log-level* 131 | OUTPUT: see (setf log-level) 132 | COLOR: Enable/Disable logging colors. If colors are not supported by the output stream, then 133 | this argument will be ignored." 134 | (setf *log-output-file* output) 135 | (check-valid-log-level level) 136 | (setf (log-level) level) 137 | ;; check if we can use pretty colors: 138 | (if (and (term-colorable-p) 139 | color) 140 | (setf cl-ansi-text:*enabled* t) 141 | (setf cl-ansi-text:*enabled* nil)) 142 | (log-string :debug "Mahogany Log settings set to:~%~2TColor:~10T~:[FALSE~;TRUE~]~%~2TOutput:~10T~A~%~2TLevel:~10T~S" 143 | cl-ansi-text:*enabled* *log-output-file* (log-level))) 144 | 145 | (defmacro with-log-level (log-level &body body) 146 | `(progn 147 | (check-valid-log-level ,log-level) 148 | (let ((*log-level* ,(get-log-level-data log-level))) 149 | ,@body))) 150 | 151 | (defmacro with-log-color-enabled (enabledp &body body) 152 | `(let ((cl-ansi-text:*enabled* ,enabledp)) 153 | ,@body)) 154 | 155 | (defmacro with-logging-to-file ((file-path log-level &rest options) &body body) 156 | (let ((file-var (gensym "LOG-FILE"))) 157 | `(with-open-file (,file-var ,file-path ,@options) 158 | (let ((*log-output-file* ,file-var)) 159 | (with-log-level ,log-level 160 | (with-log-color-enabled nil 161 | ,@body)))))) 162 | -------------------------------------------------------------------------------- /lisp/main.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:mahogany) 2 | 3 | (defun load-config-file (&optional (catch-errors nil)) 4 | "Load the user's config file. Returns a values list: whether the file loaded (t if no 5 | rc files exist), the error if it didn't, and the config file that was 6 | loaded. When CATCH-ERRORS is nil, errors are left to be handled 7 | further up. " 8 | (let* ((xdg-config 9 | (probe-file (merge-pathnames #p"mahogany/init.lisp" (uiop:xdg-config-home)))) 10 | (fallback-config 11 | (probe-file (merge-pathnames #p".config/mahogany/init.lisp" (user-homedir-pathname)))) 12 | (config-file (or xdg-config fallback-config))) 13 | (if config-file 14 | (progn 15 | (log-string :info "Found config file at ~a" config-file) 16 | (if catch-errors 17 | (handler-case (load config-file) 18 | (error (c) (values nil (format nil "~a" c) config-file)) 19 | (:no-error (&rest args) (declare (ignore args)) (values t nil config-file))) 20 | (progn 21 | (load config-file) 22 | (values t nil config-file)))) 23 | (progn 24 | (log-string :info "Did not find config file") 25 | (values t nil nil))))) 26 | 27 | (defmacro init-callback-struct (variable type &body sets) 28 | (let ((vars (mapcar #'car sets))) 29 | `(cffi:with-foreign-slots (,vars ,variable ,type) 30 | (setf ,@(loop for pair in sets 31 | append (list (car pair) `(cffi:callback ,(cadr pair)))))))) 32 | 33 | (defun init-view-callbacks (view-callbacks) 34 | (init-callback-struct view-callbacks (:struct hrt:hrt-view-callbacks) 35 | (hrt:new-view handle-new-view-event) 36 | (hrt:view-destroyed handle-view-destroyed-event))) 37 | 38 | (defun run-server (args) 39 | (disable-fpu-exceptions) 40 | (hrt:load-foreign-libraries) 41 | (log-init :level :trace) 42 | (enable-debugger) 43 | (if (cl-argparse:get-value "skip-init" args) 44 | (log-string :info "Init file loading skipped") 45 | (load-config-file)) 46 | (cffi:with-foreign-objects ((output-callbacks '(:struct hrt:hrt-output-callbacks)) 47 | (seat-callbacks '(:struct hrt:hrt-seat-callbacks)) 48 | (view-callbacks '(:struct hrt:hrt-view-callbacks)) 49 | (server '(:struct hrt:hrt-server))) 50 | (init-callback-struct output-callbacks (:struct hrt:hrt-output-callbacks) 51 | (hrt:output-added handle-new-output) 52 | (hrt:output-removed handle-output-removed) 53 | (hrt:output-layout-changed handle-output-layout-change)) 54 | (init-callback-struct seat-callbacks (:struct hrt:hrt-seat-callbacks) 55 | (hrt:button-event handle-mouse-button-event) 56 | (hrt:wheel-event handle-mouse-wheel-event) 57 | (hrt:keyboard-keypress-event keyboard-callback)) 58 | (init-view-callbacks view-callbacks) 59 | 60 | (server-state-init *compositor-state* server 61 | output-callbacks seat-callbacks view-callbacks 62 | :debug-level 3) 63 | (log-string :debug "Initialized mahogany state") 64 | (unwind-protect 65 | (hrt:hrt-server-start server) 66 | (log-string :debug "Cleaning up...") 67 | (server-stop *compositor-state*) 68 | (server-state-reset *compositor-state*) 69 | (log-string :debug "Shutdown reached.")))) 70 | 71 | (defun %parse-cmd-line-args (args) 72 | (let ((parser (cl-argparse:create-main-parser (main-parser "Mahogany is a tiling window manager for Wayland modeled after StumpWM." 73 | "mahogany") 74 | (cl-argparse:add-flag main-parser 75 | :short "q" :long "no-init-file" 76 | :help "Do not load an init file on startup" 77 | :var "skip-init")))) 78 | (cl-argparse:parse parser args))) 79 | 80 | (defun main () 81 | (handler-case 82 | (let ((args (%parse-cmd-line-args (uiop:command-line-arguments)))) 83 | (run-server args)) 84 | (cl-argparse:cancel-parsing-error (e) 85 | (format t "~a~%" e)))) 86 | -------------------------------------------------------------------------------- /lisp/objects.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:mahogany) 2 | 3 | (defstruct (mahogany-output (:constructor %make-mahogany-output (hrt-output full-name))) 4 | (hrt-output cffi:null-pointer :type cffi:foreign-pointer :read-only t) 5 | (full-name "" :type string :read-only t)) 6 | 7 | (defstruct (mahogany-group (:constructor %make-mahogany-group (name number scene-tree))) 8 | (name "" :type string) 9 | (number 1 :type fixnum :read-only t) 10 | (scene-tree (cffi:null-pointer) :type cffi:foreign-pointer :read-only t) 11 | (tree-container (make-instance 'tree:tree-container) :type tree:tree-container :read-only t) 12 | (output-map (make-hash-table :test 'equal) :type hash-table :read-only t) 13 | (current-frame nil :type (or tree:frame null)) 14 | (hidden-views (ring-list:make-ring-list) :type ring-list:ring-list) 15 | (views nil :type list)) 16 | 17 | (defclass mahogany-state () 18 | ((hrt-server :type hrt-server 19 | :initarg server 20 | :accessor mahogany-state-server) 21 | (key-state :type key-state 22 | :initform (make-key-state nil) 23 | :accessor mahogany-state-key-state) 24 | (current-group :type mahogany-group 25 | :accessor mahogany-current-group) 26 | (keybindings :type list 27 | :initform nil 28 | :reader mahogany-state-keybindings) 29 | (outputs :type vector 30 | :initform (make-array 0 31 | :element-type 'mahogany-output 32 | :adjustable t 33 | :fill-pointer t) 34 | :accessor mahogany-state-outputs) 35 | (groups :type vector 36 | :accessor mahogany-state-groups 37 | :initform (make-array 0 :element-type 'mahogany-group :adjustable t :fill-pointer t)) 38 | (hidden-groups :initform (ring-list:make-ring-list) 39 | :type ring-list:ring-list 40 | :reader mahogany-state-hidden-groups) 41 | (views :type hash-table 42 | :initform (make-hash-table) 43 | :reader mahogany-state-views))) 44 | -------------------------------------------------------------------------------- /lisp/output.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:mahogany) 2 | 3 | (defun %get-output-full-name (hrt-output) 4 | (let ((make (hrt:hrt-output-make hrt-output)) 5 | (name (hrt:hrt-output-name hrt-output)) 6 | (serial (hrt:hrt-output-serial hrt-output)) 7 | (model (hrt:hrt-output-model hrt-output))) 8 | (concatenate 'string 9 | (or name "") 10 | (or make "") 11 | (or model "") 12 | (or serial "")))) 13 | 14 | (defun construct-mahogany-output (hrt-output) 15 | (let ((name (%get-output-full-name hrt-output))) 16 | (%make-mahogany-output hrt-output name))) 17 | 18 | (cffi:defcallback handle-new-output :void ((output (:pointer (:struct hrt:hrt-output)))) 19 | (let ((mh-output (construct-mahogany-output output))) 20 | (mahogany-state-output-add *compositor-state* mh-output))) 21 | 22 | (cffi:defcallback handle-output-removed :void ((output (:pointer (:struct hrt:hrt-output)))) 23 | (mahogany-state-output-remove *compositor-state* output)) 24 | 25 | (cffi:defcallback handle-output-layout-change :void () 26 | (mahogany-state-output-reconfigure *compositor-state*)) 27 | -------------------------------------------------------------------------------- /lisp/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:mahogany 2 | (:use :cl 3 | #:alexandria 4 | #:mahogany/log 5 | #:mahogany/wm-interface 6 | #:mahogany/util 7 | #:mahogany/keyboard) 8 | (:local-nicknames (#:tree #:mahogany/tree))) 9 | -------------------------------------------------------------------------------- /lisp/ring-list/ring-list.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:ring-list 2 | (:use :cl) 3 | (:export 4 | #:make-ring-list 5 | #:ring-list 6 | #:ring-list-size 7 | #:add-item 8 | #:remove-item 9 | #:pop-item 10 | #:pop-item-prev 11 | #:swap-next 12 | #:swap-previous 13 | #:swap-next-find 14 | #:swap-previous-find)) 15 | 16 | (in-package #:ring-list) 17 | 18 | (defstruct (ring-item (:constructor make-ring-item (item prev next))) 19 | (next nil :type (or null ring-item)) 20 | (prev nil :type (or null ring-item)) 21 | (item nil)) 22 | 23 | (defstruct (ring-list (:constructor make-ring-list ())) 24 | (size 0 :type fixnum) 25 | (head nil :type (or null ring-item))) 26 | 27 | (defun add-item (ring-list item) 28 | "Add the given item to the head of the list" 29 | (declare (type ring-list ring-list)) 30 | (with-slots (head size) ring-list 31 | (if (null head) 32 | (let ((new-head (make-ring-item item nil nil))) 33 | (setf (ring-item-next new-head) new-head 34 | (ring-item-prev new-head) new-head 35 | head new-head)) 36 | (let* ((prev (ring-item-prev head)) 37 | (new-item (make-ring-item item prev head))) 38 | (setf (ring-item-prev head) new-item 39 | (ring-item-next prev) new-item 40 | head new-item))) 41 | (incf size))) 42 | 43 | (defun %find-item (ring-list item test) 44 | (declare (type ring-list ring-list) 45 | (optimize (speed 3) (safety 0))) 46 | (with-slots (head) ring-list 47 | (when head 48 | (do* ((cur (ring-item-next head) (ring-item-next cur))) 49 | (nil) 50 | (cond 51 | ((funcall test (ring-item-item cur) item) 52 | (return-from %find-item cur)) 53 | ((eql head cur) 54 | (return-from %find-item nil))))))) 55 | 56 | (defun %remove-item (ring-list ring-item) 57 | (declare (type ring-list ring-list) 58 | (type ring-item ring-item) 59 | (optimize (speed 3) (safety 0))) 60 | (with-slots (head) ring-list 61 | (if (= 1 (ring-list-size ring-list)) 62 | (setf head nil) 63 | (let ((prev (ring-item-prev ring-item)) 64 | (next (ring-item-next ring-item))) 65 | (setf (ring-item-next prev) next 66 | (ring-item-prev next) prev) 67 | (when (eql ring-item head) 68 | (setf head next)))) 69 | (decf (ring-list-size ring-list))) 70 | t) 71 | 72 | (defun remove-item (ring-list item &key (test #'equalp)) 73 | "Removes the given item from the list. Returns T if the item was 74 | found and removed" 75 | (declare (type ring-list ring-list)) 76 | (alexandria:when-let ((item (%find-item ring-list item test))) 77 | (%remove-item ring-list item))) 78 | 79 | (defun pop-item (ring-list) 80 | "Remove the item from the top of the list and return it" 81 | (declare (type ring-list ring-list)) 82 | (let ((head (ring-list-head ring-list))) 83 | (when head 84 | (%remove-item ring-list head) 85 | (ring-item-item head)))) 86 | 87 | (defun pop-item-prev (ring-list) 88 | (declare (type ring-list ring-list)) 89 | (let ((head (ring-item-prev (ring-list-head ring-list)))) 90 | (when head 91 | (let ((prev (ring-item-prev head))) 92 | (%remove-item ring-list prev) 93 | (ring-item-item prev))))) 94 | 95 | (defun %swap-find (ring-list item test swap-fn) 96 | (declare (type ring-list ring-list) 97 | (type (function (ring-list t) t) swap-fn) 98 | (type (or (function (t t) t) symbol) test) 99 | (optimize (speed 3) (safety 0))) 100 | (alexandria:when-let ((item (%find-item ring-list item test))) 101 | ;; remove the ring item from where it was: 102 | (let ((item-prev (ring-item-prev item)) 103 | (item-next (ring-item-next item))) 104 | (setf (ring-item-next item-prev) item-next 105 | (ring-item-prev item-next) item-prev)) 106 | ;; and put it at the head of the list, moving the current head back. 107 | (with-slots (head) ring-list 108 | (let ((next (ring-item-next head))) 109 | (setf (ring-item-next head) item 110 | (ring-item-prev next) item 111 | head item))) 112 | (funcall swap-fn ring-list item))) 113 | 114 | (defun swap-next-find (ring-list item &key (test #'equalp)) 115 | "Find the given item in the list and move it to the head of list. 116 | Then swap the found item for the given one like in swap-next" 117 | (declare (type ring-list ring-list)) 118 | (%swap-find ring-list item test #'swap-next)) 119 | 120 | (defun swap-previous-find (ring-list item &key (test #'equalp)) 121 | "Find the given item in the list and move it to the head of list. 122 | Then swap the found item for the given one like in swap-previous" 123 | (declare (type ring-list ring-list)) 124 | (%swap-find ring-list item test #'swap-previous)) 125 | 126 | (defun swap-next (ring-list item) 127 | "Replace the item currently at the head of the list with the given item, 128 | and move the head of the list forward one item" 129 | (declare (type ring-list ring-list) (optimize (speed 3))) 130 | (with-slots (head) ring-list 131 | (when (not head) 132 | (error "The ring list must have an item to swap with")) 133 | (let ((head-item (ring-item-item head))) 134 | (setf (ring-item-item head) item 135 | head (ring-item-next head)) 136 | head-item))) 137 | 138 | (defun swap-previous (ring-list item) 139 | "Move the head of the list backward one item and replace its item for the given one. 140 | Reverses the action that swap-next performs" 141 | (declare (type ring-list ring-list) (optimize (speed 3))) 142 | (with-slots (head) ring-list 143 | (when (not head) 144 | (error "The ring list must have an item to swap with")) 145 | (let* ((prev (ring-item-prev head)) 146 | (prev-item (ring-item-item prev))) 147 | (setf (ring-item-item prev) item 148 | head prev) 149 | prev-item))) 150 | 151 | ;; We need to re-define print-object to prevent infinite recursion 152 | ;; when chasing the next and previous pointers: 153 | (defmethod print-object ((ring-item ring-item) stream) 154 | (format stream "#S(~S :item ~S)" 'ring-item (ring-item-item ring-item))) 155 | 156 | (defmethod print-object ((ring-list ring-list) stream) 157 | (let ((head (ring-list-head ring-list))) 158 | (format stream "(") 159 | (when head 160 | (format stream "*-> ~S" (ring-item-item head)) 161 | (do ((cur (ring-item-next head) (ring-item-next cur))) 162 | (nil) 163 | (when (eql head cur) 164 | (return nil)) 165 | (format stream "-> ~S" (ring-item-item cur)))) 166 | (format stream ")"))) 167 | 168 | (defun print-backwards (ring-list &optional (stream t)) 169 | (let ((head (ring-list-head ring-list))) 170 | (format stream "(") 171 | (when head 172 | (format stream "*-> ~S" (ring-item-item head)) 173 | (do ((cur (ring-item-prev head) (ring-item-prev cur))) 174 | (nil) 175 | (when (eql head cur) 176 | (return nil)) 177 | (format stream "-> ~S" (ring-item-item cur)))) 178 | (format stream ")"))) 179 | -------------------------------------------------------------------------------- /lisp/state.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:mahogany) 2 | 3 | (defvar *default-group-name* "DEFAULT") 4 | 5 | (defun %add-group (state name index) 6 | (declare (type state mahogany-state) 7 | (type name string) 8 | (type index fixnum)) 9 | (with-accessors ((groups mahogany-state-groups) 10 | (current-group mahogany-current-group) 11 | (server mahogany-state-server)) 12 | state 13 | (let* ((scene-tree (hrt:hrt-server-scene-tree server)) 14 | (default-group (make-mahogany-group name index scene-tree))) 15 | (vector-push-extend default-group groups) 16 | default-group))) 17 | 18 | (defun server-state-init (state server output-callbacks seat-callbacks view-callbacks 19 | &key (debug-level 3)) 20 | (setf (mahogany-state-server state) server) 21 | (hrt:hrt-server-init server 22 | output-callbacks seat-callbacks view-callbacks 23 | debug-level) 24 | (let ((default-group (%add-group state *default-group-name* 1))) 25 | (setf (mahogany-current-group state) default-group))) 26 | 27 | (defun server-state-reset (state) 28 | (declare (type mahogany-state state)) 29 | (with-accessors ((groups mahogany-state-groups) 30 | (server mahogany-state-server)) 31 | state 32 | (let ((scene-tree (hrt:hrt-server-scene-tree server))) 33 | (loop for g across groups 34 | :do (destroy-mahogany-group g scene-tree))) 35 | (hrt:hrt-server-finish server) 36 | (setf server nil))) 37 | 38 | (defun server-stop (state) 39 | (declare (type mahogany-state state)) 40 | (hrt:hrt-server-stop (mahogany-state-server state))) 41 | 42 | (defmethod (setf mahogany-current-group) :around (group state) 43 | (with-accessors ((hidden-groups mahogany-state-hidden-groups) 44 | (server mahogany-state-server)) 45 | state 46 | (when (not (find group (mahogany-state-groups state) :test #'equalp)) 47 | (error (format nil "Group ~S is not part of this state" group))) 48 | (when (slot-boundp state 'current-group) 49 | (group-suspend (mahogany-current-group state) (hrt:hrt-server-seat server))) 50 | (call-next-method) 51 | (group-wakeup group (hrt:hrt-server-seat server)))) 52 | 53 | (declaim (inline server-seat)) 54 | (defun server-seat (state) 55 | (hrt:hrt-server-seat (mahogany-state-server state))) 56 | 57 | (defun server-keystate-reset (state) 58 | (setf (mahogany-state-key-state state) 59 | (make-key-state (mahogany-state-keybindings state)))) 60 | 61 | (defun (setf mahogany-state-keybindings) (kmaps state) 62 | (declare (type list kmaps) 63 | (type mahogany-state state)) 64 | (setf (slot-value state 'keybindings) kmaps) 65 | (unless (key-state-active-p (mahogany-state-key-state state)) 66 | (server-keystate-reset state))) 67 | 68 | (defun mahogany-state-output-add (state mh-output) 69 | (declare (type mahogany-state state) 70 | (type mahogany-output mh-output)) 71 | (with-accessors ((outputs mahogany-state-outputs) 72 | (groups mahogany-state-groups)) 73 | state 74 | (log-string :debug "New output added ~S" (mahogany-output-full-name mh-output)) 75 | (vector-push-extend mh-output outputs) 76 | (loop for g across groups 77 | do (group-add-output g mh-output (server-seat state))))) 78 | 79 | (defun mahogany-state-output-remove (state hrt-output) 80 | (with-accessors ((outputs mahogany-state-outputs) 81 | (groups mahogany-state-groups)) 82 | state 83 | (let ((mh-output (find hrt-output outputs 84 | :key #'mahogany-output-hrt-output 85 | :test #'cffi:pointer-eq))) 86 | (log-string :debug "Output removed ~S" (mahogany-output-full-name mh-output)) 87 | (loop for g across groups 88 | do (group-remove-output g mh-output (server-seat state))) 89 | ;; TODO: Is there a better way to remove an item from a vector when we could know the index? 90 | (setf outputs (delete mh-output outputs :test #'equalp))))) 91 | 92 | (defun mahogany-state-group-add (state &key group-name (make-current t)) 93 | (let ((index (length (mahogany-state-groups state)))) 94 | (unless group-name 95 | (setf group-name (concatenate 'string "DEFAULT" "-" (write-to-string index)))) 96 | (let ((new-group (%add-group state group-name index))) 97 | (with-accessors ((current-group mahogany-current-group) 98 | (hidden-groups mahogany-state-hidden-groups) 99 | (state-outputs mahogany-state-outputs)) 100 | state 101 | (loop for o across state-outputs 102 | do (group-add-output new-group o (server-seat state))) 103 | (cond 104 | (make-current 105 | (ring-list:add-item hidden-groups current-group) 106 | (setf current-group new-group)) 107 | (t 108 | (ring-list:add-item hidden-groups current-group))) 109 | (log-string :trace "Hidden groups: ~S" hidden-groups)) 110 | new-group))) 111 | 112 | (defun mahogany-state-group-remove (state group) 113 | (with-accessors ((groups mahogany-state-groups) 114 | (hidden-groups mahogany-state-hidden-groups) 115 | (current-group mahogany-current-group)) 116 | state 117 | (when (= (length groups) 1) 118 | (log-string :warn "Cannot remove the only group") 119 | (return-from mahogany-state-group-remove)) 120 | (if (find group groups :test #'equalp) 121 | (progn 122 | (cond 123 | ((equal group current-group) 124 | (setf current-group (ring-list:pop-item hidden-groups))) 125 | (t 126 | (ring-list:remove-item hidden-groups group))) 127 | (setf groups (delete group groups 128 | :test #'equalp)) 129 | (group-transfer-views current-group group) 130 | (let* ((server (mahogany-state-server state)) 131 | (scene-tree (hrt:hrt-server-scene-tree server))) 132 | (destroy-mahogany-group group scene-tree)) 133 | (log-string :trace "Hidden groups: ~S" hidden-groups)) 134 | (log-string :error "could not find group to delete")))) 135 | 136 | (defun mahogany-state-output-reconfigure (state) 137 | (log-string :trace "Output layout changed!") 138 | (with-accessors ((groups mahogany-state-groups)) state 139 | (loop for g across groups 140 | do (group-reconfigure-outputs g (mahogany-state-outputs state))))) 141 | 142 | (defun mahogany-state-view-add (state view-ptr) 143 | (declare (type mahogany-state state) 144 | (type cffi:foreign-pointer view-ptr)) 145 | (with-accessors ((view-tbl mahogany-state-views) 146 | (current-group mahogany-current-group) 147 | (server mahogany-state-server)) 148 | state 149 | (let ((new-view (group-add-initialize-view current-group view-ptr))) 150 | (setf (gethash (cffi:pointer-address view-ptr) view-tbl) new-view)))) 151 | 152 | (defun mahogany-state-view-remove (state view-ptr) 153 | (declare (type mahogany-state state) 154 | (type cffi:foreign-pointer view-ptr)) 155 | (with-slots (views) state 156 | (alexandria:if-let ((view (gethash (cffi:pointer-address view-ptr) views))) 157 | (progn 158 | (group-remove-view (mahogany-current-group state) view) 159 | (remhash (cffi:pointer-address view-ptr) views)) 160 | (log-string :error "Could not find mahogany view associated with pointer ~S" view-ptr)))) 161 | 162 | (defun state-next-hidden-group (state) 163 | (declare (type mahogany-state state)) 164 | (let ((current-group (mahogany-current-group state)) 165 | (hidden-groups (mahogany-state-hidden-groups state))) 166 | (when (> (ring-list:ring-list-size hidden-groups) 0) 167 | (setf (mahogany-current-group state) (ring-list:swap-next hidden-groups current-group)) 168 | (log-string :trace "Hidden groups: ~S" hidden-groups)))) 169 | 170 | (defun state-prev-hidden-group (state) 171 | (declare (type mahogany-state state)) 172 | (let ((current-group (mahogany-current-group state)) 173 | (hidden-groups (mahogany-state-hidden-groups state))) 174 | (when (> (ring-list:ring-list-size hidden-groups) 0) 175 | (setf (mahogany-current-group state) (ring-list:swap-previous hidden-groups current-group))))) 176 | 177 | (defun mahogany-current-frame (state) 178 | (mahogany-group-current-frame (mahogany-current-group state))) 179 | -------------------------------------------------------------------------------- /lisp/system.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:mahogany/system 2 | (:documentation "Package for functions interacting with the system that 3 | Mahogany is running under") 4 | (:use :cl #:mahogany/util) 5 | (:local-nicknames (#:alex #:alexandria)) 6 | (:nicknames #:sys) 7 | (:export #:find-program 8 | #:open-terminal)) 9 | 10 | (in-package #:mahogany/system) 11 | 12 | (defun find-program (name) 13 | (declare (type string name)) 14 | (handler-case 15 | (string-trim '(#\Newline #\Space) 16 | (with-output-to-string (stream) 17 | (uiop:run-program (list "which" name) :output stream))) 18 | (UIOP/RUN-PROGRAM:SUBPROCESS-ERROR nil))) 19 | 20 | (defun open-terminal () 21 | (if-let* ((term (uiop:getenv "TERMINAL")) 22 | (prog-path (find-program term))) 23 | (uiop:launch-program prog-path) 24 | (let ((programs #("konsole" "gnome-terminal" "wezterm" "foot"))) 25 | (loop for i across programs 26 | do (alex:when-let ((program (find-program i))) 27 | (uiop:launch-program program) 28 | (return t))) 29 | (values nil)))) 30 | -------------------------------------------------------------------------------- /lisp/tree/output-node.lisp: -------------------------------------------------------------------------------- 1 | (in-package :mahogany/tree) 2 | 3 | (defmethod set-position ((frame output-node) new-x new-y) 4 | (set-position (first (tree-children frame)) new-x new-y)) 5 | 6 | (defmethod set-dimensions ((frame output-node) width height) 7 | (set-dimensions (first (tree-children frame)) width height)) 8 | 9 | (defmethod frame-prev ((frame output-node)) 10 | (with-slots (children) frame 11 | (frame-prev (first children)))) 12 | 13 | (defmethod (setf %frame-prev) (prev (frame output-node)) 14 | (with-slots (children) frame 15 | (let ((first-child (first children))) 16 | (setf (%frame-prev first-child) prev)))) 17 | 18 | (defmethod (setf %frame-next) (next (frame output-node)) 19 | (with-slots (children) frame 20 | (let ((last-child (car (last children)))) 21 | (setf (%frame-next last-child) next)))) 22 | 23 | (defmethod frame-next ((frame output-node)) 24 | (with-slots (children) frame 25 | (frame-next (car (last children))))) 26 | -------------------------------------------------------------------------------- /lisp/tree/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:mahogany/tree 2 | (:use :cl 3 | #:alexandria 4 | #:iterate 5 | #:mahogany/log 6 | #:mahogany/util 7 | #:mahogany/wm-interface) 8 | (:export #:*split-frame-hook* 9 | #:*new-frame-hook* 10 | #:*remove-split-hook* 11 | #:*new-split-type* 12 | #:frame 13 | #:frame-at 14 | #:frame-x 15 | #:frame-y 16 | #:frame-width 17 | #:frame-height 18 | #:frame-parent 19 | #:tree-container 20 | #:tree-container-add 21 | #:root-tree 22 | #:tree-frame 23 | #:tree-children 24 | #:tree-split-direction 25 | #:binary-tree-frame 26 | #:poly-tree-frame 27 | #:split-frame-v 28 | #:split-frame-h 29 | #:remove-frame 30 | #:swap-positions 31 | #:find-empty-frame 32 | #:get-populated-frames 33 | #:root-frame-p 34 | #:find-root-frame 35 | #:find-first-leaf 36 | #:mark-frame-focused 37 | #:unmark-frame-focused 38 | #:replace-frame 39 | ;; View-frame functions / objects 40 | #:view-frame 41 | #:frame-view 42 | #:frame-next 43 | #:frame-prev 44 | #:leafs-in)) 45 | -------------------------------------------------------------------------------- /lisp/tree/tree-interface.lisp: -------------------------------------------------------------------------------- 1 | (in-package :mahogany/tree) 2 | 3 | ;; various hooks 4 | (defvar *split-frame-hook* nil 5 | "Hook that is called when a frame is split. It calls a function 6 | with two arguments: the first is the newly created frame, and the second 7 | is the parent of the new frame.") 8 | 9 | (defvar *new-frame-hook* nil 10 | "Hook that is called whenever a new leaf frame is created. The function 11 | called should expect one argument, the newly created frame.") 12 | 13 | (defvar *remove-split-hook* nil 14 | "Hook for when a frame is removed. Called with the deleted frame 15 | as the first argument.") 16 | 17 | (defvar *new-split-type* :binary 18 | "Directs a newly split frame to have two or many children. 19 | Valid choices are :binary or :many. You can change the split type 20 | of an already existing frame with the `set-split-frame-type` function") 21 | 22 | (defclass frame () 23 | ((x :initarg :x 24 | :accessor frame-x 25 | :type real) 26 | (y :initarg :y 27 | :accessor frame-y 28 | :type real) 29 | (width :initarg :width 30 | :accessor frame-width 31 | :type real) 32 | (height :initarg :height 33 | :accessor frame-height 34 | :type real) 35 | (parent :initarg :parent 36 | :type (or output-node frame) 37 | :accessor frame-parent) 38 | (focused :initarg :focused 39 | :reader frame-focused 40 | :initform nil 41 | :type boolean)) 42 | (:documentation "A frame that is displayed on an output")) 43 | 44 | (defgeneric frame-prev (frame) 45 | (:documentation "Get the previous edge node in the tree from this node")) 46 | 47 | (defgeneric frame-next (frame) 48 | (:documentation "Get the next edge node in the tree from this node")) 49 | 50 | ;; Use a different symbol for the setters so we don't export them: 51 | (defgeneric (setf %frame-prev) (prev frame) 52 | (:documentation "Set the previous frame from this frame")) 53 | 54 | (defgeneric (setf %frame-next) (next frame) 55 | (:documentation "Set tne next frame for this frame")) 56 | 57 | (defclass tree-parent () 58 | ((children :initarg :children 59 | :initform nil 60 | :accessor tree-children 61 | :type list 62 | :documentation "Holds the trees of this conatiner"))) 63 | 64 | (defclass tree-container (tree-parent) 65 | () 66 | (:documentation "A class that contains a frame-tree")) 67 | 68 | (defclass output-node (tree-parent) 69 | ((parent :initarg :parent 70 | :initform nil 71 | :type (or null tree-container) 72 | :accessor frame-parent))) 73 | 74 | (deftype split-frame-type () 75 | '(member :vertical :horizontal)) 76 | 77 | (defclass tree-frame (tree-parent frame) 78 | ((split-direction :initarg :split-direction 79 | :reader tree-split-direction 80 | :type split-frame-type)) 81 | (:documentation "An inner node of a frame-tree")) 82 | 83 | (defclass floating-frame (frame) 84 | ((top-frame :initarg :top-frame 85 | :accessor top-frame 86 | :type frame))) 87 | 88 | (defclass binary-tree-frame (tree-frame) 89 | () 90 | (:documentation "An inner node of a frame-tree that can only have two children")) 91 | 92 | (defclass poly-tree-frame (tree-frame) 93 | () 94 | (:documentation "An inner node of a frame-tree that can have more than two children")) 95 | 96 | ;; frame-tree interface 97 | (defgeneric set-split-frame-type (frame type) 98 | (:documentation "Sets the split frame type. Note that this may change the 99 | the layout of the tree depending on the frame type. 100 | See *new-split-type* for more details")) 101 | 102 | (defgeneric split-frame-v (frame &key ratio direction) 103 | (:documentation "Split the frame vertically. Returns a tree of the split frames. 104 | The parent tree is modified appropriately. 105 | RATIO: the size of newly created frame compared to the given frame. If not given, then 106 | the the size is split evenly between the other child frame(s) 107 | DIRECTION: where the new frame is placed. Either :left or :right")) 108 | 109 | (defgeneric split-frame-h (frame &key ratio direction) 110 | (:documentation "Split the frame horizontally. Returns a tree of the split frames. 111 | The parent tree is modified appropriately. 112 | RATIO: the size of newly created frame compared to the given frame. If not given, then 113 | the the size is split evenly between the other child frame(s) 114 | DIRECTION: where the new frame is placed. Either :top or :bottom")) 115 | 116 | (defgeneric remove-frame-from-parent (parent frame cleanup-func) 117 | (:documentation "Remove the frame from the tree. Parent must be the direct parent of frame.")) 118 | 119 | (defun remove-frame (frame &optional (cleanup-func #'identity)) 120 | "Remove the frame from the tree. The remaining children grow to equally take up the available space. 121 | e.g. If there are three frames of width (20, 40, 40), and the 20 width one is removed, the new widths 122 | will be (40, 40). If a tree only has one child left, it is replaced with its child. 123 | CLEANUP-FUNC is called on the removed frame(s) after they are removed." 124 | (remove-frame-from-parent (frame-parent frame) frame cleanup-func)) 125 | 126 | (defgeneric replace-frame (root frame &optional cleanup-func) 127 | (:documentation "Replace ROOT with FRAME. Call CLEANUP-FUNC on every view-frame that is removed 128 | from the tree. ")) 129 | 130 | (defgeneric find-empty-frame (root) 131 | (:documentation "Finds the first veiw-frame in the given tree that doesn't have 132 | a view assigned to it.")) 133 | 134 | (defgeneric frame-at (root x y) 135 | (:documentation "Get the frame that occupies the specified coordinates.")) 136 | 137 | (defgeneric mark-frame-focused (frame seat) 138 | (:documentation "Mark the frame as being focused") 139 | (:method ((frame frame) seat) 140 | (declare (ignore seat)) 141 | (log-string :trace "frame focused") 142 | (setf (slot-value frame 'focused) t))) 143 | 144 | (defgeneric unmark-frame-focused (frame seat) 145 | (:documentation "Mark the frame as being focused") 146 | (:method ((frame frame) seat) 147 | (declare (ignore seat)) 148 | (log-string :trace "frame unfocused") 149 | (setf (slot-value frame 'focused) nil))) 150 | 151 | ;; helper functions: 152 | 153 | (defun root-frame-p (frame) 154 | ;; the root frame's parent will be a tree-container: 155 | (let ((parent (frame-parent frame))) 156 | (typep parent 'output-node))) 157 | 158 | (defun find-root-frame (frame) 159 | "Find the output node for this frame" 160 | (declare (type frame frame)) 161 | (do ((cur-frame frame (frame-parent cur-frame))) 162 | ((root-frame-p cur-frame) cur-frame))) 163 | 164 | (defun tree-container-add (tree-container &key (x 0) (y 0) (width 100) (height 100)) 165 | (declare (type tree-container tree-container)) 166 | (with-accessors ((container-children tree-children)) tree-container 167 | (let* ((new-output (make-instance 'output-node :parent tree-container)) 168 | (new-tree (make-instance 'view-frame :x x :y y :width width :height height 169 | :parent new-output)) 170 | (prev-output (first container-children))) 171 | ;; We'll need to place it somewhere in the middle of the list eventually: 172 | (push new-output container-children) 173 | (push new-tree (tree-children new-output)) 174 | (if prev-output 175 | (let* ((prev-head (first (tree-children prev-output))) 176 | (prev-frame (frame-prev prev-head))) 177 | (setf (%frame-next prev-frame) new-tree 178 | (%frame-prev new-tree) prev-frame 179 | (%frame-prev prev-head) new-tree 180 | (%frame-next new-tree) prev-head)) 181 | (setf (%frame-next new-tree) new-tree 182 | (%frame-prev new-tree) new-tree)) 183 | (values new-output new-tree)))) 184 | 185 | (snakes:defgenerator leafs-in (frame) 186 | (if (or (typep frame 'tree-frame) 187 | (typep frame 'output-node)) 188 | (let ((stack (tree-children frame))) 189 | (iter (for child = (pop stack)) 190 | (while child) 191 | (if (typep child 'tree-frame) 192 | (appendf stack (tree-children child)) 193 | (snakes:yield child)))) 194 | (snakes:yield frame))) 195 | -------------------------------------------------------------------------------- /lisp/tree/view.lisp: -------------------------------------------------------------------------------- 1 | (in-package :mahogany/tree) 2 | 3 | (defclass view-frame (frame) 4 | ((view :initarg :view 5 | :accessor frame-view 6 | :initform nil 7 | :type (or hrt:view null) 8 | :documentation "The client of the frame") 9 | (next :initarg next-frame 10 | :initform nil 11 | :type (or view-frame null) 12 | :reader frame-next) 13 | (prev :initarg prev-frame 14 | :initform nil 15 | :type (or view-frame null) 16 | :reader frame-prev) 17 | (seat :initform nil))) 18 | 19 | (defmethod (setf %frame-prev) (prev (frame view-frame)) 20 | (setf (slot-value frame 'prev) prev)) 21 | 22 | (defmethod (setf %frame-next) (next (frame view-frame)) 23 | (setf (slot-value frame 'next) next)) 24 | 25 | (defmethod (setf frame-view) :after (view (frame view-frame)) 26 | "Place the view in the frame and make it have the same dimensions 27 | and position as the frame" 28 | (when view 29 | (set-position view (round (frame-x frame)) (round (frame-y frame))) 30 | (set-dimensions view (round (frame-width frame)) (round (frame-height frame))) 31 | (when (frame-focused frame) 32 | (hrt:focus-view view (slot-value frame 'seat))))) 33 | 34 | (defmethod mark-frame-focused :after ((frame view-frame) seat) 35 | (setf (slot-value frame 'seat) seat) 36 | (alexandria:when-let ((hrt-view (frame-view frame))) 37 | (log-string :trace "view frame focused") 38 | (hrt:focus-view hrt-view seat))) 39 | 40 | (defmethod unmark-frame-focused :after ((frame view-frame) seat) 41 | (alexandria:when-let ((hrt-view (frame-view frame))) 42 | (log-string :trace "view frame unfocused") 43 | (hrt:unfocus-view hrt-view seat)) 44 | (setf (slot-value frame 'seat) nil)) 45 | 46 | (defmethod print-object ((object view-frame) stream) 47 | (print-unreadable-object (object stream :type t) 48 | (with-slots (width height x y view) 49 | object 50 | (format stream ":w ~A :h ~A :x ~A :y ~A view: ~S" 51 | (round width) (round height) (round x) (round y) view)))) 52 | 53 | (defmethod (setf frame-x) :before (new-x (frame view-frame)) 54 | (when (frame-view frame) 55 | (set-position (frame-view frame) (round new-x) (round (frame-y frame))))) 56 | 57 | (defmethod (setf frame-y) :before (new-y (frame view-frame)) 58 | (when (frame-view frame) 59 | (set-position (frame-view frame) (round (frame-x frame)) (round new-y)))) 60 | 61 | (defmethod set-dimensions :before ((frame view-frame) width height) 62 | (when (frame-view frame) 63 | (set-dimensions (frame-view frame) (round width) (round height)))) 64 | 65 | (defmethod set-position :before ((frame view-frame) x y) 66 | (when (frame-view frame) 67 | (set-position (frame-view frame) (round x) (round y)))) 68 | 69 | (defmethod (setf frame-width) :before (new-width (frame view-frame)) 70 | (when (frame-view frame) 71 | (set-dimensions (frame-view frame) (round new-width) (round (frame-height frame))))) 72 | 73 | (defmethod (setf frame-height) :before (new-height (frame view-frame)) 74 | (when (frame-view frame) 75 | (set-dimensions (frame-view frame) (round (frame-width frame)) (round new-height)))) 76 | -------------------------------------------------------------------------------- /lisp/util.lisp: -------------------------------------------------------------------------------- 1 | ;;; A place to put useful functions that are shared between different files 2 | (defpackage #:mahogany/util 3 | (:use #:cl) 4 | (:export #:mahogany-error 5 | #:defglobal 6 | #:disable-fpu-exceptions 7 | #:enable-debugger 8 | #:if-let*)) 9 | 10 | (in-package #:mahogany/util) 11 | 12 | (define-condition mahogany-error (error) 13 | () 14 | (:documentation "Generic error condition for mahogany")) 15 | 16 | (define-condition initialization-error (mahogany-error) 17 | ((text :initarg text :reader text)) 18 | (:documentation "Used when initializaion goes wrong")) 19 | 20 | (define-condition invalid-operation (mahogany-error) 21 | ((text :initarg text :reader text)) 22 | (:documentation "Used when an invalid operation is attempted")) 23 | 24 | (defmacro defglobal (name value &optional doc) 25 | #+sbcl 26 | `(sb-ext:defglobal ,name ,value ,doc) 27 | #+ccl 28 | `(ccl:defstatic ,name ,value ,doc) 29 | #+(not (or ccl sbcl)) 30 | `(defvar ,name ,value ,doc)) 31 | 32 | (defun enable-debugger () 33 | #+sbcl 34 | (sb-ext:enable-debugger)) 35 | 36 | (defun disable-fpu-exceptions () 37 | #+sbcl 38 | (sb-int:set-floating-point-modes :traps nil) 39 | #+ccl 40 | (ccl:set-fpu-mode :overflow nil)) 41 | 42 | (defmacro if-let* (vars &body (then-form &optional else-form)) 43 | (let* ((end-tag (gensym "exit")) 44 | (var-reverse (reverse vars)) 45 | (let-body `(alexandria:when-let (,(car var-reverse)) 46 | ,then-form 47 | (go ,end-tag)))) 48 | (dolist (v (reverse (rest var-reverse))) 49 | (setf let-body `(alexandria:when-let (,v) 50 | ,let-body))) 51 | `(tagbody 52 | ,let-body 53 | ,else-form 54 | ,end-tag))) 55 | -------------------------------------------------------------------------------- /lisp/view.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:mahogany) 2 | 3 | (cffi:defcallback handle-new-view-event :void 4 | ((view (:pointer (:struct hrt:hrt-view)))) 5 | (log-string :trace "New view callback called!") 6 | (mahogany-state-view-add *compositor-state* view)) 7 | 8 | (cffi:defcallback handle-view-destroyed-event :void 9 | ((view (:pointer (:struct hrt:hrt-view)))) 10 | (log-string :trace "View destroyed callback called!") 11 | (mahogany-state-view-remove *compositor-state* view)) 12 | -------------------------------------------------------------------------------- /mahogany-test.asd: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of mahogany. 3 | 4 | |# 5 | 6 | (asdf:defsystem #:mahogany-test 7 | :depends-on (#:mahogany 8 | #:fiasco) 9 | :pathname "test/" 10 | :components ((:file "ring-list") 11 | (:file "tree-tests") 12 | (:file "keyboard-tests") 13 | (:file "config-system-tests") 14 | (:file "log-tests")) 15 | :description "Test System for mahogany." 16 | :perform (test-op :after (op c) 17 | (uiop/package:symbol-call "FIASCO" "ALL-TESTS"))) 18 | -------------------------------------------------------------------------------- /mahogany.asd: -------------------------------------------------------------------------------- 1 | ;;;; mahogany.asd 2 | 3 | (asdf:defsystem #:mahogany 4 | :description "Mahogany is a tiling window manager for wayland a la stumpwm" 5 | :author "Stuart Dilts" 6 | :license "GPL 2.0" 7 | :version "0.0.1" 8 | :depends-on (#:uiop 9 | #:alexandria 10 | #:cl-ansi-text 11 | #:terminfo 12 | #:cl-argparse 13 | #:xkbcommon 14 | #:cl-wayland 15 | #:snakes 16 | #:iterate 17 | #:cffi) 18 | :in-order-to ((test-op (test-op mahogany-test))) 19 | :pathname #p"lisp/" 20 | :components ((:file "log") 21 | (:file "util") 22 | (:file "system" :depends-on ("util")) 23 | (:module config 24 | :components ((:file "config-system"))) 25 | (:module ring-list 26 | :components ((:file "ring-list"))) 27 | (:module interfaces 28 | :components ((:file "view-interface"))) 29 | (:module bindings 30 | :serial t 31 | :depends-on ("interfaces") 32 | :components ((:file "package") 33 | (:file "wlr-bindings") 34 | (:file "hrt-libs") 35 | (:file "hrt-bindings") 36 | (:file "wrappers"))) 37 | (:module keyboard 38 | :depends-on ("util") 39 | :components ((:file "package") 40 | (:file "keytrans") 41 | (:file "key") 42 | (:file "kmap"))) 43 | (:module tree 44 | :depends-on ("log" "util" "interfaces") 45 | :components ((:file "package") 46 | (:file "tree-interface") 47 | (:file "output-node" :depends-on ("tree-interface")) 48 | (:file "frame" :depends-on ("tree-interface")) 49 | (:file "view" :depends-on ("tree-interface")))) 50 | (:file "package") 51 | (:file "objects" :depends-on ("package" "ring-list")) 52 | (:file "group" :depends-on ("objects" "bindings")) 53 | (:file "state" :depends-on ("objects" "keyboard")) 54 | (:file "globals" :depends-on ("state" "objects" "system")) 55 | (:file "output" :depends-on ("objects" "bindings" "state")) 56 | (:file "view" :depends-on ("globals" "state" "objects" "bindings")) 57 | (:file "input" :depends-on ("state" "keyboard" "bindings")) 58 | (:file "key-bindings" :depends-on ("globals" "state" "keyboard" "tree" "input")) 59 | (:file "main" :depends-on ("bindings" "keyboard" "input" "package")))) 60 | 61 | (asdf:defsystem #:mahogany/executable 62 | :build-operation program-op 63 | :entry-point "mahogany::main" 64 | :build-pathname "build/mahogany" 65 | :depends-on (#:mahogany)) 66 | -------------------------------------------------------------------------------- /run-tests.lisp: -------------------------------------------------------------------------------- 1 | (require 'asdf) 2 | 3 | ;; See https://asdf.common-lisp.dev/asdf.html#Configuration-DSL-1 4 | ;; for what this is doing. 5 | ;; Basically, we want our local copies of dependencies in the dependencies folder 6 | ;; to be used instead of anything that asdf can find in our environment 7 | (asdf:initialize-source-registry 8 | `(:source-registry 9 | (:directory ,(uiop/os:getcwd)) 10 | (:tree ,(merge-pathnames (uiop/os:getcwd) #P"dependencies")) 11 | ;; Use whatever the user has configured in their environment to find the rest. 12 | :inherit-configuration)) 13 | 14 | (asdf:test-system "mahogany") 15 | -------------------------------------------------------------------------------- /test/config-system-tests.lisp: -------------------------------------------------------------------------------- 1 | (fiasco:define-test-package #:config-system-tests 2 | (:use #:config-system #:alexandria)) 3 | 4 | (in-package #:config-system-tests) 5 | 6 | (defmacro defconfig-test (name lambda-list before &body body) 7 | (multiple-value-bind (forms declarations docstring) (parse-body body :documentation t) 8 | `(let* ((config-system::*config-vars* (make-hash-table)) 9 | (table config-system::*config-vars*)) 10 | ,@before 11 | (fiasco:deftest ,name ,lambda-list 12 | ,@(when docstring 13 | (list docstring)) 14 | ,@declarations 15 | (let ((config-system::*config-vars* table)) 16 | ,@forms))))) 17 | 18 | (defvar *foo* "test variable") 19 | (defvar *bar* "test variable") 20 | 21 | (defconfig-test defconfig-sets-default () 22 | ((let ((default 1)) 23 | (defconfig *defconfig-sets-default* default integer "an int"))) 24 | (is *defconfig-sets-default* 1)) 25 | 26 | (defconfig-test defconfig-var-stores-info () 27 | ((let ((default "1")) 28 | (defconfig *foo* default string "documentation"))) 29 | (let ((info (gethash '*foo* config-system::*config-vars*)) 30 | (default "1") 31 | (validator 'string)) 32 | (is info) 33 | (is (config-info-default info) default) 34 | (is (config-info-name info) '*foo*) 35 | (is (config-info-doc info) "documentation") 36 | (is (config-info-type info) validator))) 37 | 38 | (defconfig-test get-config-info-finds-info () 39 | ((let ((default "1")) 40 | (defconfig *foo* default string "documentation"))) 41 | (let ((info (get-config-info '*foo*)) 42 | (default "1") 43 | (validator 'string)) 44 | (is info) 45 | (is (config-info-default info) default) 46 | (is (config-info-name info) '*foo*) 47 | (is (config-info-doc info) "documentation") 48 | (is (config-info-type info) validator))) 49 | 50 | (defconfig-test all-config-info-shows-all () 51 | ((progn 52 | (defconfig *foo* "11" string "documentation") 53 | (defconfig *bar* "21" string "documentation"))) 54 | (let ((configs (all-config-info))) 55 | (is (length configs) 2) 56 | (is (member (get-config-info '*foo*) configs :test #'eql)) 57 | (is (member (get-config-info '*bar*) configs :test #'eql)))) 58 | 59 | (defconfig-test all-config-info-gets-correct-values () 60 | ((progn 61 | (defconfig *foo* "11" string "documentation") 62 | (defconfig *bar* "21" string "documentation"))) 63 | (let ((configs (all-config-info))) 64 | (is (length configs) 2) 65 | (let ((foo (find (get-config-info '*foo*) configs :test #'eql)) 66 | (bar (find (get-config-info '*bar*) configs :test #'eql))) 67 | (is foo) 68 | (is bar) 69 | (is (config-info-value foo) "11") 70 | (is (config-info-value bar) "21")))) 71 | 72 | (defconfig-test set-config-throws-on-not-found () 73 | ((progn 74 | (defconfig *foo* "11" string "documentation"))) 75 | (signals config-not-found-error (set-config *bar* 11))) 76 | 77 | (defconfig-test set-config-throws-on-invalid () 78 | ((progn 79 | (defconfig *foo* "11" string "documentation"))) 80 | (signals invalid-datum-error (set-config *foo* 111))) 81 | 82 | (defconfig-test set-config-checks-arg-length () 83 | () 84 | (signals error (macroexpand '(set-config *foo* 111 *bar*)))) 85 | 86 | (defconfig-test set-config-sets-valid () 87 | ((progn 88 | (defconfig *foo* "11" string "documentation"))) 89 | (set-config *foo* "12") 90 | (is *foo* "12")) 91 | 92 | (defconfig-test reset-config-works () 93 | ((defconfig *foo* "11" string "documentation") 94 | (defconfig *bar* "22" string "documentation")) 95 | (set-config *foo* "asdf" 96 | *bar* "qwerty") 97 | (reset-config *foo* *bar*) 98 | (is *foo* "11") 99 | (is *bar* "22")) 100 | 101 | (defconfig-test with-atomic-update-restores-values () 102 | ((progn 103 | (defconfig *foo* "qwerty" string "documentation") 104 | (defconfig *bar* "asdf" string "documentation"))) 105 | (ignore-errors 106 | (with-atomic-update (*foo* *bar*) 107 | (set-config *foo* "set") 108 | (set-config *bar* 11))) 109 | (is *foo* "qwerty") 110 | (is *bar* "asdf")) 111 | 112 | (defconfig-test set-config-atomic-restores-values () 113 | ((progn 114 | (defconfig *foo* "qwerty" string "documentation") 115 | (defconfig *bar* "asdf" string "documentation"))) 116 | (ignore-errors 117 | (set-config-atomic *foo* "set" 118 | *bar* 11)) 119 | (is *foo* "qwerty") 120 | (is *bar* "asdf")) 121 | -------------------------------------------------------------------------------- /test/keyboard-tests.lisp: -------------------------------------------------------------------------------- 1 | (fiasco:define-test-package #:mahogany-tests/keyboard 2 | (:use #:mahogany/keyboard)) 3 | 4 | (in-package #:mahogany-tests/keyboard) 5 | 6 | (defun expand-key-description (code &rest desc) 7 | (let ((mask 0)) 8 | (declare (type (unsigned-byte 32))) 9 | (dolist (mod desc) 10 | (setf mask (logior mod mask))) 11 | (make-key code mask))) 12 | 13 | (defmacro expect-key (kbd &key to-be) 14 | `(is (equalp (parse-key ,kbd) (expand-key-description ,@to-be)))) 15 | 16 | (fiasco:deftest test-parse-key () 17 | (expect-key "C-l" :to-be (108 mahogany/keyboard::+modifier-ctrl+)) 18 | (expect-key "C-L" :to-be (76 mahogany/keyboard::+modifier-ctrl+)) 19 | (expect-key "C-s-l" :to-be (108 mahogany/keyboard::+modifier-ctrl+ 20 | mahogany/keyboard::+modifier-super+)) 21 | (expect-key "C-S-F1" :to-be (65470 mahogany/keyboard::+modifier-ctrl+ 22 | mahogany/keyboard::+modifier-shift+)) 23 | (expect-key "C--" :to-be (45 mahogany/keyboard::+modifier-ctrl+)) 24 | (expect-key "M-RET" :to-be (65293 mahogany/keyboard::+modifier-alt+)) 25 | (expect-key "-" :to-be (45))) 26 | 27 | (fiasco:deftest parse-key-signals-errors () 28 | (signals kbd-parse-error (parse-key "C-")) 29 | (signals kbd-parse-error (parse-key "B-"))) 30 | 31 | (fiasco:deftest define-kmap-returns-kmap () 32 | (let ((kmap (define-kmap))) 33 | (fiasco:is (kmap-p kmap)))) 34 | 35 | (fiasco:deftest define-key-adds-binding () 36 | (let ((map (define-kmap)) 37 | (key (kbd "C-s")) 38 | (command 'foo)) 39 | (define-key map key command) 40 | 41 | (fiasco:is (equalp command 42 | (kmap-lookup map key))))) 43 | 44 | (fiasco:deftest define-key-overwrites-binding () 45 | (let ((map (define-kmap)) 46 | (key (kbd "M-8"))) 47 | (define-key map key 'foo) 48 | (define-key map key 'bar) 49 | (fiasco:is (equalp 'bar (kmap-lookup map key))))) 50 | 51 | (fiasco:deftest advance-key-state-returns-correct-finish-found-state () 52 | (let* ((key (kbd "C-s")) 53 | (command 'foo) 54 | (state (make-key-state (list (define-kmap key command))))) 55 | (multiple-value-bind (matched result) (key-state-advance key state) 56 | (is (eql matched t)) 57 | (is (eql result command))))) 58 | 59 | (fiasco:deftest advance-key-state-returns-correct-finish-not-found-state () 60 | (let* ((key (kbd "C-s")) 61 | (state (make-key-state (list (define-kmap)))) 62 | (matched (key-state-advance key state))) 63 | (is (eql matched nil)))) 64 | 65 | (fiasco:deftest advance-key-state-returns-correct-continue-state () 66 | (let* ((key (kbd "C-s")) 67 | (other-kmap (define-kmap)) 68 | (state (make-key-state (list (define-kmap key other-kmap))))) 69 | (multiple-value-bind (matched result) (key-state-advance key state) 70 | (is (eql matched t)) 71 | (is (eql result nil)) 72 | (is (equalp (mahogany/keyboard::key-state-kmaps state) (list other-kmap)))))) 73 | 74 | (defparameter *test-kmap* (define-kmap)) 75 | 76 | (fiasco:deftest advance-key-state-dereferences-dynamic-vars () 77 | (let* ((key (kbd "C-s")) 78 | (state (make-key-state (list (define-kmap key '*test-kmap*))))) 79 | (multiple-value-bind (matched result) (key-state-advance key state) 80 | (is (eql matched t)) 81 | (is (eql result nil)) 82 | (is (equalp (mahogany/keyboard::key-state-kmaps state) (list '*test-kmap*)))))) 83 | 84 | (fiasco:deftest advance-key-state-advances-all-when-not-found () 85 | (let* ((key (kbd "M-e")) 86 | (kmap-next (define-kmap (kbd "C-a") 'foo)) 87 | (kmap1 (define-kmap key kmap-next)) 88 | (kmap2 (define-kmap key *test-kmap*)) 89 | (state (make-key-state (list kmap1 kmap2)))) 90 | (multiple-value-bind (matched result) (key-state-advance key state) 91 | (is (eql result nil)) 92 | (is (equalp (mahogany/keyboard::key-state-kmaps state) (list kmap-next *test-kmap*)))))) 93 | 94 | (fiasco:deftest advance-key-state-progression-works () 95 | (let* ((key (kbd "M-e")) 96 | (kmap-next (define-kmap (kbd "C-a") 'foo)) 97 | (kmap1 (define-kmap key kmap-next)) 98 | (kmap2 (define-kmap key *test-kmap*)) 99 | (state (make-key-state (list kmap1 kmap2)))) 100 | (multiple-value-bind (matched result) (progn 101 | (key-state-advance key state) 102 | (key-state-advance (kbd "C-a") state)) 103 | (is (eql matched t)) 104 | (is (eql result 'foo))))) 105 | -------------------------------------------------------------------------------- /test/log-tests.lisp: -------------------------------------------------------------------------------- 1 | (fiasco:define-test-package #:mahogany-tests/log 2 | (:use #:mahogany/log)) 3 | 4 | (in-package #:mahogany-tests/log) 5 | 6 | (fiasco:deftest log-string-format-args-have-no-side-effects () 7 | (setf (log-level) :ignore) 8 | (let ((thing 0)) 9 | (flet ((fn () (setf thing (+ 1 thing)))) 10 | (log-string :debug "Counter is: ~A" (fn)) 11 | (fiasco:is (eql thing 0))))) 12 | 13 | (defun non-constant-log (lvl stream) 14 | (let ((*log-output-file* stream)) 15 | (log-string lvl "Test"))) 16 | 17 | (fiasco:deftest log-string-non-constant-lvl-has-no-side-effects () 18 | (setf (log-level) :ignore) 19 | (let ((thing 0)) 20 | (declare (notinline non-constant-log)) 21 | (flet ((fn () (setf thing (+ 1 thing)))) 22 | (with-output-to-string (stream) 23 | (non-constant-log :debug stream) 24 | (fiasco:is (eql thing 0)))))) 25 | 26 | (fiasco:deftest log-string-ignore-is-ignored () 27 | (setf (log-level) :trace) 28 | (let ((output-result (with-output-to-string (output) 29 | (let ((*log-output-file* output)) 30 | (log-string :ignore "Test"))))) 31 | (is (string-equal output-result "")))) 32 | 33 | (fiasco:deftest log-levels-translate () 34 | (dolist (level (list :trace :debug :info :warn :error :fatal :ignore)) 35 | (setf (log-level) level) 36 | (is (eql (log-level) level)))) 37 | -------------------------------------------------------------------------------- /test/mahogany-test.lisp: -------------------------------------------------------------------------------- 1 | (defpackage mahogany-test 2 | (:use :cl 3 | :prove)) 4 | 5 | (in-package :mahogany-test) 6 | 7 | (deftest test-test 8 | (plan 3) 9 | (ok (not (find 4 '(1 2 3)))) 10 | (is 4 4) 11 | (isnt 1 #\1)) 12 | 13 | (prove:run-test 'test-test) 14 | 15 | (finalize) 16 | -------------------------------------------------------------------------------- /test/ring-list.lisp: -------------------------------------------------------------------------------- 1 | (fiasco:define-test-package #:mahogany-tests/ring-list 2 | (:use #:ring-list)) 3 | 4 | (in-package #:mahogany-tests/ring-list) 5 | 6 | (fiasco:deftest remove-item-when-empty-returns-nil () 7 | (let ((ring (make-ring-list))) 8 | (is (null (remove-item ring nil))))) 9 | 10 | (fiasco:deftest remove-item-when-empty-keeps-size () 11 | (let ((ring (make-ring-list))) 12 | (remove-item ring nil) 13 | (= 0 (ring-list-size ring)))) 14 | 15 | (fiasco:deftest swap-next-signals-when-empty () 16 | (let ((ring (make-ring-list))) 17 | (fiasco:signals error 18 | (swap-next ring nil)))) 19 | 20 | (fiasco:deftest swap-previous-signals-when-empty () 21 | (let ((ring (make-ring-list))) 22 | (fiasco:signals error 23 | (swap-previous ring nil)))) 24 | 25 | (fiasco:deftest add-item-increments-size () 26 | (let ((ring (make-ring-list))) 27 | (add-item ring 'foo) 28 | (add-item ring 'bar) 29 | (is (= 2 (ring-list-size ring))))) 30 | 31 | (fiasco:deftest remove-item-decrements-counter () 32 | (let ((ring (make-ring-list))) 33 | (add-item ring 'foo) 34 | (remove-item ring 'foo) 35 | (is (= 0 (ring-list-size ring))))) 36 | --------------------------------------------------------------------------------