orion-wm/src/root-manager.scm

(define-record-type root-wm :root-wm
  (make-root-wm dpy managers current-manager in-channel)
  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!)
  (in-channel root-wm:in-channel))

(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 in-channel))
	 (initial-manager (create-move-wm in-channel dpy window '())))
    (mdisplay "creating root-wm\n")
    (set-root-wm:current-manager! root-wm initial-manager)
    (add-manager! root-wm initial-manager)

    (map-window dpy (wm:window initial-manager))

    (for-each (lambda (window)
		(wm-manage-window initial-manager window))
	      children)

    (grab-shortcut dpy window (string->keys dpy "M-k h") ;; -> options!
		   'split-horizontal in-channel #t)
    (grab-shortcut dpy window (string->keys dpy "M-k v")
		   'split-vertical in-channel #t)

    (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)
  (case (car msg)
    ((split-vertical split-horizontal)
     ;; TODO: ask for second manager
     (let* ((current (root-wm:current-manager root-wm))
	    (parent (manager-parent root-wm current)) ;; #f if root
	    (dpy (wm:dpy current))
	    (parent-window (or (and parent (wm:window parent))
			       (default-root-window dpy)))
	    (in-channel (root-wm:in-channel root-wm))
	    (orientation (if (eq? 'split-vertical (car msg))
			     'vertical 'horizontal))
	    (splitter (create-split-wm in-channel dpy parent-window
				       ;; TODO other options
				       (list (cons 'orientation orientation))))
	    (first current)
	    (second (create-switch-wm in-channel dpy (wm:window splitter)
				      '())))
       (wm-manage-window splitter (wm:window first))
       (wm-manage-window splitter (wm:window second))
       (if parent
	   (wm-manage-window parent (wm:window splitter))
	   (map-window dpy (wm:window splitter)))
       (add-manager! root-wm splitter)
       (add-manager! root-wm second)))
    ((manager-focused)
     (let ((manager (second msg)))
       (set-root-wm:current-manager! root-wm manager)))
    ((root-drop) ...)
    (else (mdisplay "unknown root message: " msg "\n"))))

;; *** observing managers ********************************************

(define (add-manager! root-wm manager)
  (set-root-wm:managers! root-wm (cons manager
				       (root-wm:managers root-wm)))
  (spawn*
   (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) #t)
	     ((focus-change-event? e)
	      ;; look at mode/detail ??
	      (if (window-contains-focus? (root-wm:dpy root-wm)
					  (wm:window manager))
		  (send (root-wm:in-channel root-wm)
			(list 'manager-focused manager)))
	      (loop))
	     (else (loop))))
	  (loop)))))))

(define (manager-parent root-wm manager)
  (let loop ((parent-window (window-parent (root-wm:dpy root-wm)
					   (wm:window manager))))
    (if (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))))))