- added normalize-window/client signal
- replaced client icons with a pager for move-wm
This commit is contained in:
frese
parent
613eb1fe8d
commit
f26844397b
|
|
@ -198,23 +198,18 @@
|
|||
(if (and client window (window-exists? dpy window))
|
||||
(reparent-to-root dpy window))))
|
||||
|
||||
((iconify-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 'iconify-client client)))))
|
||||
|
||||
((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 'maximize-client client)))))
|
||||
(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))
|
||||
|
|
@ -268,6 +263,9 @@
|
|||
(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)))
|
||||
|
||||
|
|
@ -284,13 +282,14 @@
|
|||
;; *** client ********************************************************
|
||||
|
||||
(define-record-type client :client
|
||||
(make-client window client-window in-channel data focused?)
|
||||
(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?!))
|
||||
(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)))
|
||||
|
|
@ -314,7 +313,13 @@
|
|||
(white-pixel dpy)
|
||||
(black-pixel dpy)))
|
||||
(in-channel (make-channel))
|
||||
(client (make-client window client-window in-channel #f #f)))
|
||||
(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)
|
||||
(define-cursor dpy client-window
|
||||
|
|
|
|||
|
|
@ -0,0 +1,214 @@
|
|||
(define-record-type move-wm-pager :move-wm-pager
|
||||
(make-move-wm-pager dpy window wm in-channel options buttons-alist width)
|
||||
move-wm-pager?
|
||||
(dpy pager:dpy)
|
||||
(window pager:window)
|
||||
(wm pager:wm)
|
||||
(in-channel pager:in-channel)
|
||||
(options pager:options)
|
||||
;; client -> button
|
||||
(buttons-alist pager:buttons-alist set-pager:buttons-alist!)
|
||||
(width pager:width set-pager:width!))
|
||||
|
||||
;; TODO: hide buttons/keys
|
||||
;; TODO: client-name <-> WM_ICON_NAME?
|
||||
|
||||
(define (repeat-infinitely fun) ;; -> utils
|
||||
(call-with-current-continuation
|
||||
(lambda (exit)
|
||||
(let loop ()
|
||||
(fun exit)
|
||||
(loop)))))
|
||||
|
||||
(define (create-move-wm-pager wm out-channel options)
|
||||
(let* ((dpy (wm:dpy wm))
|
||||
(parent (wm:window wm))
|
||||
(rect (calc-pager-rect wm))
|
||||
(bg-color (first (get-option-value options 'pager-colors)))
|
||||
(window (create-simple-window dpy parent
|
||||
(rectangle:x rect) (rectangle:y rect)
|
||||
(rectangle:width rect)
|
||||
(rectangle:height rect)
|
||||
0 (black-pixel dpy)
|
||||
bg-color))
|
||||
(in-channel (make-channel))
|
||||
(gc (create-gc dpy window '()))
|
||||
(colormap (screen:default-colormap (display:default-screen dpy)))
|
||||
(pager (make-move-wm-pager dpy window wm in-channel options '()
|
||||
(rectangle:width rect))))
|
||||
(spawn*
|
||||
(list 'move-wm-pager wm window)
|
||||
(lambda (release)
|
||||
(call-with-event-channel
|
||||
dpy window
|
||||
(event-mask exposure
|
||||
button-press button-release
|
||||
visibility-change)
|
||||
(lambda (window-channel)
|
||||
(release)
|
||||
(repeat-infinitely
|
||||
(lambda (exit)
|
||||
(select*
|
||||
(wrap (receive-rv in-channel)
|
||||
(lambda (msg)
|
||||
(cond
|
||||
((and (pair? (first msg))
|
||||
(eq? 'button (car (first msg))))
|
||||
(let ((client (cdr (first msg)))
|
||||
(time (second msg))
|
||||
(event (third msg)))
|
||||
(pager-action pager client time event)))
|
||||
((not (pair? (first msg)))
|
||||
(case (first msg)
|
||||
((add-client)
|
||||
(let* ((client (second msg))
|
||||
(button (pager-create-button
|
||||
pager client
|
||||
(make-rectangle 0 0 1 1))))
|
||||
(set-pager:buttons-alist!
|
||||
pager
|
||||
(append (pager:buttons-alist pager)
|
||||
(list (cons client button))))
|
||||
(pager-refit-buttons pager)
|
||||
(map-button button)))
|
||||
((remove-client)
|
||||
(let* ((client (second msg))
|
||||
(button (assq/false
|
||||
client
|
||||
(pager:buttons-alist pager))))
|
||||
(set-pager:buttons-alist!
|
||||
pager
|
||||
(alist-delete client
|
||||
(pager:buttons-alist pager)))
|
||||
(if button
|
||||
(begin
|
||||
(destroy-button button)
|
||||
(pager-refit-buttons pager))
|
||||
(warn "pager-remove-client: unknown client."
|
||||
pager client))))
|
||||
)))))
|
||||
|
||||
(wrap (receive-rv window-channel)
|
||||
(lambda (xevent)
|
||||
(cond
|
||||
((expose-event? xevent)
|
||||
(if (zero? (expose-event-count xevent))
|
||||
(pager-draw pager gc)))
|
||||
((destroy-window-event? xevent) ;; mask?
|
||||
;; destroy-button not necessary
|
||||
(exit))))))))
|
||||
(free-gc dpy gc)
|
||||
;;(free-options options #t) ;; common with wm
|
||||
))))
|
||||
(map-window dpy window)
|
||||
pager))
|
||||
|
||||
(define (pager-create-button pager client rect)
|
||||
(let* ((dpy (pager:dpy pager))
|
||||
(options (pager:options pager))
|
||||
(colors (get-option options 'pager-colors))
|
||||
(main-color (second colors))
|
||||
(light (third colors))
|
||||
(dark (fourth colors))
|
||||
(font-color (fifth colors)))
|
||||
(create-button (pager:dpy pager) (pager:window pager)
|
||||
(screen:default-colormap (display:default-screen dpy))
|
||||
rect (pager:in-channel pager)
|
||||
(cons 'button client)
|
||||
`(;; TODO: don't let every button allocate the
|
||||
;; colors, and load the font.
|
||||
(up-colors . ,(list main-color light dark font-color))
|
||||
(down-colors . ,(list main-color dark light font-color))
|
||||
(font . ,(get-option options 'font))
|
||||
(content . ,(client-name (pager:dpy pager) client))
|
||||
(type . switch)
|
||||
(initial-state . up)))))
|
||||
|
||||
(define (calc-pager-rect wm)
|
||||
(let ((dpy (wm:dpy wm))
|
||||
(window (wm:window wm))
|
||||
(options (wm:options wm))) ;; wm-options = pager-options!?
|
||||
(let* ((g (get-geometry dpy window))
|
||||
(width (vector-ref g 3))
|
||||
(height (vector-ref g 4))
|
||||
(pager-height (get-option-value options 'pager-height)))
|
||||
(make-rectangle 0 (- height pager-height)
|
||||
width pager-height))))
|
||||
|
||||
(define (pager-action pager client time event) ;, event??
|
||||
(let ((wm (pager:wm pager)))
|
||||
;; normalize/iconify directly via client?!
|
||||
(if (eq? (client:wm-state client)
|
||||
(wm-state iconic))
|
||||
(begin
|
||||
(wm-normalize-window wm (client:window client))
|
||||
(wm-select-client wm client time))
|
||||
(if (client:focused? client) ;; this should better be "on top?"
|
||||
;; select a different one?
|
||||
(wm-iconify-window wm (client:window client))
|
||||
(wm-select-client wm client time)))))
|
||||
|
||||
(define (pager-draw pager gc)
|
||||
(clear-window (pager:dpy pager) (pager:window pager)))
|
||||
|
||||
(define (pager-button-rects pager)
|
||||
(let ((alist (pager:buttons-alist pager))
|
||||
(options (pager:options pager)))
|
||||
(if (null? alist)
|
||||
'()
|
||||
(let* ((width (pager:width pager))
|
||||
(bwidth (min (get-option-value options
|
||||
'pager-maximum-button-width)
|
||||
(- (quotient width (length alist)) 2)))
|
||||
(bheight (- (get-option-value options 'pager-height) 4))
|
||||
(x 2)
|
||||
(y 2))
|
||||
(map (lambda (c.b)
|
||||
(let ((r (make-rectangle x y bwidth bheight)))
|
||||
(set! x (+ x bwidth 2))
|
||||
(cons (cdr c.b) r)))
|
||||
alist)))))
|
||||
|
||||
(define (pager-refit-buttons pager)
|
||||
(for-each (lambda (b.r)
|
||||
(move-resize-button (car b.r) (cdr b.r)))
|
||||
(pager-button-rects pager)))
|
||||
|
||||
;; "external functions"
|
||||
|
||||
(define (pager-refit pager)
|
||||
(let ((r (calc-pager-rect (pager:wm pager))))
|
||||
(set-pager:width! pager (rectangle:width r))
|
||||
(move-resize-window (pager:dpy pager) (pager:window pager)
|
||||
(rectangle:x r) (rectangle:y r)
|
||||
(rectangle:width r) (rectangle:height r))
|
||||
(pager-refit-buttons pager)))
|
||||
|
||||
(define (pager-add-client pager client)
|
||||
(send (pager:in-channel pager)
|
||||
(list 'add-client client)))
|
||||
|
||||
(define (pager-remove-client pager client)
|
||||
(send (pager:in-channel pager)
|
||||
(list 'remove-client client)))
|
||||
|
||||
(define (pager-update-button pager button client)
|
||||
(if (eq? (client:wm-state client)
|
||||
(wm-state iconic))
|
||||
(button-set-state! button 'down)
|
||||
(button-set-state! button 'up))
|
||||
(button-set-content! button
|
||||
(client-name (pager:dpy pager) client)))
|
||||
|
||||
(define (pager-update-client pager client)
|
||||
(let ((button (assq/false client (pager:buttons-alist pager))))
|
||||
(if button
|
||||
(pager-update-button pager button client)
|
||||
(warn "pager-update-client: unknown client" pager client))))
|
||||
|
||||
(define (pager-update pager)
|
||||
(for-each (lambda (c.b)
|
||||
(let ((client (car c.b))
|
||||
(button (cdr c.b)))
|
||||
(pager-update-button pager button client)))
|
||||
(pager:buttons-alist pager)))
|
||||
|
|
@ -8,6 +8,10 @@
|
|||
(corner-width int 10)
|
||||
(border-style symbol 'raised) ;; raised | sunken | flat
|
||||
(border-colors colors '("#333333" "#dddddd"))
|
||||
(pager-colors colors ;; bg, button, light, dark, font
|
||||
'("#808080" "#aaaaaa" "#eeeeee" "#777777" "black"))
|
||||
(pager-maximum-button-width int 140)
|
||||
(pager-height int 24)
|
||||
)
|
||||
|
||||
(define (create-move-wm out-channel dpy parent options default-options
|
||||
|
|
@ -24,7 +28,9 @@
|
|||
(define (init-move-wm wm channel)
|
||||
(let* ((dpy (wm:dpy wm))
|
||||
(window (wm:window wm))
|
||||
(gc (create-gc dpy window '())))
|
||||
(gc (create-gc dpy window '()))
|
||||
(pager-channel (make-channel))
|
||||
(pager (create-move-wm-pager wm pager-channel (wm:options wm))))
|
||||
(spawn* (list 'move-wm wm)
|
||||
(lambda (release)
|
||||
(release)
|
||||
|
|
@ -32,18 +38,18 @@
|
|||
(lambda (exit)
|
||||
(let loop ()
|
||||
(let ((msg (receive channel)))
|
||||
(handle-message wm gc exit msg)
|
||||
(handle-message wm pager gc exit msg)
|
||||
(loop)))))
|
||||
(free-gc dpy gc)))))
|
||||
|
||||
(define (handle-message wm gc exit msg)
|
||||
(define (handle-message wm pager 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 gc
|
||||
(handle-message wm pager gc
|
||||
(lambda args
|
||||
(sync-point-release sp)
|
||||
(apply exit args))
|
||||
|
|
@ -60,13 +66,21 @@
|
|||
((fit-windows)
|
||||
(map (lambda (client)
|
||||
(assert-client-visible wm client))
|
||||
(wm-clients wm)))
|
||||
(wm-clients wm))
|
||||
(pager-refit pager))
|
||||
|
||||
((init-client)
|
||||
(init-client wm (second msg) (third msg)))
|
||||
(let ((client (second msg))
|
||||
(maybe-rect (third msg)))
|
||||
(init-client wm client maybe-rect)
|
||||
(pager-add-client pager client)
|
||||
;; for (properly) transient windows this would not be necessary:
|
||||
(wm-select-client wm client current-time)))
|
||||
|
||||
((deinit-client)
|
||||
(deinit-client wm (second msg)))
|
||||
(let ((client (second msg)))
|
||||
(deinit-client wm client)
|
||||
(pager-remove-client pager client)))
|
||||
|
||||
((configure-window)
|
||||
(let ((window (second msg))
|
||||
|
|
@ -139,30 +153,30 @@
|
|||
|
||||
((iconify-client)
|
||||
(let ((client (second msg)))
|
||||
(if (not (client-data:icon client))
|
||||
(if (not (eq? (client:wm-state client) (wm-state iconic)))
|
||||
(begin
|
||||
(unmap-window dpy (client:client-window client))
|
||||
(unmap-window dpy (client:window client))
|
||||
(set-wm-state! dpy (client:window client) (wm-state iconic)
|
||||
none)
|
||||
(let ((icon (create-client-icon wm client)))
|
||||
(set-client-data:icon! client icon)
|
||||
(map-icon icon))))))
|
||||
(set-client:wm-state! client (wm-state iconic))))
|
||||
(pager-update-client pager client)))
|
||||
|
||||
((maximize-client)
|
||||
;; TODO: maybe exclude pager?
|
||||
(let ((client (second msg)))
|
||||
(maximize-window dpy (client:client-window client))))
|
||||
|
||||
((normalize-client)
|
||||
(let ((client (second msg)))
|
||||
(if (client-data:icon client)
|
||||
(if (not (eq? (client:wm-state client) (wm-state normal)))
|
||||
(begin
|
||||
(destroy-icon (client-data:icon client))
|
||||
(map-window dpy (client:window client))
|
||||
(map-window dpy (client:client-window client))
|
||||
(set-wm-state! dpy (client:window client) (wm-state normal)
|
||||
none)
|
||||
(set-client-data:icon! client #f)))))
|
||||
(set-client:wm-state! client (wm-state normal))))
|
||||
(pager-update-client pager client)))
|
||||
|
||||
((draw-client-window)
|
||||
(draw-client-window wm (second msg) gc))
|
||||
|
|
@ -184,27 +198,29 @@
|
|||
'focused
|
||||
'normal))
|
||||
(titlebar (client-data:titlebar client)))
|
||||
(set-titlebar-state! titlebar state)))
|
||||
(set-titlebar-state! titlebar state)
|
||||
(pager-update-client pager client)))
|
||||
|
||||
((update-client-name)
|
||||
(let ((client (second msg))
|
||||
(name (third msg)))
|
||||
(let ((titlebar (client-data:titlebar client)))
|
||||
(set-titlebar-title! titlebar name))))
|
||||
(set-titlebar-title! titlebar name)
|
||||
(pager-update-client pager client))))
|
||||
|
||||
((show-clients)
|
||||
(let ((clients (second msg)))
|
||||
(for-each (lambda (c)
|
||||
(if (client-data:icon c)
|
||||
(handle-message wm gc exit
|
||||
(if (eq? (client:wm-state c) (wm-state iconic))
|
||||
(handle-message wm pager gc exit
|
||||
(list 'normalize-client c)))
|
||||
(raise-window dpy (client:client-window c)))
|
||||
clients)))
|
||||
|
||||
(else (warn "unhandled move-wm message" wm msg)))))
|
||||
|
||||
(define (make-client-data titlebar resizer icon)
|
||||
(list titlebar resizer icon))
|
||||
(define (make-client-data titlebar resizer)
|
||||
(list titlebar resizer))
|
||||
|
||||
(define (client-data:titlebar client)
|
||||
(first (client:data client)))
|
||||
|
|
@ -212,12 +228,6 @@
|
|||
(define (client-data:resizer client)
|
||||
(second (client:data client)))
|
||||
|
||||
(define (client-data:icon client)
|
||||
(third (client:data client)))
|
||||
|
||||
(define (set-client-data:icon! client icon)
|
||||
(set-car! (cddr (client:data client)) icon))
|
||||
|
||||
(define (window-wants-decoration? dpy window)
|
||||
(cond
|
||||
((get-motif-wm-hints dpy window) =>
|
||||
|
|
@ -234,7 +244,7 @@
|
|||
(titlebar (create-client-titlebar channel wm client))
|
||||
(resizer (create-resizer wm client))
|
||||
(options (wm:options wm)))
|
||||
(set-client:data! client (make-client-data titlebar resizer #f))
|
||||
(set-client:data! client (make-client-data titlebar resizer))
|
||||
(set-titlebar-title! titlebar (client-name dpy client))
|
||||
(let* ((bw (get-option-value options 'border-width))
|
||||
(th (get-option-value options 'titlebar-height))
|
||||
|
|
@ -300,7 +310,7 @@
|
|||
(cons 'normal-colors
|
||||
(get-option options 'titlebar-colors))
|
||||
(cons 'active-colors
|
||||
(get-option options'titlebar-colors-focused))
|
||||
(get-option options 'titlebar-colors-focused))
|
||||
(cons 'focused-colors
|
||||
(get-option options 'titlebar-colors-focused))
|
||||
(cons 'border-style
|
||||
|
|
@ -310,13 +320,6 @@
|
|||
(let ((dpy (wm:dpy wm)))
|
||||
(set-input-focus dpy (wm:window wm) (revert-to parent) current-time)))
|
||||
|
||||
(define (create-client-icon wm client)
|
||||
(let* ((other-icons (filter (lambda (x) x)
|
||||
(map client-data:icon (wm-clients wm))))
|
||||
(r (find-icon-rect (clip-rectangle (wm:dpy wm) (wm:window wm))
|
||||
other-icons)))
|
||||
(create-icon wm client r)))
|
||||
|
||||
;; ***
|
||||
|
||||
(define (fit-client-windows wm client)
|
||||
|
|
@ -360,7 +363,6 @@
|
|||
(y (window-y dpy win))
|
||||
(w (window-width dpy (wm:window wm)))
|
||||
(h (window-height dpy (wm:window wm))))
|
||||
;; TODO: assert-icon-visible ...
|
||||
(if (>= x w)
|
||||
(set-window-x! dpy win (- w 10)))
|
||||
(if (>= y h)
|
||||
|
|
@ -432,7 +434,8 @@
|
|||
(window-rectangle dpy (client:client-window client)))
|
||||
(filter (lambda (c)
|
||||
(and (not (eq? c client))
|
||||
(not (client-data:icon c))))
|
||||
(not (eq? (client:wm-state c)
|
||||
(wm-state iconic)))))
|
||||
(wm-clients wm))))
|
||||
(list1 (map (lambda (x.y)
|
||||
(make-rectangle (car x.y) (cdr x.y) w h))
|
||||
|
|
|
|||
|
|
@ -72,8 +72,11 @@
|
|||
(define-structure button
|
||||
(export create-button destroy-button
|
||||
map-button unmap-button
|
||||
move-resize-button)
|
||||
move-resize-button
|
||||
button-get-state button-set-state!
|
||||
button-set-content!)
|
||||
(open scheme list-lib rendezvous-channels
|
||||
rendezvous placeholders
|
||||
define-record-types
|
||||
xlib
|
||||
utils)
|
||||
|
|
@ -118,13 +121,16 @@
|
|||
create-wm destroy-wm
|
||||
wm-clients wm-current-client
|
||||
wm-manage-window wm-unmanage-window wm-select-client
|
||||
wm-configure-window wm-iconify-window wm-maximize-window
|
||||
wm-configure-window
|
||||
wm-iconify-window wm-normalize-window wm-maximize-window
|
||||
wm-deinit-client
|
||||
|
||||
ignore-next-enter-notify!
|
||||
|
||||
client? client:window client:client-window
|
||||
client:data set-client:data!
|
||||
client:wm-state set-client:wm-state!
|
||||
client:focused?
|
||||
client-name find-window-by-name get-all-window-names
|
||||
client-replace-window
|
||||
client-of-window)
|
||||
|
|
@ -143,13 +149,13 @@
|
|||
(export create-move-wm)
|
||||
(open scheme list-lib define-record-types signals
|
||||
threads rendezvous-channels rendezvous
|
||||
xlib
|
||||
xlib button
|
||||
manager key-grab
|
||||
utils dragging titlebar
|
||||
utils dragging titlebar button
|
||||
motif enum-sets)
|
||||
(files move-wm
|
||||
move-wm-resizer
|
||||
move-wm-icon))
|
||||
move-wm-pager))
|
||||
|
||||
;; *** split manager *************************************************
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue