orion-wm/src/manager.scm

(define-options-spec manager-options-spec
  (focus-policy symbol-list '(enter)) ;; enter, click
  )

;; TODO: focus-policy click does not work yet

(define-record-type wm :wm
  (make-wm type in-channel out-channel internal-out-channel
	   dpy window colormap options
	   clients 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)
  (clients wm:clients set-wm:clients!)
  (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-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 children
		   type options-spec 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
		      (create-options dpy colormap
				      (options-spec-union options-spec
							  manager-options-spec)
				      options)
		      '() #f)))

    ;; 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" #t)))
    (set-wm-hints! dpy main-window
		   (make-wm-hint-alist
		    (input? #t)))
			  
    ;; TODO: Colormaps
    
    ;; spawn handlers ************************************************
    (spawn* (list 'manager type)
	    (lambda (release)
	      (call-with-event-channel
	       (wm:dpy wm) (wm:window wm)
	       (event-mask structure-notify
			   enter-window
			   focus-change
			   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)
      (send internal-out-channel '(update-manager-state)))

     ;; 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" #t))
	    (let ((name (car (property:data p)))
		  (time (cadr (property:data p)))
		  (client (wm:current-client wm)))
	      (if (and client
		       (equal? name (intern-atom dpy "WM_TAKE_FOCUS" #t)))
		  (handle-external-message wm exit
					   (list 'select-client client time))
		  (set-input-focus dpy main-window (revert-to parent)
				   time))
	      ))))

     )))

(define (handle-external-message wm exit msg)
  (let ((internal-out-channel (wm:internal-out-channel wm))
	(dpy (wm:dpy wm)))
    (case (car msg)
     ((manage-window)
      (let* ((window (second msg))
	     (client (create-client wm window))
	     (maybe-rect (third msg)))
	(set-wm:clients! wm (cons client (wm:clients wm)))
	(send internal-out-channel
	      (list 'init-client client maybe-rect))
	(send internal-out-channel (list 'fit-client client))
	;; sync ??
	(map-window dpy window)
	(send internal-out-channel (list 'update-client-state client))))

     ((unmanage-window)
      (let* ((window (second msg))
	     (client (find (lambda (c)
			     (eq? window (client:window c)))
			   (wm:clients wm))))
	(if client
	    (begin
	      (reparent-to-root dpy window)
	      (handle-external-message wm exit
				       (list 'deinit-client client))))))

     ((destroy-manager)
      ;; (send internal-out-channel '(deinit-manager))
      ;; sync ??
      (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)))
	(if (eq? (wm:current-client wm) client)
	    (set-wm:current-client! wm #f)) ;; select another ??
	(send (wm:internal-out-channel wm) (list 'deinit-client client))
	;; sync ??
	(destroy-window dpy (client:client-window client))))

     ((select-client)
      (let ((client (second msg))
	    (time (third msg)))
	(for-each (lambda (client)
		    (set-wm:current-client! wm client)
		    (raise-window dpy (client:client-window client))
		    (take-focus dpy (client:window client) time))
		  (cons client (transients-for-client wm client)))
;	(for-each (lambda (c)
;		    (if (not (eq? c client))
;			(grab-button dpy
;				     (button button1) (state-set)
;				     (client:client-window c) #f
;				     (event-mask button-press)
;				     (grab-mode async) (grab-mode async)
;				     none none)))
;		  (wm:clients wm))
	))

     )))

(define (wm-deinit-client wm client)
  (mdisplay "manager deinit-client\n")
  (send (wm:in-channel wm) (list 'deinit-client client)))

;; *** external messages *********************************************

(define (wm-manage-window wm window . rect)
  (send (wm:in-channel wm)
	(list 'manage-window window
	      (if (null? rect)
		  #f
		  (car rect))))
  ;; sync ??
  )

(define (wm-unmanage-window wm window)
  (send (wm:in-channel wm) (list 'unmanage-window window)))

(define (wm-select-client wm client time)
  (send (wm:in-channel wm) (list 'select-client client time)))

(define (destroy-wm wm)
  (send (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)
  client?
  (window client:window set-client:window!)
  (client-window client:client-window)
  (in-channel client:in-channel)
  (data client:data set-client:data!))

(define (create-client wm window)
  (mdisplay "creating client for " window "\n")
  (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))
	 (client (make-client window client-window in-channel #f)))
    (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:type wm))
   (lambda (release)
     (call-with-event-channel
      (wm:dpy wm) (client:client-window client)
      (event-mask exposure
		  enter-window
		  button-press
		  structure-notify
		  focus-change)
      (lambda (client-window-channel)
	(call-with-event-channel
	 (wm:dpy wm) (client:window client)
	 (event-mask property-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)
			    (mdisplay "restarting handler\n")
			    (create-client-handler wm client)
			    (exit)))))
		 (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)
  (let ((l (filter (lambda (client)
		     (equal? window (client:window client)))
		   (wm-clients wm))))
    (and (pair? l) (car l))))

(define (client-replace-window wm old-window new-window)
  (mdisplay "replace-window " wm " " old-window " " new-window "\n")
  (let ((client (client-of-window wm old-window))
	(internal-out-channel (wm:internal-out-channel wm)))
    (if client
	(begin
	  (set-client:window! client new-window)
	  (send (client:in-channel client) '(restart-handler))
	  ;; update everything... TODO
	  ;;(send internal-out-channel (list 'init-client client #f))
	  (send internal-out-channel (list 'fit-windows client))
	  ;; sync ??
	  (map-window (wm:dpy wm) new-window)
	  (send internal-out-channel (list 'update-client-state client))
	  )
	#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)
      (send internal-out-channel
	    (list 'fit-client client)))
     ((or (focus-change-event? xevent) (circulate-event? xevent))
      ;; TODO: look at mode? or maybe only look at focus-in of the
      ;; client, because the client-window never gets the focus
      ;; anyway.
      (if (window-exists? dpy (client:window client)) ;; TODO: not perfect
	  (send internal-out-channel
		(list 'update-client-state client))))

     ((eq? (event-type enter-notify) type)
      (if (memq 'enter (get-option-value (wm:options wm) 'focus-policy))
	  (wm-select-client wm client (crossing-event-time xevent))))

     ((eq? (event-type button-press) type)
      (if (memq 'click (get-option-value (wm:options wm) 'focus-policy))
	  (wm-select-client wm client (button-event-time xevent))))

     ((destroy-window-event? xevent)
      (mdisplay "client-window destroyed\n")
      (exit)))))

(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
     ((property-event? xevent)
      (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-state client)))
	 ;; TODO: respect NORMAL_HINTS change
	 )))
     ((configure-event? xevent)
      ;; TODO: we have to prevent this event if changed the size on our own.
      ;; --> XReconfigureWMWindow ??
      (send internal-out-channel (list 'fit-client-window client))
      )
     ((reparent-event? xevent)
      (if (or (not (window-exists? dpy (client:window client)))
	      (not (eq? (client:client-window client)
			(window-parent dpy (client:window client)))))
	  (begin
	    (mdisplay "manager " (wm:type wm) " reparented client\n")
	    (wm-deinit-client wm client)
	    (exit))))
     ;; TODO: withdrawn-state etc.
     ((destroy-window-event? xevent)
      (mdisplay "destroy-window client\n")
      (wm-deinit-client wm client)
      (exit))
     )))

(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)))

;; *** client names **************************************************

(define client-name
  (let ((names '()) ;; (window oname name)
	(lock (make-lock)))
    (lambda (dpy client)
      (let* ((w (client:window client))
	     (cname (let* ((p (get-wm-name dpy w))
			   (l (if p (property->string-list p) '())))
		      (if (null? l)
			  "<untitled>"
			  (car l)))))
	(with-lock lock
		   (lambda ()
		     (let ((name? (let ((p (assq w names)))
				    (and p (equal? (cadr p) cname)
					 (caddr p)))))
		       (set! names
			     (filter (lambda (e)
				       (and (not (eq? (car e) w))
					    (window-exists? dpy (car e))))
				     names))
		       (let ((name (if name? name?
				       (unique-name cname
						    (map caddr names)))))
			 (set! names (cons (list w cname name) 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)))))