Rework reparenting logic to make it more extensible and to make it op…

…tional

module/guile-wm/focus.scm

@@ -18,6 +18,7 @@
   #:use-module (xcb xml xproto)
   #:use-module (xcb xml)
   #:use-module (guile-wm shared)
+  #:use-module (guile-wm reparent)
   #:use-module (guile-wm log))
 
 (define-public current-focus #f)

module/guile-wm/module/simple-focus.scm

@@ -18,6 +18,7 @@
   #:use-module (xcb xml)
   #:use-module (xcb xml xproto)
   #:use-module (guile-wm shared)
+  #:use-module (guile-wm icccm)
   #:use-module (guile-wm color)
   #:use-module (guile-wm focus)
   #:use-module (guile-wm reparent))
@@ -50,7 +51,8 @@
 
 (define (simple-focus-change old new)
   (define cmap (xref (current-screen) 'default-colormap))
-  (if (and old (reparented? old)) (unfocus-window! old))
+  (if (and old (or (reparented? old) (top-level-window? old)))
+      (unfocus-window! old))
   (if (and current-focus (is-window? current-focus))
       (unfocus-window! current-focus))
   (change-window-attributes (window-parent new)

module/guile-wm/module/simple-reparent.scm

@@ -14,6 +14,7 @@
 ;;    along with Guile-WM.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (guile-wm module simple-reparent)
+  #:use-module (guile-wm draw)
   #:use-module (guile-wm focus)
   #:use-module (guile-wm shared)
   #:use-module (guile-wm redirect)
@@ -23,14 +24,13 @@
   #:use-module (xcb xml xproto))
 
 (define-public (click-to-focus button-press)
-  (and=>
-   (assv-ref (reverse-reparents) (xid->integer (xref button-press 'event)))
-   set-focus)
+  (if (xref button-press 'child)
+      (set-focus (window-child (xref button-press 'child)))
+      (set-focus (window-child (xref button-press 'event))))
   (allow-events 'replay-pointer (xref button-press 'time)))
 
 (wm-init
  (lambda () 
-   (set! reparents (make-hash-table))
-   (end-redirect!)
-   (begin-redirect! on-map on-configure on-circulate)
+   (define (make-parent) (basic-window-create 0 0 1 1 2))
+   (begin-reparent-redirect! make-parent 0 0 #t #f)
    (listen! button-press-event 'click-to-focus click-to-focus)))

module/guile-wm/module/tiling.scm

@@ -386,6 +386,7 @@
 
 (wm-init
  (lambda ()
+   (define (make-parent) (basic-window-create 0 0 1 1 2))
    (set! frame-list (detect-frames))
    (set! blank-x-window (basic-window-create 0 0 200 20 2))
    (change-window-attributes blank-x-window #:back-pixmap 'parent-relative)
@@ -409,12 +410,9 @@
    ;; that we don't miss any of them
    (solicit
     (with-replies ((attributes get-window-attributes (current-root)))
-      (define old-events (xref attributes 'your-event-mask))
-      (when (not (memq 'button-press old-events))
-        (change-window-attributes (current-root)
-          #:event-mask (cons 'button-press old-events))
-        (solicit
-         (begin-redirect! on-map on-configure on-circulate)))))))
+      (change-window-attributes (current-root)
+        #:event-mask (cons 'button-press (xref attributes 'your-event-mask)))
+      (solicit (begin-reparent-redirect! make-parent 0 0 #f #f))))))
 
 ;; This does the initial work of detecting the frames
 

module/guile-wm/module/window-cycle.scm

@@ -17,6 +17,7 @@
   #:use-module (xcb event-loop)
   #:use-module (xcb xml)
   #:use-module (xcb xml xproto)
+  #:use-module (guile-wm icccm)
   #:use-module (guile-wm reparent)
   #:use-module (guile-wm shared)
   #:use-module (guile-wm command)
@@ -27,27 +28,26 @@
     (cond
      ((null? to-test) (pick all))
      ((eq? to-test start) #f)
-     ((pred (make-xid (caar to-test) xwindow))
-      (make-xid (caar to-test) xwindow))
+     ((pred (car to-test)) (car to-test))
      (else (pick (cdr to-test))))))
 
 (define (basic-window-cycle pred)
-  (define reparent-alist (hash-map->list cons reparents))
+  (define windows (or (reparented-windows) (top-level-windows)))
   (with-replies ((focus get-input-focus))
     (define old (xref focus 'focus))
-    (if (not (null? reparent-alist))
+    (if (not (null? windows))
         (if (not (memv (xid->integer old) (xenum-values input-focus)))
-            (and=> (let find-focus ((alist reparent-alist))
+            (and=> (let find-focus ((w windows))
                      (cond
-                      ((null? alist) #f)
-                      ((= (caar alist) (xid->integer old))
-                       (pick-next-matching-window alist reparent-alist pred))
-                      (else (find-focus (cdr alist)))))
+                      ((null? w) #f)
+                      ((xid= (window-parent (car w)) old)
+                       (pick-next-matching-window w windows  pred))
+                      (else (find-focus (cdr w)))))
                    set-focus)
-            (set-focus (make-xid (caar reparent-alist) xwindow))))))
+            (set-focus (car windows))))))
 
 (define-command (window-cycle) (basic-window-cycle (lambda (win) #t)))
 
 (define-command (visible-window-cycle)
   (basic-window-cycle
-   (lambda (win) (not (hashv-ref obscured-windows (xid->integer win))))))
+   (lambda (win) (not (window-obscured? win)))))

module/guile-wm/reparent.scm

@@ -14,6 +14,8 @@
 ;;    along with Guile-WM.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (guile-wm reparent)
+  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 curried-definitions)
   #:use-module (xcb xml)
   #:use-module (xcb xml xproto)
   #:use-module (xcb event-loop)
@@ -23,11 +25,37 @@
   #:use-module (guile-wm shared)
   #:use-module (guile-wm redirect))
 
-(define-public (wm-reparent-window child parent x y)
-  "Reparent window CHILD inside of window PARENT with offset
-coordinates (X, Y), and set up event handlers for size, visibility,
-and mapping state changes. The parent window will be destroyed when
-the child window is unmapped."
+;; Call with: unmap-notify event, parent window
+(define-public unmap-notify-hook (make-wm-hook 2))
+;; Call with: child window, parent window
+(define-public after-reparent-hook (make-wm-hook 2))
+;; Call with: configure-request event
+(define-public configure-request-hook (make-wm-hook 1))
+;; Call with: circulate-request event
+(define-public circulate-request-hook (make-wm-hook 1))
+
+(define reparents (make-hash-table))
+(define obscured (make-hash-table))
+
+(define-public (reparented-windows)
+  (define reparented
+    (hash-map->list (lambda (k v) (make-xid k xwindow)) reparents))
+  (if (null? reparented) #f reparented))
+
+(define-public (window-obscured? win)
+  (hashv-ref obscured (xid->integer win)))
+
+(define-public (window-child win)
+  (define (xwcons k v) (cons (xid->integer v) (make-xid k xwindow)))
+  (or (assv-ref (hash-map->list xwcons reparents) (xid->integer win)) win))
+
+(define-public (window-parent win)
+  (or (hashv-ref reparents (xid->integer win)) win))
+
+(define-public (reparented? win)
+  (not (not (hashv-ref reparents (xid->integer win)))))
+
+(define (wm-reparent-window child parent x y)
   (hashv-set! reparents (xid->integer child) parent)
   (with-replies ((geom get-geometry child))
     (define child-border (* 2 (xref geom 'border-width)))
@@ -40,11 +68,12 @@ the child window is unmapped."
                                   structure-notify visibility-change))
     (reparent-window child parent x y)
     (change-window-attributes child #:event-mask '(structure-notify))
+    (map-window child)
     (create-listener (stop!)
       ((visibility-notify-event visibility #:window parent)
        (if (eq? (xref visibility 'state) 'fully-obscured)
-           (hashv-set! obscured-windows (xid->integer child) #t)
-           (hashv-remove! obscured-windows (xid->integer child))))
+           (hashv-set! obscured (xid->integer child) #t)
+           (hashv-remove! obscured (xid->integer child))))
       ((unmap-notify-event unmap-notify #:window child)
        (when (not (or (= (xref unmap-notify 'sequence-number) 0)
                       (xid= (xref unmap-notify 'window)
@@ -60,36 +89,26 @@ the child window is unmapped."
       ((configure-notify-event configure #:window parent)
        (configure-window child
          #:height (max (- (xref configure 'height) y) 0)
-         #:width (max (- (xref configure 'width) x) 0)))
-      ((configure-request-event configure #:window child)
-       (configure-window parent
-         #:height (max (+ (xref configure 'height) child-border y) 0)
-         #:width (max (+ (xref configure 'width) child-border x) 0))))))
-
-;; Call with: unmap-notify event, parent window
-(define-public unmap-notify-hook (make-wm-hook 2))
-;; Call with: child window, parent window
-(define-public after-reparent-hook (make-wm-hook 2))
-;; Support for basic reparenting
+         #:width (max (- (xref configure 'width) x) 0))))))
 
-(define-public (on-map map-request)
-  (define xcb-conn (current-xcb-connection))
-  (define original-parent (xref map-request 'parent))
+(define ((on-map create-parent child-x child-y) map-request)
   (define child (xref map-request 'window))
-  (if (not (hashv-ref reparents (xid->integer child)))
-      (let ((new-parent (basic-window-create 0 0 1 1 2 '())))
-        (grab new-parent)
-        (wm-reparent-window child new-parent 0 0)
-        (map-window child)
-        (cond
-         ((wm-hook-empty? after-reparent-hook)
-          (map-window child)
-          (map-window new-parent)
-          (set-window-state! child window-state-normal)
-          (set-focus child))
-         (else (run-wm-hook after-reparent-hook child new-parent))))))
-
-(define-public (on-configure configure-request)
+  (when (not (hashv-ref reparents (xid->integer child)))
+    (let ((new-parent (create-parent)))
+      (grab-button #f new-parent '(button-press) 'sync 'async
+                   (xcb-none xwindow) (xcb-none xcursor) '#{1}# '())
+      (wm-reparent-window child new-parent child-x child-y)
+      (cond
+       ((wm-hook-empty? after-reparent-hook)
+        (map-window new-parent)
+        (set-window-state! child window-state-normal)
+        (set-focus child))
+       (else (run-wm-hook after-reparent-hook child new-parent))))))
+
+(define (disallow-configure configure-request)
+  (run-wm-hook configure-request-hook configure-request))
+
+(define (allow-configure configure-request)
   (define value-mask (xref configure-request 'value-mask))
   (define win (xref configure-request 'window))
   (define (get-prop prop)
@@ -99,12 +118,32 @@ the child window is unmapped."
             ((sibling) (xid->integer val))
             ((stack-mode) (xenum-ref stack-mode val))
             (else val))))
+  (run-wm-hook configure-request-hook configure-request)
   (apply configure-window win
          (let flatten ((i (map get-prop value-mask)) (o '()))
            (if (null? i) o (flatten (cdr i) `(,(caar i) ,(cdar i) ,@o))))))
 
-(define-public (on-circulate circulate-request) #f)
+(define (disallow-circulate circulate-request)
+  (run-wm-hook circulate-request-hook circulate-request))
+
+(define (allow-circulate circulate-request)
+  (define win (xref circulate-request 'window))
+  (define dir (case (xref circulate-request 'place)
+                ((on-bottom) 'below)
+                ((on-top) 'above)))
+  (run-wm-hook circulate-request-hook circulate-request)
+  (configure-window (window-parent win) #:stack-mode dir))
+
+(define-public (begin-reparent-redirect!
+                create-parent child-x child-y
+                allow-configure? allow-circulate?)
+  (hash-clear! reparents)
+  (end-redirect!)
+  (begin-redirect!
+   (on-map create-parent child-x child-y)
+   (if allow-configure? allow-configure disallow-configure)
+   (if allow-circulate? allow-circulate disallow-circulate)))
 
-(define (grab win)
-  (grab-button #f win '(button-press) 'sync 'async (xcb-none xwindow)
-               (xcb-none xcursor) '#{1}# '()))
+(define-public (end-reparent-redirect!)
+  (end-redirect!)
+  (set! reparents #f))

module/guile-wm/shared.scm

@@ -69,7 +69,6 @@
 (define-public current-screen (make-parameter #f))
 
 (define module-init-thunks (make-hash-table))
-(define-public obscured-windows (make-hash-table))
 
 (define-syntax wm-init
   (syntax-rules ()
@@ -106,32 +105,3 @@ modules."
 (define (with-input-from-string string thunk)
   (parameterize ((current-input-port (open-input-string string)))
     (thunk)))
-
-(define-public (reverse-reparents)
-  "Return a association list for all reparented windows. The car of
-each assoc is the integer value of the xid of the parent window, and
-the cdr is the xid of the child."
-  (hash-map->list
-   (lambda (k v) (cons (xid->integer v) (make-xid k xwindow)))
-   reparents))
-
-(define-public (reparented-windows)
-  "Return a list of all reparented windows."
-  (if reparents
-      (hash-map->list (lambda (k v) (make-xid k xwindow)) reparents)
-      #f))
-
-(define-public (window-child win)
-  (or (assv-ref (reverse-reparents)
-                (xid->integer win))
-      win))
-
-(define-public (window-parent win)
-  (or (hashv-ref reparents (xid->integer win)) win))
-
-(define-public (reparented? win)
-  (let lp ((reparented (reparented-windows)))
-    (cond
-     ((null? reparented) #f)
-     ((xid= (car reparented) win) #t)
-     (else (lp (cdr reparented))))))