377 lines
12 KiB
Scheme
377 lines
12 KiB
Scheme
(define (create-switch-wm out-channel dpy parent options
|
|
special-options . children)
|
|
(create-wm dpy parent options #f children
|
|
(manager-type switch)
|
|
out-channel
|
|
(lambda (wm in-channel)
|
|
(init-switch-wm wm in-channel)
|
|
wm)))
|
|
|
|
(define-record-type switch-wm-data :switch-wm-data
|
|
(make-switch-wm-data titlebars empty-titlebar titlebar-options)
|
|
switch-wm-data?
|
|
(titlebars data:titlebars set-data:titlebars!)
|
|
(empty-titlebar data:empty-titlebar)
|
|
(titlebar-options data:titlebar-options))
|
|
|
|
(define (init-switch-wm wm channel)
|
|
(let* ((dpy (wm:dpy wm))
|
|
(window (wm:window wm))
|
|
(options (wm:options wm))
|
|
(gc (create-gc dpy window '()))
|
|
(titlebar-options
|
|
(let ((get (lambda (id) (get-option-value options id))))
|
|
(build-options dpy (options:colormap options)
|
|
titlebar-options-spec
|
|
`((buttons . (kill))
|
|
(normal-colors . ,(get 'titlebar-colors))
|
|
(active-colors . ,(get 'titlebar-colors-active))
|
|
(focused-colors . ,(get 'titlebar-colors-focused))
|
|
(border-style . ,(get 'titlebar-style))
|
|
(font . ,(get 'font))
|
|
(button-down-colors . ,(get
|
|
'titlebar-button-down-colors))
|
|
(button-up-colors . ,(get 'titlebar-button-up-colors))
|
|
(height . ,(get 'titlebar-height))))))
|
|
(empty-titlebar (create-empty-titlebar wm))
|
|
(data (make-switch-wm-data '() empty-titlebar titlebar-options)))
|
|
(update-titlebars wm data)
|
|
|
|
(for-each (lambda (id)
|
|
(grab-shortcut dpy window
|
|
(get-option-value options id)
|
|
id channel #f))
|
|
'(select-next select-previous swap-next swap-previous))
|
|
|
|
(spawn* (list 'switch-wm wm)
|
|
(lambda (release)
|
|
(release)
|
|
(call-with-current-continuation
|
|
(lambda (exit)
|
|
(let loop ()
|
|
(let ((msg (receive channel)))
|
|
(handle-message wm data gc exit msg)
|
|
(loop)))))
|
|
(free-gc dpy gc)))))
|
|
|
|
(define (handle-message wm data gc exit msg)
|
|
(let ((dpy (wm:dpy wm))
|
|
(window (wm:window wm)))
|
|
(case (car msg)
|
|
((wait)
|
|
(let ((sp (second msg))
|
|
(message (third msg)))
|
|
(handle-message wm data gc
|
|
(lambda args
|
|
(sync-point-release sp)
|
|
(apply exit args))
|
|
message)
|
|
(sync-point-release sp)))
|
|
|
|
((deinit-manager)
|
|
(destroy-titlebar (data:empty-titlebar data))
|
|
(for-each (lambda (client.tb)
|
|
(destroy-titlebar (cdr client.tb)))
|
|
(data:titlebars data))
|
|
(exit 'deinit-manager))
|
|
|
|
((draw-main-window) #t)
|
|
|
|
((fit-windows)
|
|
(fit-titlebars wm data)
|
|
(for-each (lambda (c)
|
|
(fit-client-window wm c))
|
|
(wm-clients wm)))
|
|
|
|
((init-client)
|
|
(init-client wm data (second msg) (third msg)))
|
|
|
|
((deinit-client)
|
|
(deinit-client wm data (second msg)))
|
|
|
|
((iconify-client maximize-client) #t)
|
|
|
|
((configure-window)
|
|
(let ((window (second msg))
|
|
(changes (third msg)))
|
|
;; TODO: exact sizes ?!
|
|
(configure-window dpy window
|
|
(append (make-window-change-alist
|
|
(border-width 0))
|
|
changes))))
|
|
|
|
((draw-client-window) #f)
|
|
|
|
((fit-client)
|
|
;; client-window changed it's size
|
|
(fit-client wm (second msg)))
|
|
|
|
((fit-client-window)
|
|
;; client changed it's size ??
|
|
(fit-client-window wm (second msg)))
|
|
|
|
((update-manager-state)
|
|
(let* ((focused? (second msg))
|
|
(state (if focused?
|
|
'focused
|
|
'active)))
|
|
(set-titlebar-state! (data:empty-titlebar data) state)))
|
|
|
|
((manager-focused)
|
|
(let ((time (second msg))
|
|
(cc (wm-current-client wm)))
|
|
(if cc (wm-select-client wm cc time))))
|
|
|
|
((update-client-state)
|
|
(let* ((client (second msg))
|
|
(focused? (third msg))
|
|
(dpy (wm:dpy wm))
|
|
(window (client:window client))
|
|
(titlebar (assq/false client (data:titlebars data))))
|
|
(if (and titlebar (window-exists? dpy window))
|
|
(let ((state (if focused?
|
|
'focused
|
|
(if (window-viewable? dpy window)
|
|
'active
|
|
'normal))))
|
|
(set-titlebar-state! titlebar state)))))
|
|
|
|
((update-client-name)
|
|
(let ((client (second msg))
|
|
(name (third msg)))
|
|
(let ((titlebar (assq/false client (data:titlebars data))))
|
|
(if titlebar
|
|
(set-titlebar-title! titlebar name)))))
|
|
|
|
((select-next) (select-next-client wm data (second msg)))
|
|
((select-previous) (select-previous-client wm data (second msg)))
|
|
|
|
((swap-next) (swap-titlebar-with-next wm data (second msg)))
|
|
((swap-previous) (swap-titlebar-with-previous wm data (second msg)))
|
|
|
|
((show-clients)
|
|
(let ((clients (second msg)))
|
|
;; it's a list of a client and it's transients.
|
|
(let ((cc (wm-current-client wm))
|
|
(top (last clients)))
|
|
(map-window dpy (client:client-window top))
|
|
(if (and cc (window-mapped? dpy (client:client-window cc)))
|
|
(unmap-window dpy (client:client-window cc))))))
|
|
|
|
(else (warn "unhandled switch-wm message" wm msg)))))
|
|
|
|
(define (fit-titlebars wm data)
|
|
(let* ((dpy (wm:dpy wm))
|
|
(width (window-width dpy (wm:window wm)))
|
|
(height (window-height dpy (wm:window wm)))
|
|
(titlebar-height (get-option-value (wm:options wm) 'titlebar-height)))
|
|
(if (> titlebar-height 0)
|
|
(begin
|
|
(move-resize-titlebar (data:empty-titlebar data)
|
|
(make-rectangle 0 0 width titlebar-height))
|
|
(let* ((titlebars (map cdr (data:titlebars data)))
|
|
(n (length titlebars))
|
|
(dw (if (zero? n) 0 (quotient width n)))
|
|
(widths (if (zero? n) '()
|
|
(append (map (lambda (_) dw) (iota (- n 1)))
|
|
(list (- width (* dw (- n 1))))))))
|
|
(for-each (lambda (i width titlebar)
|
|
(move-resize-titlebar
|
|
titlebar
|
|
(make-rectangle (* i dw) 0
|
|
width titlebar-height)))
|
|
(iota n) widths titlebars))))))
|
|
|
|
(define (update-titlebars wm data)
|
|
(if (> (get-option-value (wm:options wm) 'titlebar-height) 0)
|
|
(if (null? (data:titlebars data))
|
|
(map-titlebar (data:empty-titlebar data))
|
|
(begin
|
|
(unmap-titlebar (data:empty-titlebar data))
|
|
(for-each (lambda (c.t)
|
|
(map-titlebar (cdr c.t)))
|
|
(data:titlebars data))))))
|
|
|
|
(define (init-client wm data client maybe-rect)
|
|
(let ((dpy (wm:dpy wm))
|
|
(options (wm:options wm)))
|
|
(let* ((channel (make-channel))
|
|
(titlebar (create-client-titlebar channel wm data client)))
|
|
(set-data:titlebars! data (append (data:titlebars data)
|
|
(list (cons client titlebar))))
|
|
(set-titlebar-title! titlebar (client-name dpy client))
|
|
(fit-titlebars wm data)
|
|
(update-titlebars wm data)
|
|
|
|
(fit-client-window wm client)
|
|
(fit-client wm client)
|
|
|
|
(install-dragging-control channel dpy
|
|
(titlebar:window titlebar)
|
|
(titlebar:window titlebar))
|
|
(spawn*
|
|
(list 'switch-wm-client-handler wm client)
|
|
(lambda (release)
|
|
(release)
|
|
(let loop ()
|
|
(let ((msg (receive channel)))
|
|
(case (car msg)
|
|
((drop)
|
|
;; check if outside...
|
|
(let ((root-x (fourth msg))
|
|
(root-y (fifth msg)))
|
|
(let ((r (root-rectangle dpy (wm:window wm))))
|
|
(if (not (point-in-rectangle? r root-x root-y))
|
|
(send (wm:out-channel wm)
|
|
(list 'root-drop (client:window client)
|
|
root-x root-y))))))
|
|
((click)
|
|
(wm-select-client wm client (fourth msg)))
|
|
;; from titlebar-buttons
|
|
((kill)
|
|
(let ((time (second msg)))
|
|
;; sometimes zombie-client-windows still hang
|
|
;; around. this is just a hack to let the user close
|
|
;; those manually:
|
|
(if (or (not (window-exists? dpy (client:window client)))
|
|
(not (eq? (window-parent dpy (client:window client))
|
|
(client:client-window client))))
|
|
(spawn (lambda ()
|
|
(wm-deinit-client wm client)))
|
|
(delete-window dpy (client:window client) time))))
|
|
(else (warn "unhandled client message " wm client msg))))
|
|
(loop))))
|
|
|
|
(map-titlebar titlebar)
|
|
(if (window-exists? dpy (client:window client))
|
|
(map-window dpy (client:window client)))
|
|
(wm-select-client wm client current-time))))
|
|
|
|
(define (create-client-titlebar channel wm data client)
|
|
(create-titlebar channel (wm:dpy wm) (wm:window wm)
|
|
(data:titlebar-options data)))
|
|
|
|
(define (create-empty-titlebar wm)
|
|
(let* ((options (wm:options wm))
|
|
(get (lambda (id) (get-option-value options id)))
|
|
(tb-options
|
|
(build-options (options:dpy options) (options:colormap options)
|
|
titlebar-options-spec
|
|
`((buttons . ())
|
|
(normal-colors . ,(get 'titlebar-colors))
|
|
(active-colors . ,(get 'titlebar-colors-active))
|
|
(focused-colors . ,(get 'titlebar-colors-focused))
|
|
(border-style . ,(get 'titlebar-style))
|
|
(font . ,(get 'font))
|
|
(button-down-colors . ,(get 'titlebar-button-down-colors))
|
|
(button-up-colors . ,(get 'titlebar-button-up-colors))
|
|
(height . ,(get 'titlebar-height)))))
|
|
(tb (create-titlebar #f (wm:dpy wm) (wm:window wm) tb-options)))
|
|
(set-titlebar-title! tb "<empty frame>")
|
|
tb))
|
|
|
|
(define (deinit-client wm data client)
|
|
(let ((dpy (wm:dpy wm))
|
|
(tb (assq/false client (data:titlebars data))))
|
|
(set-data:titlebars! data (filter (lambda (c.t)
|
|
(not (eq? (car c.t) client)))
|
|
(data:titlebars data)))
|
|
(if tb (destroy-titlebar tb))
|
|
(fit-titlebars wm data)
|
|
(update-titlebars wm data)
|
|
(if (eq? client (wm-current-client wm))
|
|
(if (null? (wm-clients-stacking wm))
|
|
(set-input-focus dpy (wm:window wm) (revert-to parent)
|
|
current-time)
|
|
(let ((next-client (car (wm-clients-stacking wm))))
|
|
(wm-select-client wm next-client current-time))))))
|
|
|
|
;; ***
|
|
|
|
(define (fit-client wm client)
|
|
(let ((window (client:window client))
|
|
(client-window (client:client-window client))
|
|
(dpy (wm:dpy wm)))
|
|
(if (window-exists? dpy window)
|
|
(begin
|
|
(maximize-window dpy window)
|
|
;; if the client fills the full client-window, we set the
|
|
;; client-window to transparent, so if the client is
|
|
;; transparent too, the root-windows pixmap can be seen.
|
|
(let ((r1 (clip-rectangle dpy window))
|
|
(r2 (clip-rectangle dpy client-window)))
|
|
(if (and (equal? (rectangle:width r1) (rectangle:width r2))
|
|
(equal? (rectangle:height r1) (rectangle:height r2)))
|
|
;; client fill client-window completely, make it transparent
|
|
(set-window-background-pixmap! dpy client-window
|
|
parent-relative)
|
|
;; otherwise make it black
|
|
(set-window-background-pixel! dpy client-window
|
|
(black-pixel dpy))))))))
|
|
|
|
(define (fit-client-window wm client)
|
|
(let* ((dpy (wm:dpy wm))
|
|
(w (wm:window wm))
|
|
(options (wm:options wm))
|
|
(titlebar-height (get-option-value options 'titlebar-height)))
|
|
(move-resize-window dpy (client:client-window client)
|
|
0 titlebar-height
|
|
(window-width dpy w) (- (window-height dpy w)
|
|
titlebar-height))))
|
|
|
|
;; ***
|
|
|
|
(define (select-next-client* wm clients time)
|
|
(let ((cc (wm-current-client wm)))
|
|
(let loop ((l (append clients clients)))
|
|
(and (not (null? l))
|
|
(if (eq? (car l) cc)
|
|
(and (not (null? (cdr l)))
|
|
(wm-select-client wm (cadr l) time))
|
|
(loop (cdr l)))))))
|
|
|
|
(define (select-next-client wm data time)
|
|
(select-next-client* wm (map car (data:titlebars data)) time))
|
|
|
|
(define (select-previous-client wm data time)
|
|
(select-next-client* wm (reverse (map car (data:titlebars data))) time))
|
|
|
|
;; ***
|
|
|
|
(define (swap-titlebar wm data time next?)
|
|
(let* ((cc (wm-current-client wm))
|
|
(titlebars (if next?
|
|
(data:titlebars data)
|
|
(reverse (data:titlebars data))))
|
|
(before.after
|
|
(fold-right (lambda (client.tb result)
|
|
(if (eq? (car client.tb) cc)
|
|
(cons (cdr result) (cons client.tb (car result)))
|
|
(cons (cons client.tb (car result)) (cdr result))))
|
|
(cons '() '())
|
|
titlebars))
|
|
(before (car before.after))
|
|
(after (cdr before.after))
|
|
(ntitlebars (cond
|
|
((null? after) titlebars) ;; cc not in list
|
|
((null? (cdr after)) ;; it's the last one
|
|
;; this is not really a 'swap', but probably
|
|
;; what the user expects
|
|
(cons (car after)
|
|
before))
|
|
(else
|
|
(append before
|
|
(cons (cadr after)
|
|
(cons (car after) (cddr after))))))))
|
|
(if next?
|
|
(set-data:titlebars! data ntitlebars)
|
|
(set-data:titlebars! data (reverse ntitlebars)))
|
|
(fit-titlebars wm data)))
|
|
|
|
|
|
(define (swap-titlebar-with-next wm data time)
|
|
(swap-titlebar wm data time #t))
|
|
|
|
(define (swap-titlebar-with-previous wm data time)
|
|
(swap-titlebar wm data time #f))
|