From 3ecd9478ee5c317b7ef28a16b5ba57c280b6bb76 Mon Sep 17 00:00:00 2001 From: frese Date: Fri, 11 Apr 2003 01:31:44 +0000 Subject: [PATCH] added kill-client shortcut added workspace-manager added default options for new split, switch and move managers added quit shortcut added special message for automated split destruction fixed current-manager detection --- src/root-manager.scm | 259 ++++++++++++++++++++++++++++++++++--------- 1 file changed, 204 insertions(+), 55 deletions(-) diff --git a/src/root-manager.scm b/src/root-manager.scm index ba31766..407aeab 100644 --- a/src/root-manager.scm +++ b/src/root-manager.scm @@ -1,4 +1,6 @@ (define-options-spec root-options-spec + (quit keys "F12") + (quit-question string "Really quit orion?") (split-horizontal keys "M-s h") (split-vertical keys "M-s v") (split-horizontal-with-switch-wm keys "M-s s h") @@ -7,21 +9,37 @@ (split-vertical-with-move-wm keys "M-s m v") (create-switch-wm keys "M-k s") (create-move-wm keys "M-k m") - (split-question string "What kind of manager do want in the second frame?\n(S)witch or (M)ove windowmanager:") + (split-question string "What kind of manager do you want in the second frame?\n(S)witch or (M)ove windowmanager:") (execute keys "F3") (execute-question string "Execute:") (attach keys "M-a") (attach-question string "Attach:") + (default-split-options sexp '()) + (default-switch-options sexp '()) + (default-move-options sexp '()) + (workspace-options sexp '()) + (nth-workspace keys-list '("M-1" "M-2" "M-3" "M-4")) + (create-workspace keys "F9") + (create-workspace-question string "What kind of manager do you want in the new workspace?\n(S)witch or (M)ove windowmanager:") + (kill-client keys "M-c") ) (define-record-type root-wm :root-wm - (make-root-wm dpy managers current-manager in-channel options) + (make-root-wm dpy managers current-manager initial-manager in-channel + options finish) root-wm? (dpy root-wm:dpy) (managers root-wm:managers set-root-wm:managers!) (current-manager root-wm:current-manager set-root-wm:current-manager!) + (initial-manager root-wm:initial-manager) (in-channel root-wm:in-channel) - (options root-wm:options)) + (options root-wm:options) + (finish root-wm:finish)) + +(define (root-wm-managers root-wm) + (filter (lambda (wm) + (window-exists? (root-wm:dpy root-wm) (wm:window wm))) + (root-wm:managers root-wm))) (define (create-root-wm dpy options) (let* ((window (default-root-window dpy)) @@ -30,18 +48,16 @@ root-options-spec options)) (children (window-children dpy window)) (in-channel (make-channel)) - (root-wm (make-root-wm dpy '() #f in-channel options)) - (initial-manager (create-move-wm in-channel dpy window '()))) + ;; TODO: workspace-options... + (initial-manager (create-workspace-manager in-channel dpy window + options)) + (root-wm (make-root-wm dpy '() #f initial-manager in-channel options + (make-sync-point))) + ) (mdisplay "creating root-wm\n") (set-root-wm:current-manager! root-wm initial-manager) (add-manager! root-wm initial-manager) - (map-window dpy (wm:window initial-manager)) - - (for-each (lambda (window) - (wm-manage-window initial-manager window)) - children) - (for-each (lambda (name) (grab-shortcut dpy window (get-option-value options name) name in-channel #t)) @@ -49,22 +65,61 @@ split-horizontal-with-switch-wm split-vertical-with-switch-wm split-horizontal-with-move-wm split-vertical-with-move-wm create-switch-wm create-move-wm - execute attach)) + execute attach quit + create-workspace + kill-client)) - (call-with-event-channel - dpy window (event-mask substructure-redirect) - (lambda (event-channel) - (call-with-current-continuation - (lambda (exit) - (let loop () - (select* - (wrap (receive-rv event-channel) - (lambda (xevent) - (handle-xevent root-wm exit xevent))) - (wrap (receive-rv in-channel) - (lambda (msg) - (handle-message root-wm exit msg)))) - (loop)))))))) + (spawn* '(root-wm) + (lambda (release) + (call-with-event-channel + dpy window (event-mask substructure-redirect) + (lambda (event-channel) + (release) + (call-with-current-continuation + (lambda (exit) + (let loop () + (select* + (wrap (receive-rv event-channel) + (lambda (xevent) + (handle-xevent root-wm exit xevent))) + (wrap (receive-rv in-channel) + (lambda (msg) + (handle-message root-wm exit msg)))) + (loop)))) + (sync-point-release (root-wm:finish root-wm)))))) + root-wm)) + +(define (create-workspace-manager in-channel dpy parent options) + (let ((wm (create-switch-wm in-channel dpy parent + (cons (cons 'titlebar-height 0) + (get-option-value options + 'workspace-options)))) + (select-keys (get-option-value options 'nth-workspace)) + (channel (make-channel))) + (for-each (lambda (i key) + (grab-shortcut dpy (wm:window wm) key i channel #t)) + (iota (length select-keys)) + select-keys) + (spawn* + (list 'workspace-manager wm) + (lambda (release) + (release) + (let loop () + (let ((msg (receive channel))) + (if (number? (car msg)) + (let ((i (car msg)) + (cs (wm-clients wm))) + (if (< i (length cs)) + (wm-select-client wm (list-ref cs i) + (second msg))))) + (loop))))) + wm)) + +(define (wait-for-root-wm root-wm) + (sync-point-wait (root-wm:finish root-wm))) + +(define (root-wm-manage-window root-wm window) + (wm-manage-window (root-wm:current-manager root-wm) window)) (define (handle-xevent root-wm exit xevent) (let ((type (any-event-type xevent)) @@ -84,18 +139,23 @@ (let* ((current (root-wm:current-manager root-wm)) (parent (manager-parent root-wm current)) ;; #f if root (dpy (wm:dpy current)) + (options (root-wm:options root-wm)) (in-channel (root-wm:in-channel root-wm)) - (splitter (create-split-wm in-channel dpy - (window-parent dpy (wm:window current)) - ;; TODO other options - (list (cons 'orientation orientation)))) + (splitter + (create-split-wm in-channel dpy + (window-parent dpy (wm:window current)) + (cons (cons 'orientation orientation) + (get-option-value options + 'default-split-options)))) (first current) (creator (if (eq? new-wm 'switch-wm) create-switch-wm create-move-wm)) (second (creator in-channel dpy (wm:window splitter) - ;; TODO options - '()))) + (get-option-value options + (if (eq? new-wm 'switch-wm) + 'default-switch-options + 'default-move-options))))) ;; we just replace the client:window (if parent (client-replace-window parent (wm:window current) @@ -132,22 +192,63 @@ (do-split root-wm 'vertical 'move-wm)) ((create-switch-wm create-move-wm) - (let* ((current (root-wm:current-manager root-wm)) - (create (if (eq? (car msg) 'create-switch-wm) - create-switch-wm - create-move-wm)) - (dpy (root-wm:dpy root-wm)) - (in-channel (root-wm:in-channel root-wm)) - (new (create in-channel dpy (wm:window current) - '())) ;; TODO: options - ) - (add-manager! root-wm new) - (wm-manage-window current (wm:window new)))) + (let ((current (root-wm:current-manager root-wm))) + (create-new-manager root-wm + (if (eq? (car msg) 'create-switch-wm) + (manager-type switch) + (manager-type move)) + (get-option-value (root-wm:options root-wm) + (if (eq? (car msg) + 'create-switch-wm) + 'default-switch-options + 'default-move-options)) + current))) + + ((create-workspace) + (let* ((c (prompt (root-wm:dpy root-wm) #f + (get-option-value (root-wm:options root-wm) + 'create-workspace-question) + '(#\s #\S #\m #\M) #f)) + (type (if (or (eq? c #\s) (eq? c #\S)) + 'switch-wm 'move-wm))) + (if c + (create-new-manager root-wm + (if (eq? type 'switch-wm) + (manager-type switch) + (manager-type move)) + (get-option-value (root-wm:options root-wm) + (if (eq? type 'switch-wm) + 'default-switch-options + 'default-move-options)) + (root-wm:initial-manager root-wm))))) + + ((kill-client) + (let* ((dpy (root-wm:dpy root-wm)) + (test (lambda (window) + (let* ((managers (root-wm-managers root-wm)) + (l (filter (lambda (x) x) + (map (lambda (wm) + (client-of-window wm window)) + managers))) + (time (second msg))) + (if (not (null? l)) + (let ((window (client:window (car l)))) + (mdisplay "kill-client: " window "\n") + (delete-window dpy window time) + #t) + #f))))) + (let loop ((window (get-input-focus-window dpy))) + (if (and (window-exists? dpy window) + (not (test window))) + (loop (window-parent dpy window)))))) ((manager-focused) (let ((manager (second msg))) - ;; a split-wm should never be the current manager - (if (not (eq? (manager-type split) (wm:type manager))) + ;; a split-wm should never be the current manager and the + ;; workspace-wm too + (mdisplay "new current manager: " manager "\n") + (if (and (not (eq? (manager-type split) (wm:type manager))) + (not (eq? manager (root-wm:initial-manager root-wm)))) (set-root-wm:current-manager! root-wm manager)))) ((root-drop) (let ((window (second msg)) @@ -158,6 +259,15 @@ (wm-manage-window manager window) (mdisplay "did not find a manager at " pointer-x ":" pointer-y "\n"))))) + ((destroy-wm) ;; specially sent if second split-client terminates + (let* ((wm (second msg)) + (replacement? (if (> (length msg) 2) (third msg) #f)) + (parent (manager-parent root-wm wm))) + (if replacement? + (client-replace-window parent (wm:window wm) replacement?)) + ;; sync?? + (mdisplay "TEST\n") + (destroy-wm wm))) ((execute) (let* ((cm (root-wm:current-manager root-wm)) (exec (prompt (root-wm:dpy root-wm) (wm:window cm) @@ -182,7 +292,14 @@ (window (find-window-by-name attach))) (if window (wm-manage-window cm window)))) - + + ((quit) + (let ((a (prompt (root-wm:dpy root-wm) #f + (get-option-value (root-wm:options root-wm) + 'quit-question) + '(#\y #\Y #\n #\N) #f))) + (if (memq a '(#\y #\Y)) + (exit #t)))) (else (mdisplay "unknown root message: " msg "\n")))) (define (exec-complete str pos) @@ -228,6 +345,7 @@ (set-root-wm:managers! root-wm (cons manager (root-wm:managers root-wm))) (spawn* + (list 'root-wm-observer manager) (lambda (release) (call-with-event-channel (root-wm:dpy root-wm) (wm:window manager) @@ -238,17 +356,29 @@ (let loop () (let ((e (receive event-channel))) (cond - ((destroy-window-event? e) #t) - ((focus-change-event? e) - ;; look at mode/detail ?? - (if (window-contains-focus? (root-wm:dpy root-wm) - (wm:window manager)) - (send (root-wm:in-channel root-wm) - (list 'manager-focused manager))) + ((destroy-window-event? e) + (remove-manager! root-wm manager)) + ((eq? (event-type focus-in) (any-event-type e)) + (let ((mode (focus-change-event-mode e)) + (detail (focus-change-event-detail e))) +; (mdisplay "manager focus-event: " manager " " +; (focus-change-event-type e) " " detail "\n") + (if (and (eq? mode (notify-mode normal)) + (or (eq? detail (notify-detail inferior)) + (eq? detail (notify-detail ancestor)) + (eq? detail (notify-detail nonlinear)))) + (send (root-wm:in-channel root-wm) + (list 'manager-focused manager)))) (loop)) (else (loop)))) (loop))))))) +(define (remove-manager! root-wm manager) + (set-root-wm:managers! root-wm + (filter (lambda (m) + (not (eq? m manager))) + (root-wm:managers root-wm)))) + (define (manager-parent root-wm manager) (let loop ((parent-window (window-parent (root-wm:dpy root-wm) (wm:window manager)))) @@ -256,7 +386,7 @@ #f (let ((l (filter (lambda (m) (equal? (wm:window m) parent-window)) - (root-wm:managers root-wm)))) + (root-wm-managers root-wm)))) (if (null? l) (loop (window-parent (root-wm:dpy root-wm) parent-window)) @@ -269,7 +399,7 @@ (filter (lambda (wm) (point-in-rectangle? (root-rectangle dpy (wm:window wm)) x y)) - (root-wm:managers root-wm)))) + (root-wm-managers root-wm)))) (letrec ((loop (lambda (wm level rest) (if (null? rest) wm @@ -280,3 +410,22 @@ (loop next next-level (cdr rest)) (loop wm level (cdr rest)))))))) (loop #f -1 candidates)))) + +(define (get-manager-by-window root-wm window) + (let ((l (filter (lambda (wm) + (equal? (wm:window wm) window)) + (root-wm-managers root-wm)))) + (and (not (null? l)) + (car l)))) + +(define (create-new-manager root-wm type options parent) + (let* ((creator (cond + ((eq? type (manager-type split)) create-split-wm) + ((eq? type (manager-type switch)) create-switch-wm) + ((eq? type (manager-type move)) create-move-wm))) + (wm (creator (root-wm:in-channel root-wm) (root-wm:dpy root-wm) + (wm:window parent) options))) + (wm-manage-window parent (wm:window wm)) + (add-manager! root-wm wm) + (set-root-wm:current-manager! root-wm wm) + wm))