diff options
Diffstat (limited to 'third_party/exwm/exwm-floating.el')
| -rw-r--r-- | third_party/exwm/exwm-floating.el | 780 |
1 files changed, 780 insertions, 0 deletions
diff --git a/third_party/exwm/exwm-floating.el b/third_party/exwm/exwm-floating.el new file mode 100644 index 000000000000..574a78f01562 --- /dev/null +++ b/third_party/exwm/exwm-floating.el @@ -0,0 +1,780 @@ +;;; exwm-floating.el --- Floating Module for EXWM -*- lexical-binding: t -*- + +;; Copyright (C) 2015-2024 Free Software Foundation, Inc. + +;; Author: Chris Feng <chris.w.feng@gmail.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This module deals with the conversion between floating and non-floating +;; states and implements moving/resizing operations on floating windows. + +;;; Code: + +(require 'xcb-cursor) +(require 'exwm-core) + +(defgroup exwm-floating nil + "Floating." + :group 'exwm) + +(defcustom exwm-floating-setup-hook nil + "Normal hook run when an X window has been made floating. +This hook runs in the context of the corresponding buffer." + :type 'hook) + +(defcustom exwm-floating-exit-hook nil + "Normal hook run when an X window has exited floating state. +This hook runs in the context of the corresponding buffer." + :type 'hook) + +(defcustom exwm-floating-border-color "navy" + "Border color of floating windows." + :type 'color + :initialize #'custom-initialize-default + :set (lambda (symbol value) + (set-default symbol value) + ;; Change border color for all floating X windows. + (when exwm--connection + (let ((border-pixel (exwm--color->pixel value))) + (when border-pixel + (dolist (pair exwm--id-buffer-alist) + (with-current-buffer (cdr pair) + (when exwm--floating-frame + (xcb:+request exwm--connection + (make-instance 'xcb:ChangeWindowAttributes + :window + (frame-parameter exwm--floating-frame + 'exwm-container) + :value-mask xcb:CW:BorderPixel + :border-pixel border-pixel))))) + (xcb:flush exwm--connection)))))) + +(defcustom exwm-floating-border-width 1 + "Border width of floating windows." + :type `(integer + :validate ,(lambda (widget) + (when (< (widget-value widget) 0) + (widget-put widget :error "Border width is at least 0") + widget))) + :initialize #'custom-initialize-default + :set (lambda (symbol value) + (let ((delta (- value exwm-floating-border-width)) + container) + (set-default symbol value) + ;; Change border width for all floating X windows. + (dolist (pair exwm--id-buffer-alist) + (with-current-buffer (cdr pair) + (when exwm--floating-frame + (setq container (frame-parameter exwm--floating-frame + 'exwm-container)) + (with-slots (x y) + (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:GetGeometry + :drawable container)) + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window container + :value-mask + (logior xcb:ConfigWindow:X + xcb:ConfigWindow:Y + xcb:ConfigWindow:BorderWidth) + :border-width value + :x (- x delta) + :y (- y delta))))))) + (when exwm--connection + (xcb:flush exwm--connection))))) + +;; Cursors for moving/resizing a window +(defvar exwm-floating--cursor-move nil) +(defvar exwm-floating--cursor-top-left nil) +(defvar exwm-floating--cursor-top nil) +(defvar exwm-floating--cursor-top-right nil) +(defvar exwm-floating--cursor-right nil) +(defvar exwm-floating--cursor-bottom-right nil) +(defvar exwm-floating--cursor-bottom nil) +(defvar exwm-floating--cursor-bottom-left nil) +(defvar exwm-floating--cursor-left nil) + +(defvar exwm-floating--moveresize-calculate nil + "Calculate move/resize parameters [buffer event-mask x y width height].") + +(defvar exwm-workspace--current) +(defvar exwm-workspace--frame-y-offset) +(defvar exwm-workspace--window-y-offset) +(declare-function exwm-layout--hide "exwm-layout.el" (id)) +(declare-function exwm-layout--iconic-state-p "exwm-layout.el" (&optional id)) +(declare-function exwm-layout--refresh "exwm-layout.el" ()) +(declare-function exwm-layout--show "exwm-layout.el" (id &optional window)) +(declare-function exwm-workspace--position "exwm-workspace.el" (frame)) +(declare-function exwm-workspace--update-offsets "exwm-workspace.el" ()) +(declare-function exwm-workspace--workarea "exwm-workspace.el" (frame)) + +(defun exwm-floating--set-allowed-actions (id tilling) + "Set _NET_WM_ALLOWED_ACTIONS." + (exwm--log "#x%x" id) + (xcb:+request exwm--connection + (make-instance 'xcb:ewmh:set-_NET_WM_ALLOWED_ACTIONS + :window id + :data (if tilling + (vector xcb:Atom:_NET_WM_ACTION_MINIMIZE + xcb:Atom:_NET_WM_ACTION_FULLSCREEN + xcb:Atom:_NET_WM_ACTION_CHANGE_DESKTOP + xcb:Atom:_NET_WM_ACTION_CLOSE) + (vector xcb:Atom:_NET_WM_ACTION_MOVE + xcb:Atom:_NET_WM_ACTION_RESIZE + xcb:Atom:_NET_WM_ACTION_MINIMIZE + xcb:Atom:_NET_WM_ACTION_FULLSCREEN + xcb:Atom:_NET_WM_ACTION_CHANGE_DESKTOP + xcb:Atom:_NET_WM_ACTION_CLOSE))))) + +(defun exwm-floating--set-floating (id) + "Make window ID floating." + (let ((window (get-buffer-window (exwm--id->buffer id)))) + (when window + ;; Hide the non-floating X window first. + (set-window-buffer window (other-buffer nil t)))) + (let* ((original-frame (buffer-local-value 'exwm--frame + (exwm--id->buffer id))) + ;; Create new frame + (frame (with-current-buffer + (or (get-buffer "*scratch*") + (progn + (set-buffer-major-mode + (get-buffer-create "*scratch*")) + (get-buffer "*scratch*"))) + (make-frame + `((minibuffer . ,(minibuffer-window exwm--frame)) + (tab-bar-lines . 0) + (tab-bar-lines-keep-state . t) + (left . ,(* window-min-width -10000)) + (top . ,(* window-min-height -10000)) + (width . ,window-min-width) + (height . ,window-min-height) + (unsplittable . t))))) ;and fix the size later + (outer-id (string-to-number (frame-parameter frame 'outer-window-id))) + (window-id (string-to-number (frame-parameter frame 'window-id))) + (frame-container (xcb:generate-id exwm--connection)) + (window (frame-first-window frame)) ;and it's the only window + (x (slot-value exwm--geometry 'x)) + (y (slot-value exwm--geometry 'y)) + (width (slot-value exwm--geometry 'width)) + (height (slot-value exwm--geometry 'height))) + ;; Force drawing menu-bar & tool-bar. + (redisplay t) + (exwm-workspace--update-offsets) + (exwm--log "Floating geometry (original): %dx%d%+d%+d" width height x y) + ;; Save frame parameters. + (set-frame-parameter frame 'exwm-outer-id outer-id) + (set-frame-parameter frame 'exwm-id window-id) + (set-frame-parameter frame 'exwm-container frame-container) + ;; Fix illegal parameters + ;; FIXME: check normal hints restrictions + (with-slots ((x* x) (y* y) (width* width) (height* height)) + (exwm-workspace--workarea original-frame) + ;; Center floating windows + (when (and (or (= x 0) (= x x*)) + (or (= y 0) (= y y*))) + (let ((buffer (exwm--id->buffer exwm-transient-for)) + window edges) + (when (and buffer (setq window (get-buffer-window buffer))) + (setq edges (window-inside-absolute-pixel-edges window)) + (unless (and (<= width (- (elt edges 2) (elt edges 0))) + (<= height (- (elt edges 3) (elt edges 1)))) + (setq edges nil))) + (if edges + ;; Put at the center of leading window + (setq x (+ x* (/ (- (elt edges 2) (elt edges 0) width) 2)) + y (+ y* (/ (- (elt edges 3) (elt edges 1) height) 2))) + ;; Put at the center of screen + (setq x (/ (- width* width) 2) + y (/ (- height* height) 2))))) + (if (> width width*) + ;; Too wide + (progn (setq x x* + width width*)) + ;; Invalid width + (when (= 0 width) (setq width (/ width* 2))) + ;; Make sure at least half of the window is visible + (unless (< x* (+ x (/ width 2)) (+ x* width*)) + (setq x (+ x* (/ (- width* width) 2))))) + (if (> height height*) + ;; Too tall + (setq y y* + height height*) + ;; Invalid height + (when (= 0 height) (setq height (/ height* 2))) + ;; Make sure at least half of the window is visible + (unless (< y* (+ y (/ height 2)) (+ y* height*)) + (setq y (+ y* (/ (- height* height) 2))))) + ;; The geometry can be overridden by user options. + (let ((x** (plist-get exwm--configurations 'x)) + (y** (plist-get exwm--configurations 'y)) + (width** (plist-get exwm--configurations 'width)) + (height** (plist-get exwm--configurations 'height))) + (if (integerp x**) + (setq x (+ x* x**)) + (when (and (floatp x**) + (>= 1 x** 0)) + (setq x (+ x* (round (* x** width*)))))) + (if (integerp y**) + (setq y (+ y* y**)) + (when (and (floatp y**) + (>= 1 y** 0)) + (setq y (+ y* (round (* y** height*)))))) + (if (integerp width**) + (setq width width**) + (when (and (floatp width**) + (> 1 width** 0)) + (setq width (max 1 (round (* width** width*)))))) + (if (integerp height**) + (setq height height**) + (when (and (floatp height**) + (> 1 height** 0)) + (setq height (max 1 (round (* height** height*)))))))) + (exwm--set-geometry id x y nil nil) + (xcb:flush exwm--connection) + (exwm--log "Floating geometry (corrected): %dx%d%+d%+d" width height x y) + ;; Fit frame to client + ;; It seems we have to make the frame invisible in order to resize it + ;; timely. + ;; The frame will be made visible by `select-frame-set-input-focus'. + (make-frame-invisible frame) + (let* ((edges (window-inside-pixel-edges window)) + (frame-width (+ width (- (frame-pixel-width frame) + (- (elt edges 2) (elt edges 0))))) + (frame-height (+ height (- (frame-pixel-height frame) + (- (elt edges 3) (elt edges 1))) + ;; Use `frame-outer-height' in the future. + exwm-workspace--frame-y-offset)) + (floating-mode-line (plist-get exwm--configurations + 'floating-mode-line)) + (floating-header-line (plist-get exwm--configurations + 'floating-header-line)) + (border-pixel (exwm--color->pixel exwm-floating-border-color))) + (if floating-mode-line + (setq exwm--mode-line-format (or exwm--mode-line-format + mode-line-format) + mode-line-format floating-mode-line) + (if (and (not (plist-member exwm--configurations 'floating-mode-line)) + exwm--mwm-hints-decorations) + (when exwm--mode-line-format + (setq mode-line-format exwm--mode-line-format)) + ;; The mode-line need to be hidden in floating mode. + (setq frame-height (- frame-height (window-mode-line-height + (frame-root-window frame))) + exwm--mode-line-format (or exwm--mode-line-format + mode-line-format) + mode-line-format nil))) + (if floating-header-line + (setq header-line-format floating-header-line) + (if (and (not (plist-member exwm--configurations + 'floating-header-line)) + exwm--mwm-hints-decorations) + (setq header-line-format nil) + ;; The header-line need to be hidden in floating mode. + (setq frame-height (- frame-height (window-header-line-height + (frame-root-window frame))) + header-line-format nil))) + (set-frame-size frame frame-width frame-height t) + ;; Create the frame container as the parent of the frame. + (xcb:+request exwm--connection + (make-instance 'xcb:CreateWindow + :depth 0 + :wid frame-container + :parent exwm--root + :x x + :y (- y exwm-workspace--window-y-offset) + :width width + :height height + :border-width + (with-current-buffer (exwm--id->buffer id) + (let ((border-witdh (plist-get exwm--configurations + 'border-width))) + (if (and (integerp border-witdh) + (>= border-witdh 0)) + border-witdh + exwm-floating-border-width))) + :class xcb:WindowClass:InputOutput + :visual 0 + :value-mask (logior xcb:CW:BackPixmap + (if border-pixel + xcb:CW:BorderPixel 0) + xcb:CW:OverrideRedirect) + :background-pixmap xcb:BackPixmap:ParentRelative + :border-pixel border-pixel + :override-redirect 1)) + (xcb:+request exwm--connection + (make-instance 'xcb:ewmh:set-_NET_WM_NAME + :window frame-container + :data + (format "EXWM floating frame container for 0x%x" id))) + ;; Map it. + (xcb:+request exwm--connection + (make-instance 'xcb:MapWindow :window frame-container)) + ;; Put the X window right above this frame container. + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window id + :value-mask (logior xcb:ConfigWindow:Sibling + xcb:ConfigWindow:StackMode) + :sibling frame-container + :stack-mode xcb:StackMode:Above))) + ;; Reparent this frame to its container. + (xcb:+request exwm--connection + (make-instance 'xcb:ReparentWindow + :window outer-id :parent frame-container :x 0 :y 0)) + (exwm-floating--set-allowed-actions id nil) + (xcb:flush exwm--connection) + ;; Set window/buffer + (with-current-buffer (exwm--id->buffer id) + (setq window-size-fixed exwm--fixed-size + exwm--floating-frame frame) + ;; Do the refresh manually. + (remove-hook 'window-configuration-change-hook #'exwm-layout--refresh) + (set-window-buffer window (current-buffer)) ;this changes current buffer + (add-hook 'window-configuration-change-hook #'exwm-layout--refresh) + (set-window-dedicated-p window t) + (exwm-layout--show id window)) + (with-current-buffer (exwm--id->buffer id) + (if (exwm-layout--iconic-state-p id) + ;; Hide iconic floating X windows. + (exwm-floating-hide) + (with-selected-frame exwm--frame + (exwm-layout--refresh))) + (select-frame-set-input-focus frame)) + ;; FIXME: Strangely, the Emacs frame can move itself at this point + ;; when there are left/top struts set. Force resetting its + ;; position seems working, but it'd better to figure out why. + ;; FIXME: This also happens in another case (#220) where the cause is + ;; still unclear. + (exwm--set-geometry outer-id 0 0 nil nil) + (xcb:flush exwm--connection)) + (with-current-buffer (exwm--id->buffer id) + (run-hooks 'exwm-floating-setup-hook)) + ;; Redraw the frame. + (redisplay t)) + +(defun exwm-floating--unset-floating (id) + "Make window ID non-floating." + (exwm--log "#x%x" id) + (let ((buffer (exwm--id->buffer id))) + (with-current-buffer buffer + (when exwm--floating-frame + ;; The X window is already mapped. + ;; Unmap the X window. + (xcb:+request exwm--connection + (make-instance 'xcb:ChangeWindowAttributes + :window id :value-mask xcb:CW:EventMask + :event-mask xcb:EventMask:NoEvent)) + (xcb:+request exwm--connection + (make-instance 'xcb:UnmapWindow :window id)) + (xcb:+request exwm--connection + (make-instance 'xcb:ChangeWindowAttributes + :window id :value-mask xcb:CW:EventMask + :event-mask (exwm--get-client-event-mask))) + ;; Reparent the floating frame back to the root window. + (let ((frame-id (frame-parameter exwm--floating-frame 'exwm-outer-id)) + (frame-container (frame-parameter exwm--floating-frame + 'exwm-container))) + (xcb:+request exwm--connection + (make-instance 'xcb:UnmapWindow :window frame-id)) + (xcb:+request exwm--connection + (make-instance 'xcb:ReparentWindow + :window frame-id + :parent exwm--root + :x 0 :y 0)) + ;; Also destroy its container. + (xcb:+request exwm--connection + (make-instance 'xcb:DestroyWindow :window frame-container)))) + ;; Place the X window just above the reference X window. + ;; (the stacking order won't change from now on). + ;; Also hide the possible floating border. + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window id + :value-mask (logior xcb:ConfigWindow:BorderWidth + xcb:ConfigWindow:Sibling + xcb:ConfigWindow:StackMode) + :border-width 0 + :sibling exwm--guide-window + :stack-mode xcb:StackMode:Above))) + (exwm-floating--set-allowed-actions id t) + (xcb:flush exwm--connection) + (with-current-buffer buffer + (when exwm--floating-frame ;from floating to non-floating + (set-window-dedicated-p (frame-first-window exwm--floating-frame) nil) + ;; Select a tiling window and delete the old frame. + (select-window (frame-selected-window exwm-workspace--current)) + (with-current-buffer buffer + (delete-frame exwm--floating-frame)))) + (with-current-buffer buffer + (setq window-size-fixed nil + exwm--floating-frame nil) + (if (not (plist-member exwm--configurations 'tiling-mode-line)) + (when exwm--mode-line-format + (setq mode-line-format exwm--mode-line-format)) + (setq exwm--mode-line-format (or exwm--mode-line-format + mode-line-format) + mode-line-format (plist-get exwm--configurations + 'tiling-mode-line))) + (if (not (plist-member exwm--configurations 'tiling-header-line)) + (setq header-line-format nil) + (setq header-line-format (plist-get exwm--configurations + 'tiling-header-line)))) + ;; Only show X windows in normal state. + (unless (exwm-layout--iconic-state-p) + (pop-to-buffer-same-window buffer))) + (with-current-buffer (exwm--id->buffer id) + (run-hooks 'exwm-floating-exit-hook))) + +;;;###autoload +(cl-defun exwm-floating-toggle-floating () + "Toggle the current window between floating and non-floating states." + (interactive) + (exwm--log) + (unless (derived-mode-p 'exwm-mode) + (cl-return-from exwm-floating-toggle-floating)) + (with-current-buffer (window-buffer) + (if exwm--floating-frame + (exwm-floating--unset-floating exwm--id) + (exwm-floating--set-floating exwm--id)))) + +;;;###autoload +(defun exwm-floating-hide () + "Hide the current floating X window (which would show again when selected)." + (interactive) + (exwm--log) + (when (and (derived-mode-p 'exwm-mode) + exwm--floating-frame) + (exwm-layout--hide exwm--id) + (select-frame-set-input-focus exwm-workspace--current))) + +(defun exwm-floating--start-moveresize (id &optional type) + "Start move/resize." + (exwm--log "#x%x" id) + (let ((buffer-or-id (or (exwm--id->buffer id) id)) + frame container-or-id x y width height cursor) + (if (bufferp buffer-or-id) + ;; Managed. + (with-current-buffer buffer-or-id + (setq frame exwm--floating-frame + container-or-id (frame-parameter exwm--floating-frame + 'exwm-container))) + ;; Unmanaged. + (setq container-or-id id)) + (when (and container-or-id + ;; Test if the pointer can be grabbed + (= xcb:GrabStatus:Success + (slot-value + (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:GrabPointer + :owner-events 0 + :grab-window container-or-id + :event-mask xcb:EventMask:NoEvent + :pointer-mode xcb:GrabMode:Async + :keyboard-mode xcb:GrabMode:Async + :confine-to xcb:Window:None + :cursor xcb:Cursor:None + :time xcb:Time:CurrentTime)) + 'status))) + (with-slots (root-x root-y win-x win-y) + (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:QueryPointer :window id)) + (if (not (bufferp buffer-or-id)) + ;; Unmanaged. + (unless (eq type xcb:ewmh:_NET_WM_MOVERESIZE_MOVE) + (with-slots ((width* width) + (height* height)) + (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:GetGeometry :drawable id)) + (setq width width* + height height*))) + ;; Managed. + (select-window (frame-first-window frame)) ;transfer input focus + (setq width (frame-pixel-width frame) + height (frame-pixel-height frame)) + (unless type + ;; Determine the resize type according to the pointer position + ;; Clicking the center 1/3 part to resize has no effect + (setq x (/ (* 3 win-x) (float width)) + y (/ (* 3 win-y) (float height)) + type (cond ((and (< x 1) (< y 1)) + xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_TOPLEFT) + ((and (> x 2) (< y 1)) + xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_TOPRIGHT) + ((and (> x 2) (> y 2)) + xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_BOTTOMRIGHT) + ((and (< x 1) (> y 2)) + xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_BOTTOMLEFT) + ((> x 2) xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_RIGHT) + ((> y 2) xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_BOTTOM) + ((< x 1) xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_LEFT) + ((< y 1) xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_TOP))))) + (if (not type) + (exwm-floating--stop-moveresize) + (cond ((= type xcb:ewmh:_NET_WM_MOVERESIZE_MOVE) + (setq cursor exwm-floating--cursor-move + exwm-floating--moveresize-calculate + (lambda (x y) + (vector buffer-or-id + (eval-when-compile + (logior xcb:ConfigWindow:X + xcb:ConfigWindow:Y)) + (- x win-x) (- y win-y) 0 0)))) + ((= type xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_TOPLEFT) + (setq cursor exwm-floating--cursor-top-left + exwm-floating--moveresize-calculate + (lambda (x y) + (vector buffer-or-id + (eval-when-compile + (logior xcb:ConfigWindow:X + xcb:ConfigWindow:Y + xcb:ConfigWindow:Width + xcb:ConfigWindow:Height)) + (- x win-x) (- y win-y) + (- (+ root-x width) x) + (- (+ root-y height) y))))) + ((= type xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_TOP) + (setq cursor exwm-floating--cursor-top + exwm-floating--moveresize-calculate + (lambda (_x y) + (vector buffer-or-id + (eval-when-compile + (logior xcb:ConfigWindow:Y + xcb:ConfigWindow:Height)) + 0 (- y win-y) 0 (- (+ root-y height) y))))) + ((= type xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_TOPRIGHT) + (setq cursor exwm-floating--cursor-top-right + exwm-floating--moveresize-calculate + (lambda (x y) + (vector buffer-or-id + (eval-when-compile + (logior xcb:ConfigWindow:Y + xcb:ConfigWindow:Width + xcb:ConfigWindow:Height)) + 0 (- y win-y) (- x (- root-x width)) + (- (+ root-y height) y))))) + ((= type xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_RIGHT) + (setq cursor exwm-floating--cursor-right + exwm-floating--moveresize-calculate + (lambda (x _y) + (vector buffer-or-id + xcb:ConfigWindow:Width + 0 0 (- x (- root-x width)) 0)))) + ((= type xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_BOTTOMRIGHT) + (setq cursor exwm-floating--cursor-bottom-right + exwm-floating--moveresize-calculate + (lambda (x y) + (vector buffer-or-id + (eval-when-compile + (logior xcb:ConfigWindow:Width + xcb:ConfigWindow:Height)) + 0 0 (- x (- root-x width)) + (- y (- root-y height)))))) + ((= type xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_BOTTOM) + (setq cursor exwm-floating--cursor-bottom + exwm-floating--moveresize-calculate + (lambda (_x y) + (vector buffer-or-id + xcb:ConfigWindow:Height + 0 0 0 (- y (- root-y height)))))) + ((= type xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_BOTTOMLEFT) + (setq cursor exwm-floating--cursor-bottom-left + exwm-floating--moveresize-calculate + (lambda (x y) + (vector buffer-or-id + (eval-when-compile + (logior xcb:ConfigWindow:X + xcb:ConfigWindow:Width + xcb:ConfigWindow:Height)) + (- x win-x) + 0 + (- (+ root-x width) x) + (- y (- root-y height)))))) + ((= type xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_LEFT) + (setq cursor exwm-floating--cursor-left + exwm-floating--moveresize-calculate + (lambda (x _y) + (vector buffer-or-id + (eval-when-compile + (logior xcb:ConfigWindow:X + xcb:ConfigWindow:Width)) + (- x win-x) 0 (- (+ root-x width) x) 0))))) + ;; Select events and change cursor (should always succeed) + (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:GrabPointer + :owner-events 0 :grab-window container-or-id + :event-mask (eval-when-compile + (logior xcb:EventMask:ButtonRelease + xcb:EventMask:ButtonMotion)) + :pointer-mode xcb:GrabMode:Async + :keyboard-mode xcb:GrabMode:Async + :confine-to xcb:Window:None + :cursor cursor + :time xcb:Time:CurrentTime))))))) + +(defun exwm-floating--stop-moveresize (&rest _args) + "Stop move/resize." + (exwm--log) + (xcb:+request exwm--connection + (make-instance 'xcb:UngrabPointer :time xcb:Time:CurrentTime)) + (when exwm-floating--moveresize-calculate + (let (result buffer-or-id outer-id container-id) + (setq result (funcall exwm-floating--moveresize-calculate 0 0) + buffer-or-id (aref result 0)) + (when (bufferp buffer-or-id) + (with-current-buffer buffer-or-id + (setq outer-id (frame-parameter exwm--floating-frame 'exwm-outer-id) + container-id (frame-parameter exwm--floating-frame + 'exwm-container)) + (with-slots (x y width height border-width) + (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:GetGeometry + :drawable container-id)) + ;; Notify Emacs frame about this the position change. + (xcb:+request exwm--connection + (make-instance 'xcb:SendEvent + :propagate 0 + :destination outer-id + :event-mask xcb:EventMask:StructureNotify + :event + (xcb:marshal + (make-instance 'xcb:ConfigureNotify + :event outer-id + :window outer-id + :above-sibling xcb:Window:None + :x (+ x border-width) + :y (+ y border-width) + :width width + :height height + :border-width 0 + :override-redirect 0) + exwm--connection))) + (xcb:flush exwm--connection)) + (exwm-layout--show exwm--id + (frame-root-window exwm--floating-frame))))) + (setq exwm-floating--moveresize-calculate nil))) + +(defun exwm-floating--do-moveresize (data _synthetic) + "Perform move/resize." + (when exwm-floating--moveresize-calculate + (let* ((obj (make-instance 'xcb:MotionNotify)) + result value-mask x y width height buffer-or-id container-or-id) + (xcb:unmarshal obj data) + (setq result (funcall exwm-floating--moveresize-calculate + (slot-value obj 'root-x) (slot-value obj 'root-y)) + buffer-or-id (aref result 0) + value-mask (aref result 1) + x (aref result 2) + y (aref result 3) + width (max 1 (aref result 4)) + height (max 1 (aref result 5))) + (if (not (bufferp buffer-or-id)) + ;; Unmanaged. + (setq container-or-id buffer-or-id) + ;; Managed. + (setq container-or-id + (with-current-buffer buffer-or-id + (frame-parameter exwm--floating-frame 'exwm-container)) + x (- x exwm-floating-border-width) + ;; Use `frame-outer-height' in the future. + y (- y exwm-floating-border-width + exwm-workspace--window-y-offset) + height (+ height exwm-workspace--window-y-offset))) + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window container-or-id + :value-mask (aref result 1) + :x x + :y y + :width width + :height height)) + (when (bufferp buffer-or-id) + ;; Managed. + (setq value-mask (logand value-mask (logior xcb:ConfigWindow:Width + xcb:ConfigWindow:Height))) + (when (/= 0 value-mask) + (with-current-buffer buffer-or-id + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window (frame-parameter exwm--floating-frame + 'exwm-outer-id) + :value-mask value-mask + :width width + :height height))))) + (xcb:flush exwm--connection)))) + +(defun exwm-floating-move (&optional delta-x delta-y) + "Move a floating window right by DELTA-X pixels and down by DELTA-Y pixels. + +Both DELTA-X and DELTA-Y default to 1. This command should be bound locally." + (exwm--log "delta-x: %s, delta-y: %s" delta-x delta-y) + (unless (and (derived-mode-p 'exwm-mode) exwm--floating-frame) + (user-error "[EXWM] `exwm-floating-move' is only for floating X windows")) + (unless delta-x (setq delta-x 1)) + (unless delta-y (setq delta-y 1)) + (unless (and (= 0 delta-x) (= 0 delta-y)) + (let* ((floating-container (frame-parameter exwm--floating-frame + 'exwm-container)) + (geometry (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:GetGeometry + :drawable floating-container))) + (edges (window-inside-absolute-pixel-edges))) + (with-slots (x y) geometry + (exwm--set-geometry floating-container + (+ x delta-x) (+ y delta-y) nil nil)) + (exwm--set-geometry exwm--id + (+ (pop edges) delta-x) + (+ (pop edges) delta-y) + nil nil)) + (xcb:flush exwm--connection))) + +(defun exwm-floating--init () + "Initialize floating module." + (exwm--log) + ;; Initialize cursors for moving/resizing a window + (xcb:cursor:init exwm--connection) + (setq exwm-floating--cursor-move + (xcb:cursor:load-cursor exwm--connection "fleur") + exwm-floating--cursor-top-left + (xcb:cursor:load-cursor exwm--connection "top_left_corner") + exwm-floating--cursor-top + (xcb:cursor:load-cursor exwm--connection "top_side") + exwm-floating--cursor-top-right + (xcb:cursor:load-cursor exwm--connection "top_right_corner") + exwm-floating--cursor-right + (xcb:cursor:load-cursor exwm--connection "right_side") + exwm-floating--cursor-bottom-right + (xcb:cursor:load-cursor exwm--connection "bottom_right_corner") + exwm-floating--cursor-bottom + (xcb:cursor:load-cursor exwm--connection "bottom_side") + exwm-floating--cursor-bottom-left + (xcb:cursor:load-cursor exwm--connection "bottom_left_corner") + exwm-floating--cursor-left + (xcb:cursor:load-cursor exwm--connection "left_side"))) + +(defun exwm-floating--exit () + "Exit the floating module." + (exwm--log)) + + + +(provide 'exwm-floating) + +;;; exwm-floating.el ends here |