508 lines
17 KiB
Scheme
508 lines
17 KiB
Scheme
(define-record-type root-wm :root-wm
|
|
(make-root-wm dpy managers current-manager initial-manager in-channel
|
|
options finish cross-ref-hack
|
|
split-options switch-options move-options)
|
|
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)
|
|
(finish root-wm:finish)
|
|
(cross-ref-hack root-wm:cross-ref-hack)
|
|
(split-options root-wm:split-options)
|
|
(switch-options root-wm:switch-options)
|
|
(move-options root-wm:move-options))
|
|
|
|
(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 cross-ref-hack)
|
|
(let* ((window (default-root-window dpy))
|
|
(screen (display:default-screen dpy))
|
|
(colormap (screen:default-colormap screen))
|
|
(options (create-options dpy colormap
|
|
root-options-spec options))
|
|
(split-options (create-options dpy colormap
|
|
split-options-spec
|
|
(get-option-value options
|
|
'split-options)))
|
|
(switch-options (create-options dpy colormap
|
|
switch-options-spec
|
|
(get-option-value options
|
|
'switch-options)))
|
|
(move-options (create-options dpy colormap
|
|
move-options-spec
|
|
(get-option-value options
|
|
'move-options)))
|
|
(children (window-children dpy window))
|
|
(in-channel (make-channel))
|
|
(workspace-options (create-options dpy colormap switch-options-spec
|
|
(get-option-value options 'workspace-options)))
|
|
(initial-manager (create-workspace-manager in-channel dpy window
|
|
options
|
|
workspace-options))
|
|
(root-wm (make-root-wm dpy '() #f initial-manager in-channel options
|
|
(make-sync-point) cross-ref-hack
|
|
split-options switch-options move-options))
|
|
)
|
|
(define-cursor dpy window (get-option-value options 'default-cursor))
|
|
(set-root-wm:current-manager! root-wm initial-manager)
|
|
(add-manager! root-wm initial-manager)
|
|
|
|
(for-each (lambda (name)
|
|
(grab-shortcut dpy window (get-option-value options name)
|
|
name in-channel #t))
|
|
'(split-horizontal split-vertical
|
|
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 quit
|
|
create-workspace
|
|
save-layout
|
|
kill-client
|
|
select-outer-manager))
|
|
(for-each (lambda (binding)
|
|
(grab-shortcut dpy window (car binding) (cons 'binding binding)
|
|
in-channel #t))
|
|
(get-option-value options 'user-bindings))
|
|
|
|
(spawn* '(root-wm)
|
|
(lambda (release)
|
|
(call-with-event-channel
|
|
dpy window (event-mask substructure-redirect
|
|
substructure-notify)
|
|
(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))))
|
|
(free-options split-options #t)
|
|
(free-options switch-options #t)
|
|
(free-options move-options #t)
|
|
(free-options options #t)))
|
|
root-wm))
|
|
|
|
(define (create-workspace-manager in-channel dpy parent options switch-options)
|
|
(let ((wm (create-switch-wm in-channel dpy parent
|
|
switch-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))
|
|
(begin
|
|
(ignore-next-enter-notify!)
|
|
(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)
|
|
(let ((dpy (root-wm:dpy root-wm)))
|
|
(if (window-exists? dpy window)
|
|
(begin
|
|
;; TODO: initial-state iconic ??
|
|
(set-wm-state! (root-wm:dpy root-wm) window (wm-state normal) none)
|
|
(wm-manage-window (root-wm:current-manager root-wm) window
|
|
(window-rectangle dpy window))))))
|
|
|
|
(define (root-wm-configure-window root-wm window changes)
|
|
(let ((wm (manager-of-window root-wm window)))
|
|
(wm-configure-window (or wm (root-wm:current-manager root-wm))
|
|
window changes)))
|
|
|
|
(define (handle-xevent root-wm exit xevent)
|
|
(let ((type (any-event-type xevent))
|
|
(dpy (root-wm:dpy root-wm)))
|
|
(cond
|
|
((configure-request-event? xevent)
|
|
(root-wm-configure-window
|
|
root-wm
|
|
(configure-request-event-window xevent)
|
|
(configure-request-event-window-change-alist xevent)))
|
|
((map-request-event? xevent)
|
|
(root-wm-manage-window root-wm (map-request-event-window xevent)))
|
|
((and (unmap-event? xevent) (not (unmap-event-from-configure? xevent)))
|
|
;; syntetic unmap event for a transition to withdrawn state
|
|
(let* ((window (unmap-event-window xevent))
|
|
(wm (manager-of-window root-wm window)))
|
|
(set-wm-state! dpy window (wm-state withdrawn) none)
|
|
(if wm
|
|
(wm-unmanage-window wm window))))
|
|
((client-message-event? xevent)
|
|
(let* ((p (client-message-event-property xevent))
|
|
(type (property:type p))
|
|
(data (property:data p))
|
|
(window (client-message-event-window xevent))
|
|
(wm (manager-of-window root-wm window))
|
|
(iconic-state 3))
|
|
(if (equal? (get-atom-name dpy type) "WM_CHANGE_STATE")
|
|
(if (and (eq? (property:format p) (property-format long))
|
|
(not (null? data)) (= (car data) iconic-state))
|
|
(if wm
|
|
(wm-iconify-window wm window)
|
|
(warn "unmanaged window wants to be iconified"
|
|
window))))))
|
|
((mapping-event? xevent)
|
|
(refresh-keyboard-mapping xevent))
|
|
)))
|
|
|
|
(define (do-split root-wm orientation new-wm)
|
|
(let* ((current (root-wm:current-manager root-wm))
|
|
(parent (manager-parent root-wm current)) ;; #f if root
|
|
(dpy (wm:dpy current))
|
|
(in-channel (root-wm:in-channel root-wm))
|
|
(splitter
|
|
(create-split-wm in-channel dpy
|
|
(window-parent dpy (wm:window current))
|
|
(root-wm:split-options root-wm)
|
|
(list (cons 'orientation orientation))))
|
|
(first current)
|
|
(creator (if (eq? new-wm 'switch-wm)
|
|
create-switch-wm
|
|
create-move-wm))
|
|
(second (creator in-channel dpy (wm:window splitter)
|
|
(if (eq? new-wm 'switch-wm)
|
|
(root-wm:switch-options root-wm)
|
|
(root-wm:move-options root-wm))
|
|
'())))
|
|
;; we just replace the client:window
|
|
(if parent
|
|
(client-replace-window parent (wm:window current)
|
|
(wm:window splitter))
|
|
(map-window dpy (wm:window splitter))) ;; maybe resize ??
|
|
(wm-manage-window splitter (wm:window first))
|
|
(wm-manage-window splitter (wm:window second))
|
|
|
|
(add-manager! root-wm splitter)
|
|
(add-manager! root-wm second)))
|
|
|
|
(define (handle-message root-wm exit msg)
|
|
(case (car msg)
|
|
((split-vertical split-horizontal)
|
|
(let ((c (prompt (root-wm:dpy root-wm) #f
|
|
(get-option-value (root-wm:options root-wm)
|
|
'split-question)
|
|
'(#\s #\S #\m #\M) #f)))
|
|
(if c
|
|
(do-split root-wm
|
|
(if (eq? (car msg) 'split-vertical)
|
|
'vertical 'horizontal)
|
|
(if (or (eq? c #\s) (eq? c #\S))
|
|
'switch-wm
|
|
'move-wm)))))
|
|
|
|
((split-horizontal-with-switch-wm)
|
|
(do-split root-wm 'horizontal 'switch-wm))
|
|
((split-vertical-with-switch-wm)
|
|
(do-split root-wm 'vertical 'switch-wm))
|
|
((split-horizontal-with-move-wm)
|
|
(do-split root-wm 'horizontal 'move-wm))
|
|
((split-vertical-with-move-wm)
|
|
(do-split root-wm 'vertical 'move-wm))
|
|
|
|
((create-switch-wm create-move-wm)
|
|
(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))
|
|
(if (eq? (car msg) 'create-switch-wm)
|
|
(root-wm:switch-options root-wm)
|
|
(root-wm:move-options root-wm))
|
|
'()
|
|
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))
|
|
(if (eq? type 'switch-wm)
|
|
(root-wm:switch-options root-wm)
|
|
(root-wm:move-options root-wm))
|
|
'()
|
|
(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))))
|
|
(delete-window dpy window time))
|
|
#f)))))
|
|
(let loop ((window (get-input-focus-window dpy)))
|
|
(if (and (window-exists? dpy window)
|
|
(not (test window)))
|
|
(loop (window-parent dpy window))))))
|
|
|
|
((select-outer-manager)
|
|
(let ((time (second msg))
|
|
(current (root-wm:current-manager root-wm))
|
|
(dpy (root-wm:dpy root-wm)))
|
|
(if current
|
|
(let ((outer (manager-of-window
|
|
root-wm
|
|
(window-parent dpy (wm:window current)))))
|
|
(if outer
|
|
(set-input-focus dpy (wm:window outer)
|
|
(revert-to parent) time))))))
|
|
|
|
((manager-focused)
|
|
(let ((manager (second msg)))
|
|
;; a split-wm should never be the current manager and the
|
|
;; workspace-wm too
|
|
(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))
|
|
(pointer-x (third msg))
|
|
(pointer-y (fourth msg)))
|
|
(let ((manager (find-manager-at root-wm pointer-x pointer-y)))
|
|
(if manager
|
|
(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??
|
|
(destroy-wm wm)))
|
|
((execute)
|
|
(let* ((cm (root-wm:current-manager root-wm))
|
|
(exec (prompt (root-wm:dpy root-wm) (wm:window cm)
|
|
(get-option-value (root-wm:options root-wm)
|
|
'execute-question)
|
|
#f command-complete)))
|
|
(and exec
|
|
(not (string=? exec ""))
|
|
(let* ((p (make-string-input-port exec))
|
|
(parts (port->sexp-list p)))
|
|
(& ,parts)))))
|
|
((attach)
|
|
(let* ((cm (root-wm:current-manager root-wm))
|
|
(windows-above (window-path (wm:dpy cm) (wm:window cm)))
|
|
(all-names
|
|
(map cdr (filter
|
|
(lambda (win.name)
|
|
;; remove all that are above the current-wm,
|
|
;; all workspaces and all windows that are
|
|
;; already managed by the current-wm
|
|
(let ((win (car win.name)))
|
|
(and (not (member win windows-above))
|
|
(not (is-workspace-window? root-wm win))
|
|
(not (eq? cm
|
|
(manager-of-window root-wm win))))))
|
|
(get-all-window-names))))
|
|
(attach (prompt (root-wm:dpy root-wm) (wm:window cm)
|
|
(get-option-value (root-wm:options root-wm)
|
|
'attach-question)
|
|
all-names (finite-complete all-names)))
|
|
(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))))
|
|
|
|
((save-layout)
|
|
;; we need backup-layout from config.scm, but opening config
|
|
;; would be a cross-reference.
|
|
(((root-wm:cross-ref-hack root-wm) 'backup-layout) root-wm)
|
|
(bell (root-wm:dpy root-wm) 0))
|
|
|
|
(else
|
|
(if (and (pair? (car msg)) (eq? 'binding (car (car msg))))
|
|
(let* ((binding (cdr (car msg)))
|
|
(time (second msg))
|
|
(command (cdr binding)))
|
|
(case (car command)
|
|
((exec) (& (,@(cdr command))))
|
|
((apply) (apply (cadr command) (cddr command)))
|
|
(else (warn "unknown binding command" command))))
|
|
(warn "unhandled root message" msg)))))
|
|
|
|
(define (finite-complete strings)
|
|
(lambda (str pos)
|
|
(do-complete strings str pos)))
|
|
|
|
(define (do-complete strings str pos)
|
|
(let* ((s (substring str 0 pos))
|
|
(rest (substring str pos (string-length str)))
|
|
(candidates
|
|
(filter (lambda (str)
|
|
(and (<= (string-length s) (string-length str))
|
|
(equal? s (substring str 0 (string-length s)))))
|
|
strings))
|
|
(common (common-substring candidates)))
|
|
(cond
|
|
((null? candidates) (cons str pos))
|
|
((null? (cdr candidates))
|
|
(cons (string-append (car candidates) rest)
|
|
(string-length (car candidates))))
|
|
((not (or (equal? common "") (equal? common s)))
|
|
(cons (string-append common rest)
|
|
(string-length common)))
|
|
(else candidates))))
|
|
|
|
(define (common-substring strings)
|
|
(cond
|
|
((null? strings) "")
|
|
((null? (cdr strings)) (car strings))
|
|
(else (let ((s (car strings))
|
|
(rec (common-substring (cdr strings))))
|
|
(letrec ((loop (lambda (i)
|
|
(if (and (< i (string-length s))
|
|
(< i (string-length rec))
|
|
(eq? (string-ref s i) (string-ref rec i)))
|
|
(loop (+ i 1))
|
|
(substring s 0 i)))))
|
|
(loop 0))))))
|
|
|
|
(define (command-complete str pos)
|
|
(do-complete (executables-in-path/prefix (substring str 0 pos)) str pos))
|
|
|
|
;; *** observing managers ********************************************
|
|
|
|
(define (add-manager! root-wm manager)
|
|
(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)
|
|
(event-mask structure-notify
|
|
focus-change)
|
|
(lambda (event-channel)
|
|
(release)
|
|
(let loop ()
|
|
(let ((e (receive event-channel)))
|
|
(cond
|
|
((destroy-window-event? e) 'done)
|
|
((eq? (event-type focus-in) (any-event-type e))
|
|
(let ((mode (focus-change-event-mode e))
|
|
(detail (focus-change-event-detail e)))
|
|
(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)))))))
|
|
(remove-manager! root-wm manager))))
|
|
|
|
(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))))
|
|
(if (or (not parent-window) (zero? parent-window))
|
|
#f
|
|
(let ((l (filter (lambda (m)
|
|
(equal? (wm:window m) parent-window))
|
|
(root-wm-managers root-wm))))
|
|
(if (null? l)
|
|
(loop (window-parent (root-wm:dpy root-wm)
|
|
parent-window))
|
|
(car l))))))
|
|
|
|
(define (find-manager-at root-wm x y)
|
|
;; returns the upper-most manager at root-window's coords x y
|
|
(letrec ((dpy (root-wm:dpy root-wm))
|
|
(root-window (default-root-window dpy))
|
|
(child-at (lambda (window x y)
|
|
(let ((res (translate-coordinates dpy root-window window
|
|
x y)))
|
|
(and res (not (zero? (third res))) (third res)))))
|
|
(window-at (lambda (window x y)
|
|
(let ((child (child-at window x y)))
|
|
(if child
|
|
(window-at child x y)
|
|
window)))))
|
|
(manager-of-window root-wm (window-at root-window x y))))
|
|
|
|
(define (manager-of-window root-wm window)
|
|
(or (get-manager-by-window root-wm window)
|
|
(let ((w (window-parent (root-wm:dpy root-wm) window)))
|
|
(and w (not (zero? w)) (manager-of-window root-wm w)))))
|
|
|
|
(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 (is-workspace-window? root-wm window)
|
|
(let ((p (window-parent (root-wm:dpy root-wm) window)))
|
|
(and p (not (zero? p))
|
|
(let ((wm (manager-of-window root-wm p)))
|
|
(and wm (eq? wm (root-wm:initial-manager root-wm)))))))
|
|
|
|
(define (create-new-manager root-wm type options special-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 special-options)))
|
|
(wm-manage-window parent (wm:window wm))
|
|
(add-manager! root-wm wm)
|
|
(set-root-wm:current-manager! root-wm wm)
|
|
wm))
|