591 lines
20 KiB
Scheme
591 lines
20 KiB
Scheme
(define-record-type wm :wm
|
|
(make-wm type in-channel out-channel internal-out-channel
|
|
dpy window colormap options special-options
|
|
clients clients-stacking current-client)
|
|
wm?
|
|
(type wm:type)
|
|
(in-channel wm:in-channel)
|
|
(out-channel wm:out-channel)
|
|
(internal-out-channel wm:internal-out-channel)
|
|
(dpy wm:dpy)
|
|
(window wm:window)
|
|
(colormap wm:colormap)
|
|
(options wm:options)
|
|
(special-options wm:special-options)
|
|
(clients wm:clients set-wm:clients!)
|
|
(clients-stacking wm:clients-stacking set-wm:clients-stacking!)
|
|
(current-client wm:current-client set-wm:current-client!))
|
|
|
|
(define-record-discloser :wm
|
|
(lambda (wm)
|
|
`(Wm ,(manager-type-name (wm:type wm)) ,(wm:window wm))))
|
|
|
|
(define wm-clients wm:clients)
|
|
(define wm-clients-stacking wm:clients-stacking)
|
|
(define wm-current-client wm:current-client)
|
|
|
|
(define-enumerated-type manager-type :manager-type
|
|
manager-type? manager-types manager-type-name manager-type-index
|
|
(split switch move))
|
|
|
|
(define (manager-name type)
|
|
(cond
|
|
((eq? type (manager-type split)) "split-wm")
|
|
((eq? type (manager-type switch)) "switch-wm")
|
|
((eq? type (manager-type move)) "move-wm")))
|
|
|
|
(define (create-wm dpy parent options special-options children
|
|
type out-channel fun)
|
|
(let* ((wa (get-window-attributes dpy parent))
|
|
(main-window
|
|
(create-simple-window dpy parent 0 0 (window-attribute:width wa)
|
|
(window-attribute:height wa)
|
|
0 (white-pixel dpy) (black-pixel dpy)))
|
|
(colormap (create-colormap dpy main-window
|
|
(window-attribute:visual wa)
|
|
(colormap-alloc none)))
|
|
(in-channel (make-channel))
|
|
(internal-out-channel (make-channel))
|
|
(wm (make-wm type in-channel out-channel internal-out-channel
|
|
dpy main-window colormap
|
|
options special-options '() '() #f)))
|
|
|
|
(set-window-background-pixmap! dpy main-window parent-relative)
|
|
;; set properties ************************************************
|
|
(set-wm-name! dpy main-window
|
|
(string-list->property (list (manager-name type))))
|
|
;; icon ??
|
|
;; size-hints ??
|
|
(set-wm-hints! dpy main-window
|
|
(make-wm-hint-alist (input? #t)))
|
|
;; class-hint ??
|
|
(set-wm-protocols! dpy main-window
|
|
(list (intern-atom dpy "WM_TAKE_FOCUS" #f)
|
|
(intern-atom dpy "WM_DELETE_WINDOW" #f)))
|
|
(set-wm-hints! dpy main-window
|
|
(make-wm-hint-alist
|
|
(input? #t)))
|
|
|
|
;; TODO: Colormaps
|
|
|
|
;; spawn handlers ************************************************
|
|
(spawn* (list 'manager wm)
|
|
(lambda (release)
|
|
(call-with-event-channel
|
|
(wm:dpy wm) (wm:window wm)
|
|
(event-mask structure-notify
|
|
enter-window
|
|
focus-change
|
|
button-press
|
|
exposure)
|
|
(lambda (event-channel)
|
|
(call-with-current-continuation
|
|
(lambda (exit)
|
|
(release)
|
|
(send internal-out-channel '(fit-windows)) ;; ??
|
|
(let loop ()
|
|
(select*
|
|
(wrap (receive-rv event-channel)
|
|
(lambda (xevent)
|
|
(handle-xevent wm exit xevent)))
|
|
(wrap (receive-rv (wm:in-channel wm))
|
|
(lambda (msg)
|
|
(handle-external-message wm exit msg))))
|
|
(loop))))))
|
|
(free-colormap dpy colormap)
|
|
))
|
|
|
|
(for-each (lambda (window)
|
|
(wm-manage-window wm window))
|
|
children)
|
|
(fun wm internal-out-channel)))
|
|
|
|
(define (handle-xevent wm exit xevent)
|
|
(let ((main-window (wm:window wm))
|
|
(dpy (wm:dpy wm))
|
|
(internal-out-channel (wm:internal-out-channel wm))
|
|
(type (any-event-type xevent)))
|
|
(cond
|
|
((expose-event? xevent)
|
|
(if (= 0 (expose-event-count xevent))
|
|
(send internal-out-channel '(draw-main-window))))
|
|
|
|
((configure-event? xevent)
|
|
(send internal-out-channel '(fit-windows)))
|
|
|
|
((focus-change-event? xevent)
|
|
(if (window-exists? dpy (wm:window wm))
|
|
(let ((mode (focus-change-event-mode xevent))
|
|
(detail (focus-change-event-detail xevent)))
|
|
(if (and (eq? mode (notify-mode normal))
|
|
(memq detail (list (notify-detail nonlinear)
|
|
(notify-detail nonlinear-virtual)
|
|
(notify-detail virtual)
|
|
(notify-detail ancestor))))
|
|
(let ((focused? (eq? (event-type focus-in)
|
|
(focus-change-event-type xevent))))
|
|
(send internal-out-channel
|
|
(list 'update-manager-state focused?)))))))
|
|
|
|
;; the manager got the focus (as a client)
|
|
((client-message-event? xevent)
|
|
(let* ((p (client-message-event-property xevent))
|
|
(type (property:type p)))
|
|
(if (equal? type (intern-atom dpy "WM_PROTOCOLS" #f))
|
|
(let ((name (car (property:data p)))
|
|
(time (cadr (property:data p))))
|
|
(if (equal? name (intern-atom dpy "WM_TAKE_FOCUS" #f))
|
|
(begin
|
|
(if (window-viewable? dpy main-window)
|
|
(set-input-focus dpy main-window (revert-to parent)
|
|
current-time))
|
|
(send internal-out-channel
|
|
(list 'manager-focused current-time))))
|
|
(if (equal? name (intern-atom dpy "WM_DELETE_WINDOW" #f))
|
|
(if (null? (wm:clients wm))
|
|
;; (destroy-wm wm) would dead-lock
|
|
(handle-external-message wm exit '(destroy-manager))
|
|
(bell dpy 100)))
|
|
))))
|
|
|
|
((button-event? xevent)
|
|
(if (eq? (event-type button-press) (button-event-type xevent))
|
|
(take-focus dpy main-window (button-event-time xevent))))
|
|
|
|
((destroy-window-event? xevent)
|
|
(exit 'destroy))
|
|
)))
|
|
|
|
(define (handle-external-message wm exit msg)
|
|
(let ((internal-out-channel (wm:internal-out-channel wm))
|
|
(dpy (wm:dpy wm)))
|
|
(case (car msg)
|
|
((wait)
|
|
(let ((sp (second msg))
|
|
(message (third msg)))
|
|
(handle-external-message wm exit message)
|
|
(sync-point-release sp)))
|
|
|
|
((manage-window)
|
|
(let ((window (second msg))
|
|
(maybe-rect (third msg)))
|
|
(let ((client (create-client wm window)))
|
|
(set-wm:clients! wm (append (wm:clients wm) (list client)))
|
|
(set-wm:clients-stacking! wm (cons client (wm:clients-stacking wm)))
|
|
(send-message+wait internal-out-channel
|
|
(list 'init-client client maybe-rect))
|
|
(if (not (wm:current-client wm))
|
|
(wm-select-client wm client current-time)))))
|
|
|
|
((configure-window)
|
|
(let ((window (second msg))
|
|
(changes (third msg)))
|
|
(send-message+wait internal-out-channel
|
|
(list 'configure-window window changes))))
|
|
|
|
((unmanage-window)
|
|
(let* ((window (second msg))
|
|
(client (find (lambda (c)
|
|
(eq? window (client:window c)))
|
|
(wm:clients wm))))
|
|
(if (and client window (window-exists? dpy window))
|
|
(reparent-to-root dpy window))))
|
|
|
|
((iconify-window normalize-window maximize-window)
|
|
(let* ((window (second msg))
|
|
(client (find (lambda (c)
|
|
(eq? window (client:window c)))
|
|
(wm:clients wm))))
|
|
(if client
|
|
(send internal-out-channel
|
|
(list (case (first msg)
|
|
((iconify-window) 'iconify-client)
|
|
((normalize-window) 'normalize-client)
|
|
((maximize-window) 'maximize-client))
|
|
client)))))
|
|
|
|
((destroy-manager)
|
|
(send-message+wait internal-out-channel '(deinit-manager))
|
|
(if (window-exists? dpy (wm:window wm))
|
|
(destroy-window dpy (wm:window wm))))
|
|
|
|
((deinit-client)
|
|
(let ((client (second msg)))
|
|
(set-wm:clients! wm (filter (lambda (c) (not (eq? c client)))
|
|
(wm:clients wm)))
|
|
(set-wm:clients-stacking! wm (filter (lambda (c) (not (eq? c client)))
|
|
(wm:clients-stacking wm)))
|
|
(send-message+wait (wm:internal-out-channel wm)
|
|
(list 'deinit-client client))
|
|
(if (eq? client (wm:current-client wm))
|
|
(set-wm:current-client! wm #f))
|
|
(destroy-window dpy (client:client-window client))))
|
|
|
|
((select-client)
|
|
(let* ((client (second msg))
|
|
(time (third msg))
|
|
(all (cons client (transients-for-client wm client)))
|
|
(top (last all)))
|
|
(if (not (eq? top (wm:current-client wm)))
|
|
(begin
|
|
(send-message+wait (wm:internal-out-channel wm)
|
|
(list 'show-clients all))
|
|
(set-wm:current-client! wm top)))
|
|
(set-wm:clients-stacking! wm
|
|
(append (reverse all)
|
|
(filter (lambda (c) (not (memq c all)))
|
|
(wm:clients-stacking wm))))
|
|
(if (window-exists? dpy (client:window top))
|
|
(take-focus dpy (client:window top) time))))
|
|
|
|
(else (warn "unhandled manager message" wm msg)))))
|
|
|
|
(define (wm-deinit-client wm client)
|
|
(send (wm:in-channel wm) (list 'deinit-client client)))
|
|
|
|
;; *** external messages *********************************************
|
|
|
|
(define (wm-manage-window wm window . rect)
|
|
(let ((maybe-rect (if (null? rect)
|
|
#f
|
|
(car rect))))
|
|
(send-message+wait (wm:in-channel wm)
|
|
(list 'manage-window window maybe-rect))))
|
|
|
|
(define (wm-configure-window wm window changes)
|
|
(send-message+wait (wm:in-channel wm)
|
|
(list 'configure-window window changes)))
|
|
|
|
(define (wm-unmanage-window wm window)
|
|
(send (wm:in-channel wm) (list 'unmanage-window window)))
|
|
|
|
(define (wm-iconify-window wm window)
|
|
(send (wm:in-channel wm) (list 'iconify-window window)))
|
|
|
|
(define (wm-normalize-window wm window)
|
|
(send (wm:in-channel wm) (list 'normalize-window window)))
|
|
|
|
(define (wm-maximize-window wm window)
|
|
(send (wm:in-channel wm) (list 'maximize-window window)))
|
|
|
|
(define (wm-select-client wm client time)
|
|
(spawn (lambda ()
|
|
(send (wm:in-channel wm) (list 'select-client client time)))))
|
|
|
|
(define (destroy-wm wm)
|
|
(send-message+wait (wm:in-channel wm) '(destroy-manager)))
|
|
|
|
(define (send-root-drop wm window x y)
|
|
(send (wm:out-channel wm) (list 'root-drop window x y)))
|
|
|
|
;; *** client ********************************************************
|
|
|
|
(define-record-type client :client
|
|
(make-client window client-window in-channel data focused? wm-state)
|
|
client?
|
|
(window client:window set-client:window!)
|
|
(client-window client:client-window)
|
|
(in-channel client:in-channel)
|
|
(data client:data set-client:data!)
|
|
(focused? client:focused? set-client:focused?!)
|
|
(wm-state client:wm-state set-client:wm-state!))
|
|
|
|
(define (set-client-focused?! wm client focused?)
|
|
(let ((prev (client:focused? client)))
|
|
(if (not (eq? prev focused?))
|
|
(begin
|
|
(set-client:focused?! client focused?)
|
|
(send (wm:internal-out-channel wm)
|
|
(list 'update-client-state client focused?))))))
|
|
|
|
(define-record-discloser :client
|
|
(lambda (c)
|
|
`(Client ,(client:window c) in ,(client:client-window c))))
|
|
|
|
(define (create-client wm window)
|
|
(let* ((dpy (wm:dpy wm))
|
|
(client-window (create-simple-window dpy (wm:window wm)
|
|
0 0
|
|
(window-width dpy window)
|
|
(window-height dpy window)
|
|
0
|
|
(white-pixel dpy)
|
|
(black-pixel dpy)))
|
|
(in-channel (make-channel))
|
|
(wm-state (let ((s.i (get-wm-state dpy window)))
|
|
;; TODO initial-state? see root-manager
|
|
(if s.i
|
|
(car s.i)
|
|
(wm-state withdrawn))))
|
|
(client (make-client window client-window in-channel #f #f
|
|
wm-state)))
|
|
;; transparent by default.
|
|
(set-window-background-pixmap! dpy client-window parent-relative)
|
|
|
|
(if (memq 'click (get-option-value (wm:options wm) 'focus-policy))
|
|
;; Note: won't work recursively (manager in manager)
|
|
(grab-button dpy (button button1) (state-set) client-window
|
|
#t (event-mask button-press button-release)
|
|
(grab-mode sync) (grab-mode async) none none))
|
|
(reparent-window dpy window client-window 0 0)
|
|
(create-client-handler wm client)
|
|
client))
|
|
|
|
(define (create-client-handler wm client)
|
|
(spawn*
|
|
(list 'client-handler wm client)
|
|
(lambda (release)
|
|
(call-with-event-channel
|
|
(wm:dpy wm) (client:client-window client)
|
|
(event-mask exposure
|
|
enter-window
|
|
button-press
|
|
structure-notify
|
|
substructure-redirect)
|
|
(lambda (client-window-channel)
|
|
(call-with-event-channel
|
|
(wm:dpy wm) (client:window client)
|
|
(event-mask property-change
|
|
focus-change
|
|
structure-notify)
|
|
(lambda (client-channel)
|
|
(call-with-current-continuation
|
|
(lambda (exit)
|
|
(release)
|
|
(let loop ()
|
|
(select*
|
|
(wrap (receive-rv (client:in-channel client))
|
|
(lambda (msg)
|
|
(case (car msg)
|
|
((restart-handler)
|
|
(create-client-handler wm client)
|
|
(sync-point-release (second msg))
|
|
(exit 'restart))
|
|
(else (warn "unhandled client message" wm
|
|
client msg)))))
|
|
(wrap (receive-rv client-window-channel)
|
|
(lambda (xevent)
|
|
(handle-client-window-xevent wm exit client xevent)))
|
|
(wrap (receive-rv client-channel)
|
|
(lambda (xevent)
|
|
(handle-client-xevent wm exit client xevent))))
|
|
(loop)))))))))))
|
|
|
|
(define (client-of-window wm window)
|
|
(find (lambda (client)
|
|
(equal? window (client:window client)))
|
|
(wm-clients wm)))
|
|
|
|
(define (client-replace-window wm old-window new-window)
|
|
(let ((client (client-of-window wm old-window))
|
|
(internal-out-channel (wm:internal-out-channel wm))
|
|
(dpy (wm:dpy wm)))
|
|
(if client
|
|
(begin
|
|
(set-client:window! client new-window)
|
|
(if (not (equal? (window-parent dpy new-window)
|
|
(client:client-window client)))
|
|
(reparent-window dpy new-window (client:client-window client)
|
|
0 0))
|
|
(let ((sp (make-sync-point)))
|
|
(send (client:in-channel client)
|
|
(list 'restart-handler sp))
|
|
(sync-point-wait sp))
|
|
(send-message+wait internal-out-channel (list 'fit-client client))
|
|
(send internal-out-channel
|
|
(list 'update-client-name client (client-name dpy client)))
|
|
(map-window (wm:dpy wm) new-window)
|
|
(set-input-focus dpy new-window (revert-to parent) current-time))
|
|
#f)))
|
|
|
|
(define (handle-client-window-xevent wm exit client xevent)
|
|
(let ((type (any-event-type xevent))
|
|
(internal-out-channel (wm:internal-out-channel wm))
|
|
(dpy (wm:dpy wm)))
|
|
(cond
|
|
((expose-event? xevent)
|
|
(if (= 0 (expose-event-count xevent))
|
|
(send internal-out-channel
|
|
(list 'draw-client-window client))))
|
|
((configure-event? xevent)
|
|
(if (window-exists? dpy (client:window client))
|
|
(send internal-out-channel (list 'fit-client client))))
|
|
((configure-request-event? xevent)
|
|
(let ((changes (configure-request-event-window-change-alist xevent)))
|
|
(if (or (assq (window-change width) changes)
|
|
(assq (window-change height) changes)
|
|
(assq (window-change border-width) changes))
|
|
(begin
|
|
(configure-window dpy (client:window client)
|
|
(filter (lambda (a.v)
|
|
(memq (car a.v)
|
|
(list (window-change width)
|
|
(window-change height))))
|
|
changes))
|
|
(send internal-out-channel (list 'fit-client-window client)))
|
|
(send-configuration dpy (client:window client)))))
|
|
;; ((circulate-event? xevent)
|
|
;; (send internal-out-channel (list 'update-client-state client)))
|
|
((eq? (event-type enter-notify) type)
|
|
(let ((lazy-wm-select-client
|
|
(lambda ()
|
|
(if (and (not (eq? client (wm-current-client wm)))
|
|
(not (window-contains-focus? dpy (client:window client))))
|
|
(wm-select-client wm client (crossing-event-time xevent))))))
|
|
|
|
(if (and (memq 'enter (get-option-value (wm:options wm) 'focus-policy))
|
|
(window-exists? dpy (client:window client)))
|
|
(if (ignore-next-enter-notify?)
|
|
(begin
|
|
(accept-next-enter-notify!)
|
|
(if (not (wm-current-client wm))
|
|
(lazy-wm-select-client)))
|
|
(lazy-wm-select-client)))))
|
|
|
|
((eq? (event-type button-press) type)
|
|
(if (memq 'click (get-option-value (wm:options wm) 'focus-policy))
|
|
(begin
|
|
(wm-select-client wm client (button-event-time xevent))
|
|
(if (not (eq? (button-event-subwindow xevent)
|
|
(client:client-window client)))
|
|
(allow-events dpy (event-mode replay-pointer)
|
|
(button-event-time xevent))
|
|
(allow-events dpy (event-mode async-pointer)
|
|
(button-event-time xevent))))))
|
|
|
|
((destroy-window-event? xevent)
|
|
(exit 'destroy)))))
|
|
|
|
(define (handle-client-xevent wm exit client xevent)
|
|
(let ((type (any-event-type xevent))
|
|
(internal-out-channel (wm:internal-out-channel wm))
|
|
(dpy (wm:dpy wm)))
|
|
(cond
|
|
((focus-change-event? xevent)
|
|
(if (window-exists? dpy (client:window client))
|
|
(let ((mode (focus-change-event-mode xevent))
|
|
(detail (focus-change-event-detail xevent)))
|
|
|
|
(if (and (or (eq? mode (notify-mode normal))
|
|
(eq? mode (notify-mode while-grabbed)))
|
|
(memq detail (list (notify-detail nonlinear)
|
|
(notify-detail nonlinear-virtual)
|
|
(notify-detail virtual)
|
|
(notify-detail ancestor))))
|
|
(if (eq? (event-type focus-in)
|
|
(focus-change-event-type xevent))
|
|
(begin
|
|
(install-colormaps dpy (client:window client))
|
|
(set-client-focused?! wm client #t))
|
|
(begin
|
|
(uninstall-colormaps dpy (client:window client))
|
|
(set-client-focused?! wm client #f)))))))
|
|
|
|
((property-event? xevent)
|
|
(if (window-exists? dpy (client:window client))
|
|
(let ((name (get-atom-name (property-event-display xevent)
|
|
(property-event-atom xevent))))
|
|
(cond
|
|
((equal? "WM_NAME" name)
|
|
(send internal-out-channel
|
|
(list 'update-client-name client
|
|
(client-name dpy client))))))))
|
|
|
|
((reparent-event? xevent)
|
|
(if (and (window-exists? dpy (client:window client))
|
|
(not (eq? (client:client-window client)
|
|
(window-parent dpy (client:window client)))))
|
|
(begin
|
|
;; window has been reparented away
|
|
(wm-deinit-client wm client)
|
|
(exit 'reparent))))
|
|
((destroy-window-event? xevent)
|
|
(if (eq? (client:window client) (destroy-window-event-event xevent))
|
|
(begin
|
|
(wm-deinit-client wm client)
|
|
(exit 'destroy))))
|
|
|
|
((map-event? xevent)
|
|
(let* ((s.i (get-wm-state dpy (client:window client)))
|
|
(s (and s.i (car s.i))))
|
|
(if (eq? (wm-state iconic) s)
|
|
;; iconic -> normal transition
|
|
(send (wm:internal-out-channel wm)
|
|
(list 'normalize-client client)))))
|
|
)))
|
|
|
|
(define (transients-for-client wm client)
|
|
(filter (lambda (c)
|
|
(and (not (eq? c client))
|
|
(equal? (client:window client)
|
|
(get-transient-for (wm:dpy wm) (client:window c)))))
|
|
(wm:clients wm)))
|
|
|
|
;; ignoring the next enter-notify
|
|
(define (ignore-next-enter-notify!)
|
|
(set! *ignore-next-enter-notify* #t))
|
|
|
|
(define (ignore-next-enter-notify?)
|
|
*ignore-next-enter-notify*)
|
|
|
|
(define *ignore-next-enter-notify* #f)
|
|
|
|
(define (accept-next-enter-notify!)
|
|
(set! *ignore-next-enter-notify* #f))
|
|
|
|
|
|
;; *** client names **************************************************
|
|
|
|
(define *client-names* '()) ;; (window oname name)
|
|
(define *client-names-lock* (make-lock))
|
|
|
|
(define (client-name dpy client)
|
|
(let* ((w (client:window client))
|
|
(cname (if (window-exists? dpy w)
|
|
(let* ((p (get-wm-name dpy w))
|
|
(l (if p (property->string-list p) '())))
|
|
(if (null? l)
|
|
"<untitled>"
|
|
(car l)))
|
|
"<untitled>")))
|
|
(with-lock *client-names-lock*
|
|
(lambda ()
|
|
(let ((name? (let ((p (assq w *client-names*)))
|
|
(and p (equal? (cadr p) cname)
|
|
(caddr p)))))
|
|
(set! *client-names*
|
|
(filter (lambda (e)
|
|
(and (not (eq? (car e) w))
|
|
(window-exists? dpy (car e))))
|
|
*client-names*))
|
|
(let ((name (if name? name?
|
|
(unique-name cname
|
|
(map caddr *client-names*)))))
|
|
(set! *client-names* (cons (list w cname name)
|
|
*client-names*))
|
|
name))))))
|
|
|
|
(define (unique-name name names)
|
|
(if (not (member name names))
|
|
name
|
|
(let loop ((i 1))
|
|
(let ((n (string-append name "<" (number->string i) ">")))
|
|
(if (member n names)
|
|
(loop (+ i 1))
|
|
n)))))
|
|
|
|
(define (find-window-by-name name)
|
|
(with-lock *client-names-lock*
|
|
(lambda ()
|
|
(let ((l (filter (lambda (w.o.n)
|
|
(equal? (third w.o.n) name))
|
|
*client-names*)))
|
|
(and (not (null? l)) (first (car l)))))))
|
|
|
|
(define (get-all-window-names)
|
|
(with-lock *client-names-lock*
|
|
(lambda ()
|
|
(map (lambda (w.o.n)
|
|
(cons (first w.o.n) (third w.o.n)))
|
|
*client-names*))))
|