added root-wm options
added shortcuts for splitting, execute commands and attach windows
This commit is contained in:
frese
parent
c702b5fa52
commit
aa32a7e69d
|
|
@ -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!
|
||||
'split-horizontal in-channel #t)
|
||||
(grab-shortcut dpy window (string->keys dpy "M-k v")
|
||||
'split-vertical in-channel #t)
|
||||
(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)
|
||||
|
|
@ -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))
|
||||
(parent (manager-parent root-wm current)) ;; #f if root
|
||||
(dpy (wm:dpy current))
|
||||
(in-channel (root-wm:in-channel root-wm))
|
||||
(orientation (if (eq? 'split-vertical (car msg))
|
||||
'vertical 'horizontal))
|
||||
(splitter (create-split-wm in-channel dpy
|
||||
(window-parent dpy (wm:window current))
|
||||
;; TODO other options
|
||||
(list (cons 'orientation orientation))))
|
||||
(first current)
|
||||
;; 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))
|
||||
(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)))))
|
||||
|
||||
(add-manager! root-wm splitter)
|
||||
(add-manager! root-wm second)))
|
||||
((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))))
|
||||
(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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue