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
This commit is contained in:
frese
parent
74d9ecbb9c
commit
3ecd9478ee
|
|
@ -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))
|
||||
(initial-manager (create-move-wm in-channel dpy window '())))
|
||||
;; 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)))
|
||||
)
|
||||
(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,22 +65,61 @@
|
|||
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))
|
||||
|
||||
(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))))))))
|
||||
(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))
|
||||
|
|
@ -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
|
||||
(window-parent dpy (wm:window current))
|
||||
;; TODO other options
|
||||
(list (cons 'orientation orientation))))
|
||||
(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)
|
||||
;; 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))
|
||||
(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))))
|
||||
(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
|
||||
(if (not (eq? (manager-type split) (wm:type manager)))
|
||||
;; a split-wm should never be the current manager and the
|
||||
;; 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)
|
||||
|
|
@ -182,7 +292,14 @@
|
|||
(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)
|
||||
|
|
@ -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)
|
||||
((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)))
|
||||
((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))))
|
||||
|
|
@ -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))
|
||||
|
|
|
|||
Loading…
Reference in New Issue