added root-wm options

added shortcuts for splitting, execute commands and attach windows

src/root-manager.scm

@@ -1,16 +1,36 @@
+(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)
+  (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))
+  (in-channel root-wm:in-channel)
+  (options root-wm:options))
 
-(define (create-root-wm dpy)
+(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))
+	 (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)
@@ -22,10 +42,14 @@
 		(wm-manage-window initial-manager window))
 	      children)
 
-    (grab-shortcut dpy window (string->keys dpy "M-k h") ;; -> options!
+    (for-each (lambda (name)
-		   'split-horizontal in-channel #t)
+		(grab-shortcut dpy window (get-option-value options name)
-    (grab-shortcut dpy window (string->keys dpy "M-k v")
+			       name in-channel #t))
-		   'split-vertical 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)
@@ -56,40 +80,75 @@
 			#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* ((current (root-wm:current-manager root-wm))
+     (let ((c (prompt (root-wm:dpy root-wm) #f
-	    (parent (manager-parent root-wm current)) ;; #f if root
+		      (get-option-value (root-wm:options root-wm)
-	    (dpy (wm:dpy current))
+					'split-question)
-	    (in-channel (root-wm:in-channel root-wm))
+		      '(#\s #\S #\m #\M) #f)))
-	    (orientation (if (eq? 'split-vertical (car msg))
+       (if c
-			     'vertical 'horizontal))
+	   (do-split root-wm
-	    (splitter (create-split-wm in-channel dpy
+		     (if (eq? (car msg) 'split-vertical)
-				       (window-parent dpy (wm:window current))
+			 'vertical 'horizontal)
-				       ;; TODO other options
+		     (if (or (eq? c #\s) (eq? c #\S))
-				       (list (cons 'orientation orientation))))
+			 'switch-wm
-	    (first current)
+			 'move-wm)))))
-	    ;; TODO: ask for second manager
-	    (second (create-switch-wm 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)
+    ((split-horizontal-with-switch-wm)
-       (add-manager! root-wm second)))
+     (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))))
+	   (set-root-wm:current-manager! root-wm manager))))
     ((root-drop)
      (let ((window (second msg))
 	   (pointer-x (third msg))
@@ -99,8 +158,70 @@
 	     (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)