;;; exwm-cm.el --- Compositing Manager for EXWM -*- lexical-binding: t -*-
;; Copyright (C) 2016 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 provides a compositing manager (CM) for EXWM, mainly to
;; enable transparency support.
;; Usage:
;; Add following lines to .emacs and modify accordingly:
;;
;; (require 'exwm-cm)
;; ;; Make all Emacs frames opaque.
;; (setq window-system-default-frame-alist '((x . ((alpha . 100)))))
;; ;; Assign everything else a 80% opacity.
;; (setq exwm-cm-opacity 80)
;; (exwm-cm-enable)
;;
;; With the last line this CM would be started with EXWM. You can also
;; start and stop this CM with `exwm-cm-start' and `exwm-cm-stop' at any
;; time.
;; Theory:
;; Due to its unique way of managing X windows, EXWM can not work with
;; any existing CMs. And this CM, designed specifically for EXWM,
;; probably won't work well with other WMs, too. The theories behind
;; all CMs are basically the same, some peculiarities of this CM are
;; summarized as the following sections.
;; + Data structures:
;; This CM organizes all X windows concerned with compositing in a
;; tree hierarchy. Below is a stripped-down version of such tree with
;; each node representing an X window (except the root placeholder),
;;
;; (nil
;; (root-xwin
;; (unmanaged-xwin)
;; (workspace-container
;; (unmanaged-xwin)
;; (xwin-container
;; (xwin)
;; (floating-frame-container
;; (floating-frame)))
;; (xwin-container
;; (xwin))
;; (workspace-frame-container
;; (workspace-frame)))
;; (minibuffer-frame-container
;; (minibuffer-frame))))
;;
;; where
;; - nodes with non-nil CDRs are containers,
;; - siblings are arranged in stacking order (top to bottom),
;; - and "managed" and "unmanaged" are in WM's sense.
;;
;; During a painting process, the tree is traversed starting from the
;; root node, with each leaf visited and painted. The attributes of
;; each X window (position, size, etc) are recorded as an instance of
;; class `exwm-cm--attr'. Such instance is associated with the
;; corresponding X window ID through a hash table. The instance also
;; contains a slot pointing to a subtree of the aforementioned tree,
;; with the root node being the parent of the X window. This makes it
;; convenient to carry out operations such as insertion, deletion,
;; restacking and reparenting.
;; + Compositing strategies:
;; - Only leaves are painted, since branches (containers) are always
;; invisible.
;; - The root X window is painted separately.
;; - Siblings below a workspace frame container are not painted; they
;; are considered hidden.
;; - Only the top workspace in one (RandR) output is painted.
;; - Workspace frames and floating frames are always clipped by its
;; Emacs windows displaying `exwm-mode' buffers, therefore they
;; don't block X windows.
;; Reference:
;; + xcompmgr (http://cgit.freedesktop.org/xorg/app/xcompmgr/)
;;; Code:
(require 'xcb-composite)
(require 'xcb-damage)
(require 'xcb-ewmh)
(require 'xcb-icccm)
(require 'xcb-renderutil)
(require 'xcb-shape)
(require 'exwm-core)
(require 'exwm-workspace)
(require 'exwm-manage)
(defconst exwm-cm--OPAQUE (float #xFFFFFFFF)
"The opacity value of the _NET_WM_WINDOW_OPACITY property.")
(defvar exwm-cm--_NET_WM_WINDOW_OPACITY nil "The _NET_WM_WINDOW_OPACITY atom.")
(defvar exwm-cm-opacity nil
"The default value of opacity when it's not explicitly specified.
The value should be a floating number between 0 (transparent) and 100
(opaque). A value of nil also means opaque.")
(defvar exwm-cm--hash nil
"The hash table associating X window IDs to their attributes.")
(defvar exwm-cm--conn nil "The X connection used by the CM.")
(defvar exwm-cm--buffer nil "The rendering buffer.")
(defvar exwm-cm--depth nil "Default depth.")
(defvar exwm-cm--clip-changed t "Whether clip has changed.")
(defvar exwm-cm--damages nil "All damaged regions.")
(defvar exwm-cm--expose-rectangles nil
"Used by Expose event handler to collect exposed regions.")
(defvar exwm-cm--background nil "The background (render) picture.")
(defvar exwm-cm--background-atom-names '("_XROOTPMAP_ID" "_XSETROOT_ID")
"Property names for background pixmap.")
(defvar exwm-cm--background-atoms nil "Interned atoms of the property names.")
(defun exwm-cm--get-opacity (xwin)
"Get the opacity of X window XWIN.
The value is between 0 (fully transparent) to #xFFFFFFFF (opaque)."
(let ((reply (xcb:+request-unchecked+reply exwm-cm--conn
(make-instance 'xcb:icccm:-GetProperty-single
:window xwin
:property exwm-cm--_NET_WM_WINDOW_OPACITY
:type xcb:Atom:CARDINAL))))
;; The X window might have already been destroyed.
(when reply
(slot-value reply 'value))))
(defun exwm-cm-set-opacity (xwin opacity)
"Set the opacity of X window XWIN to OPACITY.
The value is between 0 (fully transparent) to 100 (opaque).
If called interactively, XWIN would be the selected X window."
(interactive
(list (exwm--buffer->id (window-buffer))
(read-number "Opacity (0 ~ 100): " 100)))
(when (and xwin
(<= 0 opacity 100))
(setq opacity (round (* exwm-cm--OPAQUE (/ opacity 100.0))))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:icccm:-ChangeProperty-single
:window xwin
:property exwm-cm--_NET_WM_WINDOW_OPACITY
:type xcb:Atom:CARDINAL
:data opacity))
(xcb:flush exwm-cm--conn)))
(defclass exwm-cm--attr ()
(
;; The entity associated with this X window; can be a frame, a buffer
;; or nil.
(entity :initform nil)
;; The subtree of which the root node is the parent of this X window.
(tree :initarg :tree)
;; Geometry.
(x :initarg :x)
(y :initarg :y)
(width :initarg :width)
(height :initarg :height)
;; X window attributes.
(visual :initarg :visual)
(class :initarg :class)
;; The opacity of this X window; can be 0 ~ #xFFFE or nil.
(opacity :initform nil)
;; Determine whether this X window should be treated as opaque or
;; transparent; can be nil (opaque), 'argb or 'transparent (both
;; should be treated as transparent).
(mode :initform nil)
;; The (render) picture of this X window.
(picture :initform nil)
;; The 1x1 (render) picture with only alpha channel.
(alpha-picture :initform nil)
;; Whether this X window is ever damaged.
(damaged :initform nil)
;; The damage object monitoring this X window.
(damage :initarg :damage)
;; The bounding region of this X window (can be irregular).
(border-size :initform nil)
;; The rectangular bounding region of this X window.
(extents :initform nil)
;; The region require repainting (used for transparent X windows).
(border-clip :initform nil)
;; Shape-related parameters.
(shaped :initform nil)
(shape-x :initarg :shape-x)
(shape-y :initarg :shape-y)
(shape-width :initarg :shape-width)
(shape-height :initarg :shape-height))
:documentation "Attributes of an X window.")
(defsubst exwm-cm--xwin->attr (xwin)
"Get the attributes of X window XWIN."
(gethash xwin exwm-cm--hash))
(defsubst exwm-cm--get-tree (xwin)
"Get the subtree of the parent of X window XWIN."
(slot-value (exwm-cm--xwin->attr xwin) 'tree))
(defsubst exwm-cm--set-tree (xwin tree)
"Reparent X window XWIN to another tree TREE."
(setf (slot-value (exwm-cm--xwin->attr xwin) 'tree) tree))
(defsubst exwm-cm--get-parent (xwin)
"Get the parent of X window XWIN."
(car (exwm-cm--get-tree xwin)))
(defsubst exwm-cm--get-siblings (xwin)
"Get a list of subtrees of the siblings of X window XWIN"
(cdr (exwm-cm--get-tree xwin)))
(defsubst exwm-cm--get-subtree (xwin)
"Get the subtree of which the X window XWIN is the root node."
(assq xwin (exwm-cm--get-siblings xwin)))
(defun exwm-cm--create-attr (xwin tree x y width height)
"Create attributes for X window XWIN.
TREE is the subtree and the parent of this X window is the tree's root.
X and Y specify the position with regard to the root X window. WIDTH
and HEIGHT specify the size of the X window."
(let (visual class map-state damage attr)
(cond
((= xwin exwm--root)
;; Redirect all subwindows to off-screen storage.
(xcb:+request exwm-cm--conn
(make-instance 'xcb:composite:RedirectSubwindows
:window exwm--root
:update xcb:composite:Redirect:Manual))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:ChangeWindowAttributes
:window xwin
:value-mask xcb:CW:EventMask
:event-mask (logior xcb:EventMask:StructureNotify
xcb:EventMask:PropertyChange
xcb:EventMask:SubstructureNotify
xcb:EventMask:Exposure)))
(setq visual (slot-value (car (slot-value (xcb:get-setup exwm-cm--conn)
'roots))
'root-visual)
class xcb:WindowClass:InputOutput))
((eq xwin exwm-manage--desktop)
;; Ignore any desktop; paint the background ourselves.
(setq visual 0
class xcb:WindowClass:InputOnly
map-state xcb:MapState:Unmapped))
(t
;; Redirect this window to off-screen storage, or the content
;; would be mirrored to its parent.
(xcb:+request exwm-cm--conn
(make-instance 'xcb:composite:RedirectWindow
:window xwin
:update xcb:composite:Redirect:Manual))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:ChangeWindowAttributes
:window xwin
:value-mask xcb:CW:EventMask
:event-mask (logior xcb:EventMask:StructureNotify
xcb:EventMask:PropertyChange)))
(let ((reply (xcb:+request-unchecked+reply exwm-cm--conn
(make-instance 'xcb:GetWindowAttributes
:window xwin))))
(if reply
(with-slots ((visual* visual)
(class* class)
(map-state* map-state))
reply
(setq visual visual*
class class*
map-state map-state*))
;; The X window has been destroyed actually. It'll get
;; removed by a DestroyNotify event.
(setq visual 0
class xcb:WindowClass:InputOnly
map-state xcb:MapState:Unmapped)))
(when (/= class xcb:WindowClass:InputOnly)
(setq damage (xcb:generate-id exwm-cm--conn))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:damage:Create
:damage damage
:drawable xwin
:level xcb:damage:ReportLevel:NonEmpty))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:shape:SelectInput
:destination-window xwin
:enable 1)))))
(setq attr (make-instance 'exwm-cm--attr
:tree tree
:x x
:y y
:width width
:height height
:visual visual
:class class
:damage damage
:shape-x x
:shape-y y
:shape-width width
:shape-height height))
(puthash xwin attr exwm-cm--hash)
(unless (or (= xwin exwm--root)
(= class xcb:WindowClass:InputOnly))
(exwm-cm--update-opacity xwin)
(when (= map-state xcb:MapState:Viewable)
(exwm-cm--map-xwin xwin t)))))
(defun exwm-cm--update-geometry (xwin x y width height &optional above-sibling)
"Update the geometry of X window XWIN.
X, Y, WIDTH and HEIGHT have the same meaning with the arguments used in
`exwm-cm--create-attr'. If ABOVE-SIBLING is non-nil, restack XWIN with
`exwm-cm--restack.'"
(with-slots ((x* x)
(y* y)
(width* width)
(height* height)
extents shaped shape-x shape-y shape-width shape-height)
(exwm-cm--xwin->attr xwin)
(let ((stack-changed (and above-sibling
(exwm-cm--restack xwin above-sibling)))
(position-changed (or (and x (/= x x*))
(and y (/= y y*))))
(size-changed (or (and width (/= width width*))
(and height (/= height height*))))
subtree dx dy damage new-extents)
(when position-changed
(setq subtree (exwm-cm--get-subtree xwin)
dx (- x x*)
dy (- y y*))
(dolist (node (cdr subtree))
(with-slots (x y) (exwm-cm--xwin->attr (car node))
(exwm--log "(CM) #x%X(*): @%+d%+d => @%+d%+d"
(car node) x y (+ x dx) (+ y dy))
(exwm-cm--update-geometry (car node) (+ x dx) (+ y dy) nil nil)))
(exwm--log "(CM) #x%X: @%+d%+d => @%+d%+d" xwin x* y* x y)
(setf x* x
y* y)
(cl-incf shape-x dx)
(cl-incf shape-y dy))
(when size-changed
(setf width* width
height* height)
(unless shaped
(setf shape-width width
shape-height height)))
(when (or stack-changed position-changed size-changed)
(setq damage (xcb:generate-id exwm-cm--conn)
new-extents (xcb:generate-id exwm-cm--conn))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:CreateRegion
:region damage
:rectangles nil))
(when extents
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:CopyRegion
:source extents
:destination damage)))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:CreateRegion
:region new-extents
:rectangles (list (make-instance 'xcb:RECTANGLE
:x x*
:y y*
:width width*
:height height*))))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:UnionRegion
:source1 damage
:source2 new-extents
:destination damage))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:DestroyRegion
:region new-extents))
(exwm-cm--add-damage damage)))))
(defun exwm-cm--update-opacity (xwin)
"Update the opacity of X window XWIN."
(with-slots (visual opacity mode alpha-picture extents)
(exwm-cm--xwin->attr xwin)
(let (format forminfo)
;; Get the opacity.
(setf opacity (exwm-cm--get-opacity xwin))
(if opacity
(setf opacity (round (* #xFFFF (/ opacity exwm-cm--OPAQUE))))
(when (numberp exwm-cm-opacity)
(setf opacity (round (* #xFFFF (/ exwm-cm-opacity 100.0))))))
(when (and opacity
(>= opacity #xFFFF))
(setf opacity nil))
;; Determine the mode of the X window.
(setq format (xcb:renderutil:find-visual-format
(xcb:renderutil:query-formats exwm-cm--conn) visual))
(when format
(catch 'break
(dolist (f (slot-value (xcb:renderutil:query-formats exwm-cm--conn)
'formats))
(when (eq format (slot-value f 'id))
(setq forminfo f)
(throw 'break nil)))))
(if (and forminfo
(eq xcb:render:PictType:Direct (slot-value forminfo 'type))
(/= 0 (slot-value (slot-value forminfo 'direct) 'alpha-mask)))
(setf mode 'argb)
(if opacity
(setf mode 'transparent)
(setf mode nil)))
;; Clear resources.
(when alpha-picture
(xcb:+request exwm-cm--conn
(make-instance 'xcb:render:FreePicture
:picture alpha-picture))
(setf alpha-picture nil))
(when extents
(let ((damage (xcb:generate-id exwm-cm--conn)))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:CreateRegion
:region damage
:rectangles nil))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:CopyRegion
:source extents
:destination damage))
(exwm-cm--add-damage damage))))))
(defsubst exwm-cm--push (newelt place)
"Similar to `push' but preserve the reference."
(let ((oldelt (car place)))
(setf (car place) newelt
(cdr place) (cons oldelt (cdr place)))))
(defsubst exwm-cm--delq (elt list)
"Similar to `delq' but preserve the reference."
(if (eq elt (car list))
(setf (car list) (cadr list)
(cdr list) (cddr list))
(delq elt list)))
(defsubst exwm-cm--assq-delete-all (key alist)
"Similar to `assq-delete-all' but preserve the reference."
(when (eq key (caar alist))
(setf (car alist) (cadr alist)
(cdr alist) (cddr alist)))
(assq-delete-all key alist))
(defun exwm-cm--create-tree (&optional xwin)
"Create a tree with XWIN being the root node."
(let (tree0 x0 y0 children containers)
;; Get the position of this branch.
(if xwin
(with-slots (tree x y) (exwm-cm--xwin->attr xwin)
(setq tree0 (assq xwin (cdr tree))
x0 x
y0 y))
(setq tree0 (list nil)
x0 0
y0 0))
;; Get children nodes.
(if (null xwin)
(setq children (list exwm--root))
(setq children
(reverse (slot-value (xcb:+request-unchecked+reply exwm-cm--conn
(make-instance 'xcb:QueryTree
:window xwin))
'children))))
;; Get container nodes.
;; Floating frame containers are determined dynamically.
(cond
((null xwin)
(setq containers `((,exwm--root))))
((= xwin exwm--root)
;; Workspace containers and the minibuffer frame container.
(setq containers (mapcar (lambda (f)
(cons (frame-parameter f 'exwm-workspace) f))
exwm-workspace--list))
(when (exwm-workspace--minibuffer-own-frame-p)
(push (cons
(frame-parameter exwm-workspace--minibuffer 'exwm-container)
exwm-workspace--minibuffer)
containers)))
;; No containers in the minibuffer container.
((and (exwm-workspace--minibuffer-own-frame-p)
(= xwin
(frame-parameter exwm-workspace--minibuffer 'exwm-container))))
((= exwm--root
(slot-value (xcb:+request-unchecked+reply exwm-cm--conn
(make-instance 'xcb:QueryTree
:window xwin))
'parent))
;; Managed X window containers and the workspace frame container.
(let (frame)
(catch 'break
(dolist (f exwm-workspace--list)
(when (= xwin (frame-parameter f 'exwm-workspace))
(setq frame f)
(throw 'break nil))))
(cl-assert frame)
(dolist (pair exwm--id-buffer-alist)
(with-current-buffer (cdr pair)
(when (eq frame exwm--frame)
(push (cons exwm--container (cdr pair)) containers))))
(push (cons (frame-parameter frame 'exwm-container) frame)
containers))))
;; Create subnodes.
(dolist (xwin children)
;; Create attributes.
(let ((reply (xcb:+request-unchecked+reply exwm-cm--conn
(make-instance 'xcb:GetGeometry
:drawable xwin))))
;; It's possible the X window has been destroyed.
(if (null reply)
(setq xwin nil)
(when reply
(with-slots (x y width height) reply
(exwm-cm--create-attr xwin tree0
(+ x x0) (+ y y0) width height))
;; Insert the node.
(setcdr (or (last (cdr tree0)) tree0) `((,xwin))))))
(cond
((null xwin))
((assq xwin containers)
;; A branch. Repeat the process.
(exwm-cm--create-tree xwin)
(let ((entity (cdr (assq xwin containers)))
entity-xwin)
(when entity
(setq entity-xwin (if (framep entity)
(frame-parameter entity 'exwm-outer-id)
(buffer-local-value 'exwm--id entity)))
(setf (slot-value (exwm-cm--xwin->attr entity-xwin) 'entity) entity
(slot-value (exwm-cm--xwin->attr xwin) 'entity) entity)
(let ((tmp (exwm-cm--get-parent entity-xwin)))
(when (/= xwin tmp)
;; Workspace frame container.
(setf (slot-value (exwm-cm--xwin->attr tmp) 'entity)
entity))))))
((and (null containers)
(exwm--id->buffer xwin))
;; A leaf but a floating frame container might follow.
(with-current-buffer (exwm--id->buffer xwin)
(when exwm--floating-frame
(push (cons (frame-parameter exwm--floating-frame 'exwm-container)
exwm--floating-frame)
containers))))))))
(defun exwm-cm--restack (xwin above-sibling)
"Restack X window XWIN so as to it's exactly on top of ABOVE-SIBLING."
(let ((siblings (exwm-cm--get-siblings xwin))
node tmp)
(unless (= 1 (length siblings))
(setq node (assq xwin siblings))
(if (= above-sibling xcb:Window:None)
;; Put at bottom.
(unless (eq node (cdr (last siblings)))
(exwm-cm--delq node siblings)
(setcdr (last siblings) (list node))
;; Set the return value.
t)
;; Insert before the sibling.
(setq tmp siblings)
(while (and tmp
(/= above-sibling (caar tmp)))
(setq tmp (cdr tmp)))
(cl-assert tmp)
;; Check if it's already at the requested position.
(unless (eq tmp (cdr siblings))
(exwm-cm--delq node siblings)
(exwm-cm--push node tmp)
;; Set the return value.
t)))))
(declare-function exwm-layout--iconic-state-p "exwm-layout.el" (&optional id))
(defun exwm-cm--paint-tree (tree region &optional force-opaque frame-clip)
"Paint the tree TREE, with REGION specifying the clipping region.
If FORCE-OPAQUE is non-nil, all X windows painted in this tree is
assumed opaque. FRAME-CLIP specifies the region should be clipped when
painting a frame."
(unless tree
(setq tree (exwm-cm--get-tree exwm--root)))
(let ((root (car tree))
xwin attr entity current output outputs queue rectangles)
;; Paint subtrees.
(catch 'break
(dolist (subtree (cdr tree))
(setq xwin (car subtree)
attr (exwm-cm--xwin->attr xwin))
(cond
;; Skip destroyed X windows.
((null attr))
;; Skip InputOnly X windows.
((= xcb:WindowClass:InputOnly
(slot-value attr 'class)))
((and (eq root exwm--root)
(frame-live-p (setq entity (slot-value attr 'entity)))
(if (eq entity exwm-workspace--minibuffer)
;; Skip the minibuffer if the current workspace is
;; already painted.
(unless (exwm-workspace--minibuffer-attached-p)
current)
;; Skip lower workspaces on visited RandR output.
;; If RandR is not enabled, it'll just paint the first.
(memq (setq output (frame-parameter entity
'exwm-randr-output))
outputs))))
((cdr subtree)
;; Paint the subtree.
(setq entity (slot-value attr 'entity))
(let (fullscreen clip)
(cond
((buffer-live-p entity)
(with-current-buffer entity
;; Collect frame clip but exclude fullscreen and
;; floating X windows.
(setq fullscreen (memq xcb:Atom:_NET_WM_STATE_FULLSCREEN
exwm--ewmh-state))
(when (and (null fullscreen)
;; In case it's hidden.
(null (exwm-layout--iconic-state-p))
;; The buffer of a floating X windows is not
;; displayed on a workspace frame.
(null exwm--floating-frame)
;; Opaque regions are always clipped.
(slot-value (exwm-cm--xwin->attr xwin) 'mode))
;; Prepare rectangles to clip the workspace frame.
(with-slots (x y width height) (exwm-cm--xwin->attr xwin)
(push (make-instance 'xcb:RECTANGLE
:x x
:y y
:width width
:height height)
rectangles)))))
((and rectangles
(frame-live-p entity))
;; Prepare region to clip the frame.
(setq clip (xcb:generate-id exwm-cm--conn))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:CreateRegion
:region clip
:rectangles rectangles))))
(setq queue
(nconc (exwm-cm--paint-tree subtree region fullscreen clip)
queue))
(when fullscreen
;; Fullscreen X windows are always opaque thus occludes
;; anything in this workspace.
(throw 'break 'fullscreen))
(when clip
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:DestroyRegion
:region clip))))
(if (not (eq root exwm--root))
;; Avoid painting any siblings below the workspace frame
;; container.
(when (exwm-workspace--workspace-p (slot-value attr 'entity))
(throw 'break nil))
;; Save some status.
(when (and (frame-live-p entity)
(not (eq entity exwm-workspace--minibuffer)))
(push output outputs)
(when (eq entity exwm-workspace--current)
(setq current t)))))
((and force-opaque
(slot-value attr 'damaged))
(exwm-cm--paint-opaque xwin region t))
((slot-value attr 'damaged)
;; Paint damaged leaf.
(setq entity (slot-value attr 'entity))
(when (slot-value attr 'mode)
(push xwin queue))
(cond
((buffer-live-p entity)
(with-current-buffer entity
(cl-assert (= xwin exwm--id))
(when (and exwm--floating-frame
;; Opaque regions are always clipped.
(slot-value (exwm-cm--xwin->attr xwin) 'mode))
;; Prepare rectangles to clip the floating frame.
(with-slots (x y width height) (exwm-cm--xwin->attr xwin)
(push (make-instance 'xcb:RECTANGLE
:x x
:y y
:width width
:height height)
rectangles)))))
((and frame-clip
(frame-live-p entity))
;; Apply frame clip.
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:IntersectRegion
:source1 region
:source2 frame-clip
:destination frame-clip))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:SubtractRegion
:source1 region
:source2 frame-clip
:destination region))))
(exwm-cm--paint-opaque xwin region)
(when (and frame-clip
(frame-live-p entity))
;; Restore frame clip.
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:UnionRegion
:source1 region
:source2 frame-clip
:destination region)))))))
;; Return the queue.
queue))
(defun exwm-cm--paint-opaque (xwin region &optional force-opaque)
"Paint an X window XWIN clipped by region REGION if XWIN is opaque.
Also update the attributes of XWIN and clip the region."
(with-slots (x y width height visual mode picture
border-size extents border-clip)
(exwm-cm--xwin->attr xwin)
;; Prepare the X window picture.
(unless picture
(setf picture (xcb:generate-id exwm-cm--conn))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:render:CreatePicture
:pid picture
:drawable xwin
:format (xcb:renderutil:find-visual-format
(xcb:renderutil:query-formats exwm-cm--conn)
visual)
:value-mask 0)))
;; Clear cached resources if clip changed.
(when exwm-cm--clip-changed
(when border-size
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:DestroyRegion
:region border-size))
(setf border-size nil))
(when extents
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:DestroyRegion
:region extents))
(setf extents nil))
(when border-clip
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:DestroyRegion
:region border-clip))
(setf border-clip nil)))
;; Retrieve the border.
(unless border-size
(setf border-size (xcb:generate-id exwm-cm--conn))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:CreateRegionFromWindow
:region border-size
:window xwin
:kind xcb:shape:SK:Bounding))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:TranslateRegion
:region border-size
:dx x
:dy y)))
;; Retrieve the extents.
(unless extents
(setf extents (xcb:generate-id exwm-cm--conn))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:CreateRegion
:region extents
:rectangles (list (make-instance 'xcb:RECTANGLE
:x x
:y y
:width width
:height height)))))
(cond
((and mode
(null force-opaque))
;; Calculate clipped border for the transparent X window.
(unless border-clip
(setf border-clip (xcb:generate-id exwm-cm--conn))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:CreateRegion
:region border-clip
:rectangles nil))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:CopyRegion
:source region
:destination border-clip))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:IntersectRegion
:source1 border-clip
:source2 border-size
:destination border-clip))))
(t
;; Clip & render for the opaque X window.
;; Set the clip region for the rendering buffer.
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:SetPictureClipRegion
:picture exwm-cm--buffer
:region region
:x-origin 0
:y-origin 0))
;; Clip the region with border.
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:SubtractRegion
:source1 region
:source2 border-size
:destination region))
;; Render the picture to the buffer.
(xcb:+request exwm-cm--conn
(make-instance 'xcb:render:Composite
:op xcb:render:PictOp:Src
:src picture
:mask xcb:render:Picture:None
:dst exwm-cm--buffer
:src-x 0
:src-y 0
:mask-x 0
:mask-y 0
:dst-x x
:dst-y y
:width width
:height height))))))
(defun exwm-cm--paint-transparent (xwin)
"Paint a transparent X window XWIN."
(with-slots (x y width height opacity picture alpha-picture border-clip)
(exwm-cm--xwin->attr xwin)
;; Prepare the alpha picture for transparent X windows.
(when (and opacity (null alpha-picture))
(setf alpha-picture (xcb:generate-id exwm-cm--conn))
(let ((pixmap (xcb:generate-id exwm-cm--conn)))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:CreatePixmap
:depth 8
:pid pixmap
:drawable exwm--root
:width 1
:height 1))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:render:CreatePicture
:pid alpha-picture
:drawable pixmap
:format (xcb:renderutil:find-standard
(xcb:renderutil:query-formats
exwm-cm--conn)
xcb:renderutil:PICT_STANDARD:A_8)
:value-mask xcb:render:CP:Repeat
:repeat 1))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:render:FillRectangles
:op xcb:render:PictOp:Src
:dst alpha-picture
:color (make-instance 'xcb:render:COLOR
:red 0
:green 0
:blue 0
:alpha opacity)
:rects (list (make-instance 'xcb:RECTANGLE
:x 0
:y 0
:width 1
:height 1))))))
;; Set the clip region for the rendering buffer.
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:SetPictureClipRegion
:picture exwm-cm--buffer
:region border-clip
:x-origin 0
:y-origin 0))
;; Render the picture to the buffer.
(xcb:+request exwm-cm--conn
(make-instance 'xcb:render:Composite
:op xcb:render:PictOp:Over
:src picture
:mask (or alpha-picture xcb:render:Picture:None)
:dst exwm-cm--buffer
:src-x 0
:src-y 0
:mask-x 0
:mask-y 0
:dst-x x
:dst-y y
:width width
:height height))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:DestroyRegion
:region border-clip))
(setf border-clip nil)))
(defun exwm-cm--paint (&optional region)
"Paint the whole tree within clipping region REGION.
If REGION is omitted, `exwm-cm--damages' is assumed. If it's t, paint
the whole screen."
;; Prepare the clipping region.
(cond
((null region)
(when exwm-cm--damages
(setq region exwm-cm--damages)))
((eq region t)
(with-slots (width height) (exwm-cm--xwin->attr exwm--root)
(let ((rect (make-instance 'xcb:RECTANGLE
:x 0
:y 0
:width width
:height height)))
(setq region (xcb:generate-id exwm-cm--conn))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:CreateRegion
:region region
:rectangles (list rect)))))))
(when region
;; Prepare the rendering buffer.
(unless exwm-cm--buffer
(let ((pixmap (xcb:generate-id exwm-cm--conn))
(picture (xcb:generate-id exwm-cm--conn)))
(setq exwm-cm--buffer picture)
(with-slots (width height visual) (exwm-cm--xwin->attr exwm--root)
(xcb:+request exwm-cm--conn
(make-instance 'xcb:CreatePixmap
:depth exwm-cm--depth
:pid pixmap
:drawable exwm--root
:width width
:height height))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:render:CreatePicture
:pid picture
:drawable pixmap
:format (xcb:renderutil:find-visual-format
(xcb:renderutil:query-formats
exwm-cm--conn)
visual)
:value-mask 0)))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:FreePixmap
:pixmap pixmap))))
(let (queue)
;; Paint opaque X windows and update clipping region.
(setq queue (exwm-cm--paint-tree nil region))
;; Paint the background.
(exwm-cm--paint-background region)
;; Paint transparent X windows.
(while queue
(exwm-cm--paint-transparent (pop queue))))
;; Submit changes.
(with-slots (width height picture) (exwm-cm--xwin->attr exwm--root)
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:SetPictureClipRegion
:picture exwm-cm--buffer
:region xcb:xfixes:Region:None
:x-origin 0
:y-origin 0))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:render:Composite
:op xcb:render:PictOp:Src
:src exwm-cm--buffer
:mask xcb:render:Picture:None
:dst picture
:src-x 0
:src-y 0
:mask-x 0
:mask-y 0
:dst-x 0
:dst-y 0
:width width
:height height)))
;; Cleanup.
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:DestroyRegion
:region region))
(when (eq region exwm-cm--damages)
(setq exwm-cm--damages nil))
(setq exwm-cm--clip-changed nil)
(xcb:flush exwm-cm--conn)))
(defun exwm-cm--paint-background (region)
"Paint the background."
(unless exwm-cm--background
(setq exwm-cm--background (xcb:generate-id exwm-cm--conn))
(let (pixmap exist)
(catch 'break
(dolist (atom exwm-cm--background-atoms)
(with-slots (~lsb format value-len value)
(xcb:+request-unchecked+reply exwm-cm--conn
(make-instance 'xcb:GetProperty
:delete 0
:window exwm--root
:property atom
:type xcb:Atom:PIXMAP
:long-offset 0
:long-length 4))
(when (and (= format 32)
(= 1 value-len))
(setq pixmap (if ~lsb
(xcb:-unpack-u4-lsb value 0)
(xcb:-unpack-u4 value 0)))
(setq exist t)
(throw 'break nil)))))
(unless pixmap
(setq pixmap (xcb:generate-id exwm-cm--conn))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:CreatePixmap
:depth exwm-cm--depth
:pid pixmap
:drawable exwm--root
:width 1
:height 1)))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:render:CreatePicture
:pid exwm-cm--background
:drawable pixmap
:format (xcb:renderutil:find-visual-format
(xcb:renderutil:query-formats exwm-cm--conn)
(slot-value (exwm-cm--xwin->attr exwm--root)
'visual))
:value-mask xcb:render:CP:Repeat
:repeat 1))
(unless exist
(xcb:+request exwm-cm--conn
(make-instance 'xcb:render:FillRectangles
:op xcb:render:PictOp:Src
:dst exwm-cm--background
:color (make-instance 'xcb:render:COLOR
:red #x8080
:green #x8080
:blue #x8080
:alpha #xFFFF)
:rects (list (make-instance 'xcb:RECTANGLE
:x 0
:y 0
:width 1
:height 1)))))))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:SetPictureClipRegion
:picture exwm-cm--buffer
:region region
:x-origin 0
:y-origin 0))
(with-slots (width height) (exwm-cm--xwin->attr exwm--root)
(xcb:+request exwm-cm--conn
(make-instance 'xcb:render:Composite
:op xcb:render:PictOp:Src
:src exwm-cm--background
:mask xcb:render:Picture:None
:dst exwm-cm--buffer
:src-x 0
:src-y 0
:mask-x 0
:mask-y 0
:dst-x 0
:dst-y 0
:width width
:height height))))
(defun exwm-cm--map-xwin (xwin &optional silent)
"Prepare to map X window XWIN."
(let ((attr (exwm-cm--xwin->attr xwin)))
(setf (slot-value attr 'damaged) nil)
;; Add to damage.
(when (slot-value attr 'extents)
(let ((damage (xcb:generate-id exwm-cm--conn)))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:CreateRegion
:region damage
:rectangles nil))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:CopyRegion
:source (slot-value attr 'extents)
:destination damage))
(exwm-cm--add-damage damage))
(unless silent
(exwm-cm--paint)))))
(defun exwm-cm--on-MapNotify (data _synthetic)
"Handle MapNotify events."
(let ((obj (make-instance 'xcb:MapNotify))
attr)
(xcb:unmarshal obj data)
(with-slots (event window) obj
(exwm--log "(CM) MapNotify: Try to map #x%X" window)
(setq attr (exwm-cm--xwin->attr window))
(when (and attr
(/= (slot-value attr 'class) xcb:WindowClass:InputOnly)
(or (= event exwm--root)
;; Filter out duplicated events.
(/= exwm--root (exwm-cm--get-parent window))))
(exwm--log "(CM) MapNotify: Map")
(exwm-cm--map-xwin window)))))
(defun exwm-cm--on-UnmapNotify (data _synthetic)
"Handle UnmapNotify events."
(let ((obj (make-instance 'xcb:UnmapNotify))
attr)
(xcb:unmarshal obj data)
(with-slots (event window) obj
(exwm--log "(CM) UnmapNotify: Try to unmap #x%X" window)
(setq attr (exwm-cm--xwin->attr window))
(when (and attr
(or (= event exwm--root)
;; Filter out duplicated events.
(/= exwm--root (exwm-cm--get-parent window))))
(exwm--log "(CM) UnmapNotify: Unmap")
(with-slots (picture damaged border-size extents border-clip) attr
(setf damaged nil)
(when picture
(xcb:+request exwm-cm--conn
(make-instance 'xcb:render:FreePicture
:picture picture))
(setf picture nil))
(when border-size
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:DestroyRegion
:region border-size))
(setf border-size nil))
(when extents
(exwm-cm--add-damage extents)
(setf extents nil))
(when border-clip
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:DestroyRegion
:region border-clip))
(setf border-clip nil)))
(setq exwm-cm--clip-changed t)
(exwm-cm--paint)))))
(defun exwm-cm--on-CreateNotify (data _synthetic)
"Handle CreateNotify events."
(let ((obj (make-instance 'xcb:CreateNotify))
tree0)
(xcb:unmarshal obj data)
(with-slots (window parent x y width height) obj
(exwm--log "(CM) CreateNotify: Create #x%X on #x%X @%sx%s%+d%+d"
window parent width height x y)
(cl-assert (= parent exwm--root))
(cl-assert (null (exwm-cm--xwin->attr window)))
(setq tree0 (exwm-cm--get-subtree parent))
(exwm-cm--create-attr window tree0 x y width height)
(if (cdr tree0)
(exwm-cm--push (list window) (cdr tree0))
(setcdr tree0 `((,window)))))))
(defun exwm-cm--on-ConfigureNotify (data synthetic)
"Handle ConfigureNotify events."
;; Ignore synthetic ConfigureNotify events sent by the WM.
(unless synthetic
(let ((obj (make-instance 'xcb:ConfigureNotify)))
(xcb:unmarshal obj data)
(with-slots (event window above-sibling x y width height) obj
(exwm--log
"(CM) ConfigureNotify: Try to configure #x%X @%sx%s%+d%+d, above #x%X"
window width height x y above-sibling)
(cond
((= window exwm--root)
(exwm--log "(CM) ConfigureNotify: Configure the root X window")
(when exwm-cm--buffer
(xcb:+request exwm-cm--conn
(make-instance 'xcb:render:FreePicture
:picture exwm-cm--buffer))
(setq exwm-cm--buffer nil))
(with-slots ((x* x)
(y* y)
(width* width)
(height* height))
(exwm-cm--xwin->attr exwm--root)
(setf x* x
y* y
width* width
height* height))
(exwm-cm--paint))
((null (exwm-cm--xwin->attr window)))
((or (= event exwm--root)
;; Filter out duplicated events.
(/= exwm--root (exwm-cm--get-parent window)))
(exwm--log "(CM) ConfigureNotify: Configure")
(with-slots ((x0 x)
(y0 y))
(exwm-cm--xwin->attr (exwm-cm--get-parent window))
(exwm-cm--update-geometry window (+ x x0) (+ y y0) width height
above-sibling))
(setq exwm-cm--clip-changed t)
(exwm-cm--paint))
(t
(exwm--log "(CM) ConfigureNotify: Skip event from #x%X" event)))))))
(defun exwm-cm--destroy (xwin)
"Prepare to destroy X window XWIN."
(with-slots (tree picture alpha-picture damage
border-size extents border-clip)
(exwm-cm--xwin->attr xwin)
(cl-assert (assq xwin (cdr tree)))
(if (= 1 (length (cdr tree)))
(setcdr tree nil)
(exwm-cm--assq-delete-all xwin (cdr tree)))
(remhash xwin exwm-cm--hash)
;; Release resources.
(when picture
(xcb:+request exwm-cm--conn
(make-instance 'xcb:render:FreePicture
:picture picture))
(setf picture nil))
(when alpha-picture
(xcb:+request exwm-cm--conn
(make-instance 'xcb:render:FreePicture
:picture alpha-picture))
(setf alpha-picture nil))
(when damage
(xcb:+request exwm-cm--conn
(make-instance 'xcb:damage:Destroy
:damage damage))
(setf damage nil))
(when border-size
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:DestroyRegion
:region border-size))
(setf border-size nil))
(when extents
(exwm-cm--add-damage extents)
(setf extents nil))
(when border-clip
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:DestroyRegion
:region border-clip))
(setf border-clip nil))))
(defun exwm-cm--on-DestroyNotify (data _synthetic)
"Handle DestroyNotify events."
(let ((obj (make-instance 'xcb:DestroyNotify))
xwin)
(xcb:unmarshal obj data)
(setq xwin (slot-value obj 'window))
(exwm--log "(CM) DestroyNotify: Try to destroy #x%X" xwin)
(when (exwm-cm--xwin->attr xwin)
(exwm--log "(CM) DestroyNotify: Destroy")
(exwm-cm--destroy xwin))))
(defun exwm-cm--on-CirculateNotify (data _synthetic)
"Handle CirculateNotify events."
(let ((obj (make-instance 'xcb:CirculateNotify))
attr)
(xcb:unmarshal obj data)
(with-slots (event window place) obj
(setq attr (exwm-cm--xwin->attr window))
(exwm--log "(CM) CirculateNotify: Try to circulate #x%X to %s"
window place)
(when (and attr
(or (= event exwm--root)
;; Filter out duplicated events.
(/= exwm--root (exwm-cm--get-parent window))))
(exwm--log "(CM) CirculateNotify: Circulate")
(exwm-cm--update-geometry window nil nil nil nil
(if (= place xcb:Circulate:LowerHighest)
xcb:Window:None
(caar (exwm-cm--get-siblings window))))
(setq exwm-cm--clip-changed t)
(exwm-cm--paint)))))
(defun exwm-cm--on-Expose (data _synthetic)
"Handle Expose events."
(let ((obj (make-instance 'xcb:Expose)))
(xcb:unmarshal obj data)
(with-slots (window x y width height count) obj
(when (eq window exwm--root)
(push (make-instance 'xcb:RECTANGLE
:x x
:y y
:width width
:height height)
exwm-cm--expose-rectangles))
(when (= count 0)
(let ((region (xcb:generate-id exwm-cm--conn)))
(xcb:+request exwm-cm--conn
(xcb:xfixes:CreateRegion
:region region
:rectangles exwm-cm--expose-rectangles))
(exwm-cm--add-damage region))
(setq exwm-cm--expose-rectangles nil)
(exwm-cm--paint)))))
(defun exwm-cm--on-PropertyNotify (data _synthetic)
"Handle PropertyNotify events."
(let ((obj (make-instance 'xcb:PropertyNotify)))
(xcb:unmarshal obj data)
(with-slots (window atom) obj
(cond
((and (= window exwm--root)
(memq atom exwm-cm--background-atoms))
(exwm--log "(CM) PropertyNotify: Update background")
(when exwm-cm--background
(xcb:+request exwm-cm--conn
(make-instance 'xcb:render:FreePicture
:picture exwm-cm--background))
(setq exwm-cm--background nil)
(xcb:+request exwm-cm--conn
(make-instance 'xcb:ClearArea
:exposures 1
:window exwm--root
:x 0
:y 0
:width 0
:height 0))
(xcb:flush exwm-cm--conn)))
((and (= atom exwm-cm--_NET_WM_WINDOW_OPACITY)
;; Some applications also set this property on their parents.
(null (cdr (exwm-cm--get-subtree window))))
(when (exwm-cm--xwin->attr window)
(exwm--log "(CM) PropertyNotify: Update opacity for #x%X" window)
(exwm-cm--update-opacity window)
(exwm-cm--paint)))))))
(defun exwm-cm--prepare-container (xwin)
"Make X window XWIN a container by deselecting unnecessary events."
(with-slots (damage) (exwm-cm--xwin->attr xwin)
(when damage
(xcb:+request exwm-cm--conn
(make-instance 'xcb:damage:Destroy
:damage damage)))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:shape:SelectInput
:destination-window xwin
:enable 0))))
(defun exwm-cm--on-ReparentNotify (data _synthetic)
"Handle ReparentNotify events."
(let ((obj (make-instance 'xcb:ReparentNotify))
tree tree0 grandparent great-grandparent entity)
(xcb:unmarshal obj data)
(with-slots (window parent x y) obj
(exwm--log "(CM) ReparentNotify: Try to reparent #x%X to #x%X @%+d%+d"
window parent x y)
(cond
((null (exwm-cm--xwin->attr window))
(when (eq parent exwm--root)
(exwm--log "(CM) ReparentNotify: Create on the root X window")
(let ((reply (xcb:+request-unchecked+reply exwm-cm--conn
(make-instance 'xcb:GetGeometry
:drawable window))))
(when reply
(with-slots (width height) reply
(setq tree0 (exwm-cm--get-subtree exwm--root))
(exwm-cm--create-attr window tree0 x y width height)
(if (cdr tree0)
(exwm-cm--push (list window) (cdr tree0))
(setcdr tree0 `((,window)))))
(exwm-cm--paint)))))
((= parent (exwm-cm--get-parent window)))
(t
(unless (exwm-cm--xwin->attr parent)
;; Only allow workspace frame here.
(setq grandparent
(slot-value (xcb:+request-unchecked+reply exwm-cm--conn
(make-instance 'xcb:QueryTree
:window parent))
'parent))
(cond
((null (exwm-cm--xwin->attr grandparent))
(exwm--log "(CM) ReparentNotify: Destroy (too deep)"))
((and (= exwm--root
(setq great-grandparent (exwm-cm--get-parent grandparent)))
(setq tree0 (exwm-cm--get-subtree grandparent))
(or (setq entity (exwm--id->buffer window))
(null (cdr tree0))))
;; Reparent a workspace frame or an X window into its
;; container.
(exwm--debug
(if entity
(exwm--log "(CM) ReparentNotify: \
Create implicit X window container")
(exwm--log "(CM) ReparentNotify: \
Create implicit workspace frame container")))
(unless entity
(setq entity 'workspace-frame))
(with-slots ((x0 x)
(y0 y))
(exwm-cm--xwin->attr grandparent)
(with-slots (x y width height)
(xcb:+request-unchecked+reply exwm-cm--conn
(make-instance 'xcb:GetGeometry
:drawable parent))
(exwm-cm--create-attr parent tree0
(+ x x0) (+ y y0) width height)))
(if (null (cdr tree0))
(setcdr tree0 `((,parent)))
;; The stacking order of the parent is unknown.
(let* ((siblings
(slot-value (xcb:+request-unchecked+reply exwm-cm--conn
(make-instance 'xcb:QueryTree
:window grandparent))
'children)))
(cl-assert (memq parent siblings))
(if (= parent (car siblings))
;; At the bottom.
(setcdr (last (cdr tree0)) `((,parent)))
;; Insert it.
(exwm-cm--push (list parent)
;; The stacking order is reversed.
(nthcdr (- (length siblings) 1
(cl-position parent siblings))
(cdr tree0)))))))
((and (= exwm--root
(exwm-cm--get-parent great-grandparent))
(setq tree0 (exwm-cm--get-subtree grandparent))
(= 1 (length (cdr tree0)))
(exwm--id->buffer (caar (cdr tree0))))
;; Reparent a floating frame into its container.
(exwm--log "(CM) ReparentNotify: Create floating frame container")
(setq entity 'floating-frame)
(with-slots ((x0 x)
(y0 y))
(exwm-cm--xwin->attr grandparent)
(with-slots (x y width height)
(xcb:+request-unchecked+reply exwm-cm--conn
(make-instance 'xcb:GetGeometry
:drawable parent))
(exwm-cm--create-attr parent tree0
(+ x x0) (+ y y0) width height)))
(nconc (cdr tree0) `((,parent))))
(t
(exwm--log "(CM) ReparentNotify: Destroy")
(exwm-cm--destroy window))))
;; Ensure there's a valid parent.
(when (exwm-cm--xwin->attr parent)
(exwm--log "(CM) ReparentNotify: Reparent")
(when (null (cdr (exwm-cm--get-subtree parent)))
;; The parent is a new container.
(exwm-cm--prepare-container parent))
(setq tree (exwm-cm--get-subtree window))
(let ((tree (exwm-cm--get-tree window)))
(if (= 1 (length (cdr tree)))
(setcdr tree nil)
(exwm-cm--assq-delete-all window (cdr tree))))
(setq tree0 (exwm-cm--get-subtree parent))
(exwm-cm--set-tree window tree0)
;; The size might have already changed (e.g. when reparenting
;; a workspace frame).
(let ((reply (xcb:+request-unchecked+reply exwm-cm--conn
(make-instance 'xcb:GetGeometry
:drawable window))))
;; The X window might have already been destroyed.
(when reply
(with-slots (width height) reply
(with-slots ((x0 x)
(y0 y))
(exwm-cm--xwin->attr parent)
(exwm-cm--update-geometry window (+ x x0) (+ y y0)
width height)))))
(when entity
;; Decide frame entity.
(when (symbolp entity)
(catch 'break
(dolist (f (if (eq entity 'workspace-frame)
exwm-workspace--list
(frame-list)))
(when (eq window (frame-parameter f 'exwm-outer-id))
(setq entity f)
(throw 'break nil))))
(when (exwm-workspace--workspace-p entity)
;; The grandparent is a new workspace container.
(exwm-cm--prepare-container grandparent)
(setf (slot-value (exwm-cm--xwin->attr grandparent) 'entity)
entity)))
(setf (slot-value (exwm-cm--xwin->attr parent) 'entity) entity)
(setf (slot-value (exwm-cm--xwin->attr window) 'entity) entity))
(if (cdr tree0)
(exwm-cm--push tree (cdr tree0))
(setcdr tree0 `(,tree)))
(exwm-cm--paint)))))))
(defun exwm-cm--add-damage (damage)
"Add region DAMAGE to `exwm-cm--damages'."
(if (not exwm-cm--damages)
(setq exwm-cm--damages damage)
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:UnionRegion
:source1 exwm-cm--damages
:source2 damage
:destination exwm-cm--damages))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:DestroyRegion
:region damage))))
(defun exwm-cm--on-DamageNotify (data _synthetic)
"Handle DamageNotify events."
(let ((obj (make-instance 'xcb:damage:Notify))
parts)
(xcb:unmarshal obj data)
(cl-assert (exwm-cm--xwin->attr (slot-value obj 'drawable)))
(with-slots (x y width height damaged damage)
(exwm-cm--xwin->attr (slot-value obj 'drawable))
(setq parts (xcb:generate-id exwm-cm--conn))
(cond
(damaged
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:CreateRegion
:region parts
:rectangles nil))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:damage:Subtract
:damage damage
:repair xcb:xfixes:Region:None
:parts parts))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:TranslateRegion
:region parts
:dx x
:dy y)))
(t
(setf damaged t)
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:CreateRegion
:region parts
:rectangles (list (make-instance 'xcb:RECTANGLE
:width width
:height height
:x x
:y y))))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:damage:Subtract
:damage damage
:repair xcb:xfixes:Region:None
:parts xcb:xfixes:Region:None))))
(exwm-cm--add-damage parts))
;; Check if there are more damages immediately followed.
(unless (/= 0 (logand #x80 (slot-value obj 'level)))
(exwm-cm--paint))))
(defun exwm-cm--on-ShapeNotify (data _synthetic)
"Handle ShapeNotify events."
(let ((obj (make-instance 'xcb:shape:Notify))
attr region1 region2)
(xcb:unmarshal obj data)
(with-slots (shape-kind affected-window shaped
extents-x extents-y extents-width extents-height)
obj
(exwm--log "(CM) ShapeNotify: #x%X" affected-window)
(when (and (or (eq shape-kind xcb:shape:SK:Clip)
(eq shape-kind xcb:shape:SK:Bounding))
(setq attr (exwm-cm--xwin->attr affected-window)))
(with-slots ((shaped* shaped)
x y width height
shape-x shape-y shape-width shape-height)
attr
(setq region1 (xcb:generate-id exwm-cm--conn)
region2 (xcb:generate-id exwm-cm--conn))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:CreateRegion
:region region1
:rectangles `(,(make-instance 'xcb:RECTANGLE
:width shape-width
:height shape-height
:x shape-x
:y shape-y))))
(if shaped
(setf shaped* t
shape-x (+ x extents-x)
shape-y (+ y extents-y)
shape-width (+ width extents-width)
shape-height (+ height extents-height))
(setf shaped* nil
shape-x x
shape-y y
shape-width width
shape-height height))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:CreateRegion
:region region2
:rectangles `(,(make-instance 'xcb:RECTANGLE
:width shape-width
:height shape-height
:x shape-x
:y shape-y))))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:UnionRegion
:source1 region1
:source2 region2
:destination region1))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:DestroyRegion
:region region2))
(setq exwm-cm--clip-changed t)
(exwm-cm--paint region1))))))
(defun exwm-cm--init ()
"Initialize EXWM compositing manager."
;; Create a new connection.
(setq exwm-cm--conn (xcb:connect))
(set-process-query-on-exit-flag (slot-value exwm-cm--conn 'process) nil)
;; Initialize ICCCM/EWMH support.
(xcb:icccm:init exwm-cm--conn)
(xcb:ewmh:init exwm-cm--conn)
;; Check for Render extension.
(let ((version (xcb:renderutil:query-version exwm-cm--conn)))
(unless (and version
(= 0 (slot-value version 'major-version))
(<= 2 (slot-value version 'minor-version)))
(error "[EXWM] The server does not support Render extension")))
;; Check for Composite extension.
(when (or (= 0
(slot-value (xcb:get-extension-data exwm-cm--conn
'xcb:composite)
'present))
(with-slots (major-version minor-version)
(xcb:+request-unchecked+reply exwm-cm--conn
(make-instance 'xcb:composite:QueryVersion
:client-major-version 0
:client-minor-version 1))
(or (/= major-version 0) (< minor-version 1))))
(error "[EXWM] The server does not support Composite extension"))
;; Check for Damage extension.
(when (or (= 0 (slot-value (xcb:get-extension-data exwm-cm--conn 'xcb:damage)
'present))
(with-slots (major-version minor-version)
(xcb:+request-unchecked+reply exwm-cm--conn
(make-instance 'xcb:damage:QueryVersion
:client-major-version 1
:client-minor-version 1))
(or (/= major-version 1) (< minor-version 1))))
(error "[EXWM] The server does not support Damage extension"))
;; Check for XFixes extension.
(when (or (= 0 (slot-value (xcb:get-extension-data exwm-cm--conn 'xcb:xfixes)
'present))
(with-slots (major-version minor-version)
(xcb:+request-unchecked+reply exwm-cm--conn
(make-instance 'xcb:xfixes:QueryVersion
:client-major-version 2
:client-minor-version 0))
(or (/= major-version 2) (/= minor-version 0))))
(error "[EXWM] The server does not support XFixes extension"))
;; Check for Shape extension.
(when (or (= 0 (slot-value (xcb:get-extension-data exwm-cm--conn 'xcb:shape)
'present))
(with-slots (major-version minor-version)
(xcb:+request-unchecked+reply exwm-cm--conn
(make-instance 'xcb:shape:QueryVersion))
(or (/= major-version 1) (< minor-version 1))))
(error "[EXWM] The server does not support Shape extension"))
;; Intern atoms.
(let ((atom-name "_NET_WM_WINDOW_OPACITY"))
(setq exwm-cm--_NET_WM_WINDOW_OPACITY
(slot-value (xcb:+request-unchecked+reply exwm-cm--conn
(make-instance 'xcb:InternAtom
:only-if-exists 0
:name-len (length atom-name)
:name atom-name))
'atom)))
(setq exwm-cm--background-atoms
(mapcar (lambda (atom-name)
(slot-value (xcb:+request-unchecked+reply exwm-cm--conn
(make-instance 'xcb:InternAtom
:only-if-exists 0
:name-len (length atom-name)
:name atom-name))
'atom))
exwm-cm--background-atom-names))
;; Register CM.
(with-slots (owner)
(xcb:+request-unchecked+reply exwm-cm--conn
(make-instance 'xcb:GetSelectionOwner
:selection xcb:Atom:_NET_WM_CM_S0))
(when (/= owner xcb:Window:None)
(error "[EXWM] Other compositing manager detected")))
(let ((id (xcb:generate-id exwm-cm--conn)))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:CreateWindow
:depth 0
:wid id
:parent exwm--root
:x 0
:y 0
:width 1
:height 1
:border-width 0
:class xcb:WindowClass:InputOnly
:visual 0
:value-mask xcb:CW:OverrideRedirect
:override-redirect 1))
;; Set _NET_WM_NAME.
(xcb:+request exwm-cm--conn
(make-instance 'xcb:ewmh:set-_NET_WM_NAME
:window id
:data "EXWM-CM"))
;; Get the selection ownership.
(xcb:+request exwm-cm--conn
(make-instance 'xcb:SetSelectionOwner
:owner id
:selection xcb:Atom:_NET_WM_CM_S0
:time xcb:Time:CurrentTime)))
;; Attach event listeners.
(xcb:+event exwm-cm--conn 'xcb:MapNotify #'exwm-cm--on-MapNotify)
(xcb:+event exwm-cm--conn 'xcb:UnmapNotify #'exwm-cm--on-UnmapNotify)
(xcb:+event exwm-cm--conn 'xcb:CreateNotify #'exwm-cm--on-CreateNotify)
(xcb:+event exwm-cm--conn 'xcb:ConfigureNotify #'exwm-cm--on-ConfigureNotify)
(xcb:+event exwm-cm--conn 'xcb:DestroyNotify #'exwm-cm--on-DestroyNotify)
(xcb:+event exwm-cm--conn 'xcb:ReparentNotify #'exwm-cm--on-ReparentNotify)
(xcb:+event exwm-cm--conn 'xcb:CirculateNotify #'exwm-cm--on-CirculateNotify)
(xcb:+event exwm-cm--conn 'xcb:Expose #'exwm-cm--on-Expose)
(xcb:+event exwm-cm--conn 'xcb:PropertyNotify #'exwm-cm--on-PropertyNotify)
(xcb:+event exwm-cm--conn 'xcb:damage:Notify #'exwm-cm--on-DamageNotify)
(xcb:+event exwm-cm--conn 'xcb:shape:Notify #'exwm-cm--on-ShapeNotify)
;; Scan the window tree.
(setq exwm-cm--hash (make-hash-table))
(exwm-cm--create-tree)
;; Set up the root X window.
(setq exwm-cm--depth
(slot-value (car (slot-value (xcb:get-setup exwm-cm--conn) 'roots))
'root-depth))
(with-slots (visual picture) (exwm-cm--xwin->attr exwm--root)
(setf picture (xcb:generate-id exwm-cm--conn))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:render:CreatePicture
:pid picture
:drawable exwm--root
:format (xcb:renderutil:find-visual-format
(xcb:renderutil:query-formats exwm-cm--conn)
visual)
:value-mask xcb:render:CP:SubwindowMode
:subwindowmode xcb:SubwindowMode:IncludeInferiors)))
(xcb:flush exwm-cm--conn)
;; Paint once.
(exwm-cm--paint t))
(defun exwm-cm--exit ()
"Exit EXWM compositing manager."
(when exwm-cm--conn
(xcb:disconnect exwm-cm--conn)
(clrhash exwm-cm--hash)
(setq exwm-cm--hash nil
exwm-cm--conn nil
exwm-cm--buffer nil
exwm-cm--clip-changed t
exwm-cm--damages nil
exwm-cm--expose-rectangles nil
exwm-cm--background nil)))
(defun exwm-cm-enable ()
"Enable compositing support for EXWM."
(add-hook 'exwm-init-hook #'exwm-cm--init t)
(add-hook 'exwm-exit-hook #'exwm-cm--exit t))
(defun exwm-cm-start ()
"Start EXWM composting manager."
(interactive)
(unless exwm-cm--conn
(exwm-cm--init)))
(defun exwm-cm-stop ()
"Stop EXWM compositing manager."
(interactive)
(exwm-cm--exit))
(defun exwm-cm-toggle ()
"Toggle the running state of EXWM compositing manager."
(interactive)
(if exwm-cm--conn
(exwm-cm-stop)
(exwm-cm-start)))
(provide 'exwm-cm)
;;; exwm-cm.el ends here
