orion-wm/src/root-manager.scm

(define-options-spec root-options-spec
  (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 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:")
  )

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

(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))
	 (root-wm (make-root-wm dpy '() #f in-channel options))
	 (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)

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

    (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 (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))
	 (in-channel (root-wm:in-channel root-wm))
	 (splitter (create-split-wm in-channel dpy
				    (window-parent dpy (wm:window current))
				    ;; TODO other options
				    (list (cons 'orientation orientation))))
	 (first current)
	 (creator (if (eq? new-wm 'switch-wm)
		      create-switch-wm
		      create-move-wm))
	 (second (creator in-channel dpy (wm:window splitter)
			  ;; TODO 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 (if (eq? (car msg) 'create-switch-wm)
			create-switch-wm
			create-move-wm))
	    (dpy (root-wm:dpy root-wm))
	    (in-channel (root-wm:in-channel root-wm))
	    (new (create in-channel dpy (wm:window current)
			 '())) ;; TODO: options
	    )
       (add-manager! root-wm new)
       (wm-manage-window current (wm:window new))))

    ((manager-focused)
     (let ((manager (second msg)))
       ;; a split-wm should never be the current manager
       (if (not (eq? (manager-type split) (wm:type manager)))
	   (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")))))
    ((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))))
    
    (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*
   (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))))))

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