61 lines
1.9 KiB
Scheme
61 lines
1.9 KiB
Scheme
|
(define-record-type root-wm :root-wm
|
||
|
|
(make-root-wm dpy managers current-manager)
|
||
|
|
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!))
|
||
|
|
|
||
|
|
(define (create-root-wm dpy)
|
||
|
|
(let* ((window (default-root-window dpy))
|
||
|
|
(children (window-children dpy window))
|
||
|
|
(in-channel (make-channel))
|
||
|
|
(root-wm (make-root-wm dpy '() #f))
|
||
|
|
(initial-manager (create-move-wm in-channel dpy window '())))
|
||
|
|
(mdisplay "creating root-wm\n")
|
||
|
|
(set-root-wm:managers! root-wm (list initial-manager))
|
||
|
|
(set-root-wm:current-manager! root-wm initial-manager)
|
||
|
|
|
||
|
|
(map-window dpy (wm:window initial-manager))
|
||
|
|
|
||
|
|
(for-each (lambda (window)
|
||
|
|
(wm-manage-window initial-manager window))
|
||
|
|
children)
|
||
|
|
;;(create-move-wm in-channel dpy window '())
|
||
|
|
|
||
|
|
(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))))))))
|
||
|
|
|
||
|
|
(define (handle-xevent root-wm exit xevent)
|
||
|
|
(let ((type (any-event-type xevent))
|
||
|
|
(dpy (root-wm:dpy root-wm)))
|
||
|
|
(cond
|
||
|
|
((configure-request-event? xevent)
|
||
|
|
;; TODO: maybe let it configure by the future manager...
|
||
|
|
(configure-window dpy (configure-request-event-window xevent)
|
||
|
|
(configure-request-event-window-change-alist xevent)))
|
||
|
|
((map-request-event? xevent)
|
||
|
|
(wm-manage-window (root-wm:current-manager root-wm)
|
||
|
|
(map-request-event-window xevent)
|
||
|
|
#f))
|
||
|
|
)))
|
||
|
|
|
||
|
|
(define (handle-message root-wm exit msg)
|
||
|
|
'none)
|
||
|
|
|
||
|
|
;; *** observing managers ********************************************
|
||
|
|
|
||
|
|
(define (add-manager! manager)
|
||
|
|
#t)
|