111 lines
3.2 KiB
Scheme
111 lines
3.2 KiB
Scheme
|
;; *** layout ********************************************************
|
||
|
|
|
||
|
|
(define (get-root-layout root-wm)
|
||
|
|
(letrec ((loop (lambda (wm)
|
||
|
|
(let ((children
|
||
|
|
(filter
|
||
|
|
(lambda (x) x)
|
||
|
|
(map (lambda (c)
|
||
|
|
(get-manager-by-window root-wm
|
||
|
|
(client:window c)))
|
||
|
|
(wm-clients wm)))))
|
||
|
|
(cons (manager-type-name (wm:type wm))
|
||
|
|
(cons (get-options-diff (wm:options wm))
|
||
|
|
(map loop children)))))))
|
||
|
|
(cddr (loop (root-wm:initial-manager root-wm)))))
|
||
|
|
|
||
|
|
(define (create-root-layout root-wm layout)
|
||
|
|
(letrec ((loop (lambda (parent spec)
|
||
|
|
(let ((type (car spec))
|
||
|
|
(options (cadr spec))
|
||
|
|
(more (cddr spec)))
|
||
|
|
(let* ((type2 (cond
|
||
|
|
((eq? 'split type) (manager-type split))
|
||
|
|
((eq? 'switch type) (manager-type switch))
|
||
|
|
((eq? 'move type) (manager-type move))))
|
||
|
|
;; else error ?!
|
||
|
|
(def-opt
|
||
|
|
(get-option-value
|
||
|
|
(root-wm:options root-wm)
|
||
|
|
(cond
|
||
|
|
((eq? 'split type) 'default-split-options)
|
||
|
|
((eq? 'switch type) 'default-switch-options)
|
||
|
|
((eq? 'move type) 'default-move-options))))
|
||
|
|
|
||
|
|
(wm (create-new-manager root-wm type2
|
||
|
|
(append options def-opt)
|
||
|
|
parent)))
|
||
|
|
(for-each (lambda (spec)
|
||
|
|
(loop wm spec))
|
||
|
|
more))))))
|
||
|
|
(for-each (lambda (spec)
|
||
|
|
(loop (root-wm:initial-manager root-wm) spec))
|
||
|
|
layout)))
|
||
|
|
|
||
|
|
(define (layout-filename dpy)
|
||
|
|
(let ((dir (resolve-tilde-file-name "~/.orion-wm")))
|
||
|
|
(if (not (file-exists? dir))
|
||
|
|
(create-directory dir))
|
||
|
|
(string-append dir "/layout-" (display:name dpy))))
|
||
|
|
|
||
|
|
(define (backup-layout root-wm)
|
||
|
|
(call-with-output-file (layout-filename (root-wm:dpy root-wm))
|
||
|
|
(lambda (p)
|
||
|
|
(for-each (lambda (spec)
|
||
|
|
(write spec p))
|
||
|
|
(get-root-layout root-wm)))))
|
||
|
|
|
||
|
|
(define (restore-layout root-wm)
|
||
|
|
(let ((fn (layout-filename (root-wm:dpy root-wm))))
|
||
|
|
(if (file-exists? fn)
|
||
|
|
(call-with-input-file fn
|
||
|
|
(lambda (p)
|
||
|
|
(create-root-layout root-wm
|
||
|
|
(port->sexp-list p))))
|
||
|
|
'())))
|
||
|
|
|
||
|
|
;; *** configuration *************************************************
|
||
|
|
|
||
|
|
(define (config-filename dpy)
|
||
|
|
(let ((dir (resolve-tilde-file-name "~/.orion-wm")))
|
||
|
|
(if (not (file-exists? dir))
|
||
|
|
(create-directory dir))
|
||
|
|
(string-append dir "/config-" (display:name dpy))))
|
||
|
|
|
||
|
|
(define (load-configuration dpy)
|
||
|
|
(let ((filename (config-filename dpy)))
|
||
|
|
(if (file-exists? filename)
|
||
|
|
(begin
|
||
|
|
;; exceptions ??
|
||
|
|
(for-each (lambda (exp)
|
||
|
|
(eval exp (interaction-environment)))
|
||
|
|
`( (define root-options '())
|
||
|
|
(define split-options '())
|
||
|
|
(define switch-options '())
|
||
|
|
(define move-options '())
|
||
|
|
(define-syntax define-option
|
||
|
|
(syntax-rules
|
||
|
|
()
|
||
|
|
((define-option list name value)
|
||
|
|
(set! list (cons (cons (quote name) value)
|
||
|
|
list)))))
|
||
|
|
(define-syntax define-options
|
||
|
|
(syntax-rules
|
||
|
|
()
|
||
|
|
((define-options l (name value) ...)
|
||
|
|
(set! l (append (list (cons (quote name) value)
|
||
|
|
...)
|
||
|
|
l)))))
|
||
|
|
;; define-options ...
|
||
|
|
(load ,filename)
|
||
|
|
(set! root-options
|
||
|
|
(append (list (cons 'default-split-options
|
||
|
|
split-options)
|
||
|
|
(cons 'default-switch-options
|
||
|
|
switch-options)
|
||
|
|
(cons 'default-move-options
|
||
|
|
move-options))
|
||
|
|
root-options)) ))
|
||
|
|
(eval 'root-options (interaction-environment)))
|
||
|
|
'())))
|