orion-wm/src/root-manager.scm

(define-options-spec root-options-spec
  (quit keys "F12")
  (quit-question string "Really quit orion?")
  (split-horizontal keys "M-s h")
  (split-vertical keys "M-s v")
  (split-horizontal-with-switch-wm keys "M-s s h")
  (split-vertical-with-switch-wm keys "M-s s v")
  (split-horizontal-with-move-wm keys "M-s m h")
  (split-vertical-with-move-wm keys "M-s m v")
  (create-switch-wm keys "M-k s")
  (create-move-wm keys "M-k m")
  (split-question string "What kind of manager do you want in the second frame?\n(S)witch or (M)ove windowmanager:")
  (execute keys "F3")
  (execute-question string "Execute:")
  (attach keys "M-a")
  (attach-question string "Attach:")
  (default-split-options sexp '())
  (default-switch-options sexp '())
  (default-move-options sexp '())
  (workspace-options sexp '())
  (nth-workspace keys-list '("M-1" "M-2" "M-3" "M-4"))
  (create-workspace keys "F9")
  (create-workspace-question string "What kind of manager do you want in the new workspace?\n(S)witch or (M)ove windowmanager:")
  (kill-client keys "M-c")
  )

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

(define (root-wm-managers root-wm)
  (filter (lambda (wm)
	    (window-exists? (root-wm:dpy root-wm) (wm:window wm)))
	  (root-wm:managers root-wm)))

(define (create-root-wm dpy options)
  (let* ((window (default-root-window dpy))
	 (screen (display:default-screen dpy))
	 (options (create-options dpy (screen:default-colormap screen)
				  root-options-spec options))
	 (children (window-children dpy window))
	 (in-channel (make-channel))
	 ;; TODO: workspace-options...
	 (initial-manager (create-workspace-manager in-channel dpy window
						    options))
	 (root-wm (make-root-wm dpy '() #f initial-manager in-channel options
				(make-sync-point)))
	 )
    (set-root-wm:current-manager! root-wm initial-manager)
    (add-manager! root-wm initial-manager)

    (for-each (lambda (name)
		(grab-shortcut dpy window (get-option-value options name)
			       name in-channel #t))
	      '(split-horizontal split-vertical
		split-horizontal-with-switch-wm split-vertical-with-switch-wm
		split-horizontal-with-move-wm split-vertical-with-move-wm
		create-switch-wm create-move-wm
		execute attach quit
		create-workspace
		kill-client))

    (spawn* '(root-wm)
	    (lambda (release)
	      (call-with-event-channel
	       dpy window (event-mask substructure-redirect)
	       (lambda (event-channel)
		 (release)
		 (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))))
		 (sync-point-release (root-wm:finish root-wm))))))
    root-wm))

(define (create-workspace-manager in-channel dpy parent options)
  (let ((wm (create-switch-wm in-channel dpy parent
			      (cons (cons 'titlebar-height 0)
				    (get-option-value options
						      'workspace-options))))
	(select-keys (get-option-value options 'nth-workspace))
	(channel (make-channel)))
    (for-each (lambda (i key)
		(grab-shortcut dpy (wm:window wm) key i channel #t))
	      (iota (length select-keys))
	      select-keys)
    (spawn*
     (list 'workspace-manager wm)
     (lambda (release)
       (release)
       (let loop ()
	 (let ((msg (receive channel)))
	   (if (number? (car msg))
	       (let ((i (car msg))
		     (cs (wm-clients wm)))
		 (if (< i (length cs))
		     (wm-select-client wm (list-ref cs i)
				       (second msg)))))
	   (loop)))))
    wm))

(define (wait-for-root-wm root-wm)
  (sync-point-wait (root-wm:finish root-wm)))

(define (root-wm-manage-window root-wm window)
  (wm-manage-window (root-wm:current-manager root-wm) window))

(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))
     ((and (unmap-event? xevent) (not (unmap-event-from-configure? xevent)))
      ;; syntetic unmap event for a transition to withdrawn state
      (set-wm-state! dpy (unmap-event-window xevent)
		     (wm-state withdrawn) none))
     )))

(define (do-split root-wm orientation new-wm)
  (let* ((current (root-wm:current-manager root-wm))
	 (parent (manager-parent root-wm current)) ;; #f if root
	 (dpy (wm:dpy current))
	 (options (root-wm:options root-wm))
	 (in-channel (root-wm:in-channel root-wm))
	 (splitter
	  (create-split-wm in-channel dpy
			   (window-parent dpy (wm:window current))
			   (cons (cons 'orientation orientation)
				 (get-option-value options
						   'default-split-options))))
	 (first current)
	 (creator (if (eq? new-wm 'switch-wm)
		      create-switch-wm
		      create-move-wm))
	 (second (creator in-channel dpy (wm:window splitter)
			  (get-option-value options
					    (if (eq? new-wm 'switch-wm)
						'default-switch-options
						'default-move-options)))))
    ;; we just replace the client:window
    (if parent
	(client-replace-window parent (wm:window current)
			       (wm:window splitter))
	(map-window dpy (wm:window splitter))) ;; maybe resize ??
    (wm-manage-window splitter (wm:window first))
    (wm-manage-window splitter (wm:window second))
    
    (add-manager! root-wm splitter)
    (add-manager! root-wm second)))

(define (handle-message root-wm exit msg)
  (case (car msg)
    ((split-vertical split-horizontal)
     (let ((c (prompt (root-wm:dpy root-wm) #f
		      (get-option-value (root-wm:options root-wm)
					'split-question)
		      '(#\s #\S #\m #\M) #f)))
       (if c
	   (do-split root-wm
		     (if (eq? (car msg) 'split-vertical)
			 'vertical 'horizontal)
		     (if (or (eq? c #\s) (eq? c #\S))
			 'switch-wm
			 'move-wm)))))

    ((split-horizontal-with-switch-wm)
     (do-split root-wm 'horizontal 'switch-wm))
    ((split-vertical-with-switch-wm)
     (do-split root-wm 'vertical 'switch-wm))
    ((split-horizontal-with-move-wm)
     (do-split root-wm 'horizontal 'move-wm))
    ((split-vertical-with-move-wm)
     (do-split root-wm 'vertical 'move-wm))

    ((create-switch-wm create-move-wm)
     (let ((current (root-wm:current-manager root-wm)))
       (create-new-manager root-wm
			   (if (eq? (car msg) 'create-switch-wm)
			       (manager-type switch)
			       (manager-type move))
			   (get-option-value (root-wm:options root-wm)
					     (if (eq? (car msg)
						      'create-switch-wm)
						 'default-switch-options
						 'default-move-options))
			   current)))

    ((create-workspace)
     (let* ((c (prompt (root-wm:dpy root-wm) #f
		       (get-option-value (root-wm:options root-wm)
					 'create-workspace-question)
		       '(#\s #\S #\m #\M) #f))
	    (type (if (or (eq? c #\s) (eq? c #\S))
		      'switch-wm 'move-wm)))
       (if c
	   (create-new-manager root-wm
			       (if (eq? type 'switch-wm)
				   (manager-type switch)
				   (manager-type move))
			       (get-option-value (root-wm:options root-wm)
						 (if (eq? type 'switch-wm)
						     'default-switch-options
						     'default-move-options))
			       (root-wm:initial-manager root-wm)))))

    ((kill-client)
     (let* ((dpy (root-wm:dpy root-wm))
	    (test (lambda (window)
		    (let* ((managers (root-wm-managers root-wm))
			   (l (filter (lambda (x) x)
				      (map (lambda (wm)
					     (client-of-window wm window))
					   managers)))
			   (time (second msg)))
		      (if (not (null? l))
			  (let ((window (client:window (car l))))
			    (mdisplay "kill-client: " window "\n")
			    (delete-window dpy window time)
			    #t)
			  #f)))))
       (let loop ((window (get-input-focus-window dpy)))
	 (if (and (window-exists? dpy window)
		  (not (test window)))
	     (loop (window-parent dpy window))))))

    ((manager-focused)
     (let ((manager (second msg)))
       ;; a split-wm should never be the current manager and the
       ;; workspace-wm too
       (if (and (not (eq? (manager-type split) (wm:type manager)))
		(not (eq? manager (root-wm:initial-manager root-wm))))
	   (set-root-wm:current-manager! root-wm manager))))
    ((root-drop)
     (let ((window (second msg))
	   (pointer-x (third msg))
	   (pointer-y (fourth msg)))
       (let ((manager (find-manager-at root-wm pointer-x pointer-y)))
	 (if manager
	     (wm-manage-window manager window)
	     (mdisplay "did not find a manager at " pointer-x ":"
		       pointer-y "\n")))))
    ((destroy-wm) ;; specially sent if second split-client terminates
     (let* ((wm (second msg))
	    (replacement? (if (> (length msg) 2) (third msg) #f))
	    (parent (manager-parent root-wm wm)))
       (if replacement?
	   (client-replace-window parent (wm:window wm) replacement?))
       ;; sync??
       (mdisplay "TEST\n")
       (destroy-wm wm)))
    ((execute)
     (let* ((cm (root-wm:current-manager root-wm))
	    (exec (prompt (root-wm:dpy root-wm) (wm:window cm)
			  (get-option-value (root-wm:options root-wm)
					    'execute-question)
			  #f exec-complete)))
       (if exec
	   (run (sh -c ,(string-append exec " &"))))))
    ((attach)
     (let* ((cm (root-wm:current-manager root-wm))
	    (all-names
	     (map cdr (filter (lambda (win.name)
				;; remove all that are below the current-wm
				(not (member (wm:window cm)
					     (window-path (wm:dpy cm)
							  (car win.name)))))
			      (get-all-window-names))))
	    (attach (prompt (root-wm:dpy root-wm) (wm:window cm)
			    (get-option-value (root-wm:options root-wm)
					      'attach-question)
			    all-names (finite-complete all-names)))
	    (window (find-window-by-name attach)))
       (if window
	   (wm-manage-window cm window))))

    ((quit)
     (let ((a (prompt (root-wm:dpy root-wm) #f
		      (get-option-value (root-wm:options root-wm)
					'quit-question)
		      '(#\y #\Y #\n #\N) #f)))
       (if (memq a '(#\y #\Y))
	   (exit #t))))
    (else (mdisplay "unknown root message: " msg "\n"))))

(define (exec-complete str pos)
  ;; TODO
  (cons str pos))

(define (finite-complete strings)
  (lambda (str pos)
    (let* ((s (substring str 0 pos))
	   (candidates
	    (filter (lambda (str)
		      (and (<= (string-length s) (string-length str))
			   (equal? s (substring str 0 (string-length s)))))
		    strings))
	   (common (common-substring candidates)))
      (cond
       ((null? candidates) (cons str pos))
       ((null? (cdr candidates))
	(cons (car candidates) ;; or insert ??
	      (string-length (car candidates))))
       ((not (or (equal? common "") (equal? common s)))
	(cons common ;; or insert??
	      (string-length common)))
       (else candidates)))))

(define (common-substring strings)
  (cond
   ((null? strings) "")
   ((null? (cdr strings)) (car strings))
   (else (let ((s (car strings))
	       (rec (common-substring (cdr strings))))
	   (letrec ((loop (lambda (i)
			    (if (and (< i (string-length s))
				     (< i (string-length rec))
				     (eq? (string-ref s i) (string-ref rec i)))
				(loop (+ i 1))
				(substring s 0 i)))))
	     (loop 0))))))

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

(define (add-manager! root-wm manager)
  (set-root-wm:managers! root-wm (cons manager
				       (root-wm:managers root-wm)))
  (spawn*
   (list 'root-wm-observer manager)
   (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)
	      (remove-manager! root-wm manager))
	     ((eq? (event-type focus-in) (any-event-type e))
	      (let ((mode (focus-change-event-mode e))
		    (detail (focus-change-event-detail e)))
;		(mdisplay "manager focus-event: " manager " "
;			  (focus-change-event-type e) " " detail "\n")
		(if (and (eq? mode (notify-mode normal))
			 (or (eq? detail (notify-detail inferior))
			     (eq? detail (notify-detail ancestor))
			     (eq? detail (notify-detail nonlinear))))
		    (send (root-wm:in-channel root-wm)
			  (list 'manager-focused manager))))
	      (loop))
	     (else (loop))))
	  (loop)))))))

(define (remove-manager! root-wm manager)
  (set-root-wm:managers! root-wm
			 (filter (lambda (m)
				   (not (eq? m manager)))
				 (root-wm:managers root-wm))))

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

(define (find-manager-at root-wm x y)
  ;; returns the upper-most manager at root-window's coords x y
  (let* ((dpy (root-wm:dpy root-wm))
	 (candidates
	  (filter (lambda (wm)
		    (point-in-rectangle? (root-rectangle dpy (wm:window wm))
					 x y))
		  (root-wm-managers root-wm))))
    (letrec ((loop (lambda (wm level rest)
		     (if (null? rest)
			 wm
			 (let* ((next (car rest))
				(next-level (window-level dpy
							  (wm:window next))))
			   (if (> next-level level)
			       (loop next next-level (cdr rest))
			       (loop wm level (cdr rest))))))))
      (loop #f -1 candidates))))

(define (get-manager-by-window root-wm window)
  (let ((l (filter (lambda (wm)
		     (equal? (wm:window wm) window))
		   (root-wm-managers root-wm))))
    (and (not (null? l))
	 (car l))))

(define (create-new-manager root-wm type options parent)
  (let* ((creator (cond
		   ((eq? type (manager-type split)) create-split-wm)
		   ((eq? type (manager-type switch)) create-switch-wm)
		   ((eq? type (manager-type move)) create-move-wm)))
	 (wm (creator (root-wm:in-channel root-wm) (root-wm:dpy root-wm)
		      (wm:window parent) options)))
    (wm-manage-window parent (wm:window wm))
    (add-manager! root-wm wm)
    (set-root-wm:current-manager! root-wm wm)
    wm))