added kill-client shortcut

added workspace-manager
added default options for new split, switch and move managers
added quit shortcut
added special message for automated split destruction
fixed current-manager detection

src/root-manager.scm

@@ -1,4 +1,6 @@
 (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")
@@ -7,21 +9,37 @@
   (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:")
+  (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 in-channel options)
+  (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))
+  (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))
@@ -30,18 +48,16 @@
 				  root-options-spec options))
 	 (children (window-children dpy window))
 	 (in-channel (make-channel))
-	 (root-wm (make-root-wm dpy '() #f in-channel options))
+	 ;; TODO: workspace-options...
-	 (initial-manager (create-move-wm in-channel dpy window '())))
+	 (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)))
+	 )
     (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))
@@ -49,11 +65,16 @@
 		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))
+		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 ()
@@ -64,7 +85,41 @@
 		       (wrap (receive-rv in-channel)
 			     (lambda (msg)
 			       (handle-message root-wm exit msg))))
-	    (loop))))))))
+		      (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))
@@ -84,18 +139,23 @@
   (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
+	 (splitter
+	  (create-split-wm in-channel dpy
 			   (window-parent dpy (wm:window current))
-				    ;; TODO other options
+			   (cons (cons 'orientation orientation)
-				    (list (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)
-			  ;; TODO options
+			  (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)
@@ -132,22 +192,63 @@
      (do-split root-wm 'vertical 'move-wm))
 
     ((create-switch-wm create-move-wm)
-     (let* ((current (root-wm:current-manager root-wm))
+     (let ((current (root-wm:current-manager root-wm)))
-	    (create (if (eq? (car msg) 'create-switch-wm)
+       (create-new-manager root-wm
-			create-switch-wm
+			   (if (eq? (car msg) 'create-switch-wm)
-			create-move-wm))
+			       (manager-type switch)
-	    (dpy (root-wm:dpy root-wm))
+			       (manager-type move))
-	    (in-channel (root-wm:in-channel root-wm))
+			   (get-option-value (root-wm:options root-wm)
-	    (new (create in-channel dpy (wm:window current)
+					     (if (eq? (car msg)
-			 '())) ;; TODO: options
+						      'create-switch-wm)
-	    )
+						 'default-switch-options
-       (add-manager! root-wm new)
+						 'default-move-options))
-       (wm-manage-window current (wm:window new))))
+			   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
+       ;; a split-wm should never be the current manager and the
-       (if (not (eq? (manager-type split) (wm:type manager)))
+       ;; workspace-wm too
+       (mdisplay "new current manager: " manager "\n")
+       (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))
@@ -158,6 +259,15 @@
 	     (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)
@@ -183,6 +293,13 @@
        (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)
@@ -228,6 +345,7 @@
   (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)
@@ -238,17 +356,29 @@
 	(let loop ()
 	  (let ((e (receive event-channel)))
 	    (cond
-	     ((destroy-window-event? e) #t)
+	     ((destroy-window-event? e)
-	     ((focus-change-event? e)
+	      (remove-manager! root-wm manager))
-	      ;; look at mode/detail ??
+	     ((eq? (event-type focus-in) (any-event-type e))
-	      (if (window-contains-focus? (root-wm:dpy root-wm)
+	      (let ((mode (focus-change-event-mode e))
-					  (wm:window manager))
+		    (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)))
+			  (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))))
@@ -256,7 +386,7 @@
 	#f
 	(let ((l (filter (lambda (m)
 			   (equal? (wm:window m) parent-window))
-			 (root-wm:managers root-wm))))
+			 (root-wm-managers root-wm))))
 	  (if (null? l)
 	      (loop (window-parent (root-wm:dpy root-wm)
 				   parent-window))
@@ -269,7 +399,7 @@
 	  (filter (lambda (wm)
 		    (point-in-rectangle? (root-rectangle dpy (wm:window wm))
 					 x y))
-		  (root-wm:managers root-wm))))
+		  (root-wm-managers root-wm))))
     (letrec ((loop (lambda (wm level rest)
 		     (if (null? rest)
 			 wm
@@ -280,3 +410,22 @@
 			       (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))