scsh-conservatory
/
orion-wm
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

- pass all allocated option-values to titlebars and buttons 

- use special-options for the layout
This commit is contained in:
frese 2005-01-29 14:36:47 +00:00
parent e7b936149c
commit 6d99e01988
12 changed files with 191 additions and 138 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
src/button.scm
View File

@ -3,7 +3,7 @@
(up-colors colors '("gray" "white" "black" "black"))
(down-colors colors '("gray" "black" "white" "black"))
(font font "-*-helvetica-medium-r-normal-*-12-*-*-*-*-*-*-*")
(content sexp 'none) ;; string | 'kill | 'iconify | 'maximize
(initial-content sexp 'none) ;; string | 'kill | 'iconify | 'maximize
(type sexp 'standard) ;; 'standard | 'switch (remains pressed)
(initial-state sexp 'up) ;; 'up | 'down
)
@ -20,10 +20,8 @@
(lambda (b)
`(Button ,(button:window b))))
(define (create-button dpy parent colormap rect out-channel message options)
(let* ((options (create-options dpy colormap button-options-spec
options))
(bgcolor (first (get-option-value options 'up-colors)))
(define (create-button dpy parent rect out-channel message options)
(let* ((bgcolor (first (get-option-value options 'up-colors)))
(window (create-simple-window dpy parent
(rectangle:x rect)
(rectangle:y rect)
@ -46,7 +44,7 @@
(call-with-current-continuation
(lambda (exit)
(let ((state (get-option-value options 'initial-state))
(content (get-option-value options 'content)))
(content (get-option-value options 'initial-content)))
(let loop ()
(select*
(wrap (receive-rv in-channel)
@ -98,8 +96,7 @@
(list message (button-event-time e)
new-state)))))))))
(loop)))))
(free-gc dpy gc)
(free-options options #t)))))
(free-gc dpy gc)))))
abutton))
(define (destroy-button button)

8
src/config-specs.scm
View File

@ -1,8 +1,6 @@
;; *** configuration specification ***********************************
(define-options-spec split-options-spec
(orientation symbol 'horizontal) ;; horizontal | vertical
(aspect number 1/1)
(bar-width int 3)
(resize-step int 5)
(bar-style symbol 'raised) ;; raised | sunken | flat
@ -18,6 +16,9 @@
(titlebar-colors colors '("#aaaaaa" "#eeeeee" "#777777" "black"))
(titlebar-colors-focused colors '("#666699" "#aaaacc" "#333366" "#eeeeee"))
(titlebar-colors-active colors '("#9999aa" "#eeeeff" "#777788" "black"))
;; colors: (background top-left-border button-right-border font-img-color)
(titlebar-button-up-colors colors '("gray" "white" "black" "black"))
(titlebar-button-down-colors colors '("gray" "black" "white" "black"))
(titlebar-height int 18)
(titlebar-style symbol 'raised)
(font font "-*-helvetica-medium-r-normal-*-12-*-*-*-*-*-*-*")
@ -31,6 +32,8 @@
(define-options-spec move-options-spec
(titlebar-colors colors '("#aaaaaa" "#eeeeee" "#777777" "black"))
(titlebar-colors-focused colors '("#666699" "#aaaacc" "#333366" "#eeeeee"))
(titlebar-button-up-colors colors '("gray" "white" "black" "black"))
(titlebar-button-down-colors colors '("gray" "black" "white" "black"))
(titlebar-height int 18)
(titlebar-style symbol 'flat)
(font font "-*-helvetica-medium-r-normal-*-12-*-*-*-*-*-*-*")
@ -75,5 +78,6 @@
(user-bindings binding-list '(("F2" exec "xterm")))
(save-layout keys "F11")
(select-outer-manager keys "M-Home")
(default-cursor cursor xc-X-cursor)
)

8
src/config.scm
View File

@ -8,9 +8,12 @@
(map (lambda (c)
(get-manager-by-window root-wm
(client:window c)))
(wm-clients wm)))))
(wm-clients wm))))
(diff (if (wm:special-options wm)
(get-options-diff (wm:special-options wm))
'())))
(cons (manager-type-name (wm:type wm))
(cons (get-options-diff (wm:options wm))
(cons diff
(map loop children)))))))
(cddr (loop (root-wm:initial-manager root-wm)))))
@ -95,7 +98,6 @@
(cons 'move-options
(get 'move-options)))
(get 'root-options))))))))
;; TODO: maybe create a file with default-config-file in it
'())))
(define default-config-file

8
src/manager.scm
View File

@ -1,6 +1,6 @@
(define-record-type wm :wm
(make-wm type in-channel out-channel internal-out-channel
dpy window colormap options
dpy window colormap options special-options
clients current-client)
wm?
(type wm:type)
@ -11,6 +11,7 @@
(window wm:window)
(colormap wm:colormap)
(options wm:options)
(special-options wm:special-options)
(clients wm:clients set-wm:clients!)
(current-client wm:current-client set-wm:current-client!))
@ -31,7 +32,7 @@
((eq? type (manager-type switch)) "switch-wm")
((eq? type (manager-type move)) "move-wm")))
(define (create-wm dpy parent options children
(define (create-wm dpy parent options special-options children
type out-channel fun)
(let* ((wa (get-window-attributes dpy parent))
(main-window
@ -45,7 +46,7 @@
(internal-out-channel (make-channel))
(wm (make-wm type in-channel out-channel internal-out-channel
dpy main-window colormap
options '() #f)))
options special-options '() #f)))
(set-window-background-pixmap! dpy main-window parent-relative)
;; set properties ************************************************
@ -311,7 +312,6 @@
wm-state)))
;; transparent by default.
(set-window-background-pixmap! dpy client-window parent-relative)
;;(define-cursor dpy client-window xc-X-cursor) TODO
(if (memq 'click (get-option-value (wm:options wm) 'focus-policy))
;; Note: won't work recursively (manager in manager)

54
src/move-wm-pager.scm
View File

@ -1,6 +1,6 @@
(define-record-type move-wm-pager :move-wm-pager
(make-move-wm-pager dpy window wm in-channel options buttons-alist width
visible?)
visible? button-options)
move-wm-pager?
(dpy pager:dpy)
(window pager:window)
@ -10,9 +10,9 @@
;; client -> button
(buttons-alist pager:buttons-alist set-pager:buttons-alist!)
(width pager:width set-pager:width!)
(visible? pager:visible? set-pager:visible!))
(visible? pager:visible? set-pager:visible!)
(button-options pager:button-options))
;; TODO: hide buttons/keys
;; TODO: client-name <-> WM_ICON_NAME?
(define (repeat-infinitely fun) ;; -> utils
@ -35,9 +35,24 @@
bg-color))
(in-channel (make-channel))
(gc (create-gc dpy window '()))
(colormap (screen:default-colormap (display:default-screen dpy)))
(button-options
(let* ((colors (get-option-value options 'pager-colors))
(main-color (second colors))
(light (third colors))
(dark (fourth colors))
(font-color (fifth colors)))
(build-options
(options:dpy options) (options:colormap options)
button-options-spec
`((up-colors . ,(list main-color light dark font-color))
(down-colors . ,(list main-color dark light font-color))
(font . ,(get-option-value options 'font))
(initial-content . "<unnamed>")
(type . switch)
(initial-state . up)))))
(pager (make-move-wm-pager dpy window wm in-channel options '()
(rectangle:width rect) #t)))
(rectangle:width rect) #t
button-options)))
(spawn*
(list 'move-wm-pager wm window)
(lambda (release)
@ -99,32 +114,17 @@
((destroy-window-event? xevent) ;; mask?
;; destroy-button not necessary
(exit))))))))
(free-gc dpy gc)
;;(free-options options #t) ;; common with wm
))))
(free-gc dpy gc)))))
(map-window dpy window)
pager))
(define (pager-create-button pager client rect)
(let* ((dpy (pager:dpy pager))
(options (pager:options pager))
(colors (get-option options 'pager-colors))
(main-color (second colors))
(light (third colors))
(dark (fourth colors))
(font-color (fifth colors)))
(create-button (pager:dpy pager) (pager:window pager)
(screen:default-colormap (display:default-screen dpy))
rect (pager:in-channel pager)
(cons 'button client)
`(;; TODO: don't let every button allocate the
;; colors, and load the font.
(up-colors . ,(list main-color light dark font-color))
(down-colors . ,(list main-color dark light font-color))
(font . ,(get-option options 'font))
(content . ,(client-name (pager:dpy pager) client))
(type . switch)
(initial-state . up)))))
(let ((b (create-button (pager:dpy pager) (pager:window pager)
rect (pager:in-channel pager)
(cons 'button client)
(pager:button-options pager))))
(button-set-content! b (client-name (pager:dpy pager) client))
b))
(define (calc-pager-rect wm)
(let ((dpy (wm:dpy wm))

42
src/move-wm.scm
View File

@ -1,6 +1,6 @@
(define (create-move-wm out-channel dpy parent options
special-options . children)
(create-wm dpy parent options children
(create-wm dpy parent options #f children
(manager-type move)
out-channel
(lambda (wm in-channel)
@ -13,7 +13,21 @@
(gc (create-gc dpy window '()))
(pager-channel (make-channel))
(options (wm:options wm))
(pager (create-move-wm-pager wm pager-channel options)))
(pager (create-move-wm-pager wm pager-channel options))
(titlebar-options
(let ((get (lambda (id) (get-option-value options id))))
(build-options dpy (options:colormap options)
titlebar-options-spec
`((buttons . (kill maximize iconify))
(normal-colors . ,(get 'titlebar-colors))
(active-colors . ,(get 'titlebar-colors-focused))
(focused-colors . ,(get 'titlebar-colors-focused))
(border-style . ,(get 'titlebar-style))
(font . ,(get 'font))
(button-down-colors . ,(get
'titlebar-button-down-colors))
(button-up-colors . ,(get 'titlebar-button-up-colors))
(height . ,(get 'titlebar-height)))))))
(for-each (lambda (id)
(grab-shortcut dpy window
(get-option-value options id)
@ -26,11 +40,11 @@
(lambda (exit)
(let loop ()
(let ((msg (receive channel)))
(handle-message wm pager gc exit msg)
(handle-message wm pager gc titlebar-options exit msg)
(loop)))))
(free-gc dpy gc)))))
(define (handle-message wm pager gc exit msg)
(define (handle-message wm pager gc titlebar-options exit msg)
(let ((dpy (wm:dpy wm))
(window (wm:window wm)))
(case (car msg)
@ -60,7 +74,7 @@
((init-client)
(let ((client (second msg))
(maybe-rect (third msg)))
(init-client wm client maybe-rect)
(init-client wm client maybe-rect titlebar-options)
(pager-add-client pager client)
;; for (properly) transient windows this would not be necessary:
(wm-select-client wm client current-time)))
@ -241,11 +255,12 @@
(not (null? (enum-set->list (motif-wm-hints:decorations hints)))))))
(else #t)))
(define (init-client wm client maybe-rect)
(define (init-client wm client maybe-rect titlebar-options)
(let ((dpy (wm:dpy wm)))
(let* ((r (initial-client-rect wm client maybe-rect))
(channel (make-channel))
(titlebar (create-client-titlebar channel wm client))
(titlebar (create-client-titlebar channel wm client
titlebar-options))
(resizer (create-resizer wm client))
(options (wm:options wm)))
(set-client:data! client (make-client-data titlebar resizer))
@ -306,19 +321,10 @@
(map-window dpy (client:window client)))
(map-window dpy (client:client-window client)))))
(define (create-client-titlebar channel wm client)
(define (create-client-titlebar channel wm client titlebar-options)
(let ((options (wm:options wm)))
(create-titlebar channel (wm:dpy wm) (client:client-window client)
(wm:colormap wm)
(list (cons 'buttons '(kill maximize iconify))
(cons 'normal-colors
(get-option options 'titlebar-colors))
(cons 'active-colors
(get-option options 'titlebar-colors-focused))
(cons 'focused-colors
(get-option options 'titlebar-colors-focused))
(cons 'border-style
(get-option options 'titlebar-style))))))
titlebar-options)))
(define (deinit-client wm client)
(let ((dpy (wm:dpy wm)))

11
src/packages.scm
View File

@ -6,7 +6,8 @@
make-sync-point sync-point-release sync-point-wait
send-message+wait
create-options free-options
options:dpy options:colormap
create-options free-options build-options
get-option-value get-option set-option! get-options
((define-options-spec) :syntax) options-spec-union
get-options-diff spec-defaults
@ -55,7 +56,8 @@
(define-structure titlebar
(export create-titlebar destroy-titlebar titlebar? titlebar:window
map-titlebar unmap-titlebar move-resize-titlebar
set-titlebar-state! set-titlebar-title! set-titlebar-title+state!)
set-titlebar-state! set-titlebar-title! set-titlebar-title+state!
titlebar-options-spec)
(open scheme define-record-types threads list-lib
rendezvous-channels rendezvous
xlib
@ -74,7 +76,8 @@
map-button unmap-button
move-resize-button
button-get-state button-set-state!
button-set-content!)
button-set-content!
button-options-spec)
(open scheme list-lib rendezvous-channels
rendezvous placeholders
define-record-types
@ -116,7 +119,7 @@
(define-structure manager
(export wm? wm:type wm:dpy wm:window wm:colormap wm:options wm:out-channel
wm:internal-out-channel
wm:internal-out-channel wm:special-options
(manager-type :syntax) manager-types manager-type-name
create-wm destroy-wm
wm-clients wm-current-client

5
src/root-manager.scm
View File

@ -49,6 +49,7 @@
(make-sync-point) cross-ref-hack
split-options switch-options move-options))
)
(define-cursor dpy window (get-option-value options 'default-cursor))
(set-root-wm:current-manager! root-wm initial-manager)
(add-manager! root-wm initial-manager)
@ -181,8 +182,8 @@
(splitter
(create-split-wm in-channel dpy
(window-parent dpy (wm:window current))
(list (cons 'orientation orientation))
(root-wm:split-options root-wm)))
(root-wm:split-options root-wm)
(list (cons 'orientation orientation))))
(first current)
(creator (if (eq? new-wm 'switch-wm)
create-switch-wm

43
src/split-wm.scm
View File

@ -10,26 +10,25 @@
(define (create-split-wm external-in-channel dpy parent options
special-options . children)
(create-wm dpy parent options children
(manager-type split)
external-in-channel
(lambda (wm in-channel)
(init-split-wm wm in-channel
(create-options dpy #f
split-special-options-spec
special-options))
wm)))
(let ((special-options (create-options dpy #f
split-special-options-spec
special-options)))
(create-wm dpy parent options special-options children
(manager-type split)
external-in-channel
(lambda (wm in-channel)
(init-split-wm wm in-channel)
wm))))
(define-record-type split-data :split-data
(make-split-data resizer first-client second-client options)
(make-split-data resizer first-client second-client)
split-data?
(resizer data:resizer set-data:resizer!)
(first-client data:first-client set-data:first-client!)
(second-client data:second-client set-data:second-client!)
(options data:options))
(second-client data:second-client set-data:second-client!))
(define (init-split-wm wm channel options)
(let* ((data (make-split-data #f #f #f options))
(define (init-split-wm wm channel)
(let* ((data (make-split-data #f #f #f))
(resizer (create-resizer wm data)))
(set-data:resizer! data resizer)
(spawn* (list 'split-wm wm)
@ -42,7 +41,7 @@
(let ((msg (receive channel)))
(handle-message wm channel data exit msg)
(loop)))))
(free-options options #t)))))
(free-options (wm:special-options wm) #t)))))
(define (handle-message wm channel data exit msg)
(let ((dpy (wm:dpy wm)))
@ -81,7 +80,7 @@
(map-window dpy (client:window client))
(map-window dpy (client:client-window client))
(let ((opt (if (eq? (get-option-value (data:options data)
(let ((opt (if (eq? (get-option-value (wm:special-options wm)
'orientation)
'horizontal)
(if first? 'select-right 'select-left)
@ -143,9 +142,10 @@
(define (calc-rectangles wm data)
(let* ((options (wm:options wm))
(special-options (wm:special-options wm))
(bar-width (get-option-value options 'bar-width))
(orientation (get-option-value (data:options data) 'orientation))
(aspect (get-option-value (data:options data) 'aspect))
(orientation (get-option-value special-options 'orientation))
(aspect (get-option-value special-options 'aspect))
(r (clip-rectangle (wm:dpy wm) (wm:window wm))))
(if (eq? orientation 'horizontal)
(let* ((r1 (make-rectangle 0 0
@ -212,6 +212,7 @@
'horizontal)
xc-sb-h-double-arrow
xc-sb-v-double-arrow))))
;; TODO: v-cursor doesn't work anymore?!
(set-window-cursor! dpy window cursor)
(spawn*
(list 'split-resizer wm)
@ -278,7 +279,7 @@
(r1 (first rects)) (r2 (third rects))
(aspect
(if (eq? 'horizontal
(get-option-value (data:options data)
(get-option-value (wm:special-options wm)
'orientation))
(if (= 0 (- (rectangle:width r2) dx))
0
@ -290,7 +291,7 @@
(- (rectangle:height r2) dy))))))
(if (> aspect 0)
(begin
(set-option! (data:options data) 'aspect aspect)
(set-option! (wm:special-options wm) 'aspect aspect)
(send (wm:internal-out-channel wm)
'(fit-windows))
)))))
@ -298,7 +299,7 @@
(lambda (start-rect dx dy)
(let ((width (rectangle:width start-rect))
(height (rectangle:height start-rect)))
(if (eq? (get-option-value (data:options data)
(if (eq? (get-option-value (wm:special-options wm)
'orientation)
'horizontal)
(make-rectangle (+ (rectangle:x start-rect) dx)

68
src/switch-wm.scm
View File

@ -1,6 +1,6 @@
(define (create-switch-wm out-channel dpy parent options
special-options . children)
(create-wm dpy parent options children
(create-wm dpy parent options #f children
(manager-type switch)
out-channel
(lambda (wm in-channel)
@ -8,11 +8,12 @@
wm)))
(define-record-type switch-wm-data :switch-wm-data
(make-switch-wm-data titlebars empty-titlebar last-focused)
(make-switch-wm-data titlebars empty-titlebar last-focused titlebar-options)
switch-wm-data?
(titlebars data:titlebars set-data:titlebars!)
(empty-titlebar data:empty-titlebar)
(last-focused data:last-focused set-data:last-focused!))
(last-focused data:last-focused set-data:last-focused!)
(titlebar-options data:titlebar-options))
;; only for switch-wm's, but maybe we will need that for all...
(define (last-focused-client wm data)
@ -31,8 +32,23 @@
(window (wm:window wm))
(options (wm:options wm))
(gc (create-gc dpy window '()))
(titlebar-options
(let ((get (lambda (id) (get-option-value options id))))
(build-options dpy (options:colormap options)
titlebar-options-spec
`((buttons . (kill))
(normal-colors . ,(get 'titlebar-colors))
(active-colors . ,(get 'titlebar-colors-active))
(focused-colors . ,(get 'titlebar-colors-focused))
(border-style . ,(get 'titlebar-style))
(font . ,(get 'font))
(button-down-colors . ,(get
'titlebar-button-down-colors))
(button-up-colors . ,(get 'titlebar-button-up-colors))
(height . ,(get 'titlebar-height))))))
(empty-titlebar (create-empty-titlebar wm))
(data (make-switch-wm-data '() empty-titlebar (cons #f #f))))
(data (make-switch-wm-data '() empty-titlebar (cons #f #f)
titlebar-options)))
(update-titlebars wm data)
(for-each (lambda (id)
@ -195,7 +211,7 @@
(let ((dpy (wm:dpy wm))
(options (wm:options wm)))
(let* ((channel (make-channel))
(titlebar (create-client-titlebar channel wm client)))
(titlebar (create-client-titlebar channel wm data client)))
(set-data:titlebars! data (append (data:titlebars data)
(list (cons client titlebar))))
(set-titlebar-title! titlebar (client-name dpy client))
@ -246,34 +262,26 @@
(map-window dpy (client:window client)))
(wm-select-client wm client current-time))))
(define (create-client-titlebar channel wm client)
(let ((options (wm:options wm)))
(create-titlebar channel (wm:dpy wm) (wm:window wm)
(wm:colormap wm)
(list (cons 'buttons '(kill))
(cons 'normal-colors
(get-option options 'titlebar-colors))
(cons 'active-colors
(get-option options 'titlebar-colors-active))
(cons 'focused-colors
(get-option options 'titlebar-colors-focused))
(cons 'border-style
(get-option options 'titlebar-style))))))
(define (create-client-titlebar channel wm data client)
(create-titlebar channel (wm:dpy wm) (wm:window wm)
(data:titlebar-options data)))
(define (create-empty-titlebar wm)
(let* ((options (wm:options wm))
(tb
(create-titlebar #f (wm:dpy wm) (wm:window wm) (wm:colormap wm)
(list
(cons 'normal-colors
(get-option options 'titlebar-colors))
(cons 'active-colors
(get-option options 'titlebar-colors-active))
(cons 'focused-colors
(get-option options 'titlebar-colors-focused))
(cons 'border-style
(get-option options 'titlebar-style))
(cons 'buttons '())))))
(get (lambda (id) (get-option-value options id)))
(tb-options
(build-options (options:dpy options) (options:colormap options)
titlebar-options-spec
`((buttons . ())
(normal-colors . ,(get 'titlebar-colors))
(active-colors . ,(get 'titlebar-colors-active))
(focused-colors . ,(get 'titlebar-colors-focused))
(border-style . ,(get 'titlebar-style))
(font . ,(get 'font))
(button-down-colors . ,(get 'titlebar-button-down-colors))
(button-up-colors . ,(get 'titlebar-button-up-colors))
(height . ,(get 'titlebar-height)))))
(tb (create-titlebar #f (wm:dpy wm) (wm:window wm) tb-options)))
(set-titlebar-title! tb "<empty frame>")
tb))

39
src/titlebar.scm
View File

@ -5,7 +5,10 @@
(focused-colors colors '("#666699" "#aaaacc" "#333366" "#eeeeee"))
(border-style symbol 'raised) ; flat | sunken
(font font "-*-helvetica-medium-r-normal-*-12-*-*-*-*-*-*-*")
(button-border-style symbol 'flat) ; none | raised
;; colors: (background top-left-border button-right-border font-img-color)
(button-up-colors colors '("gray" "white" "black" "black"))
(button-down-colors colors '("gray" "black" "white" "black"))
(height number 18)
)
(define-record-type titlebar :titlebar
@ -17,23 +20,34 @@
(title titlebar:title set-titlebar:title!)
(state titlebar:state set-titlebar:state!)) ;; active | focused | normal
(define (create-titlebar out-channel dpy parent colormap options-def)
(define (create-titlebar out-channel dpy parent options)
(let* ((in-channel (make-channel))
(height (get-option-value options 'height)) ;; TODO: height button-size
(window (create-simple-window dpy parent
0 0 1 1 0
(black-pixel dpy) (black-pixel dpy)))
(options (create-options dpy colormap titlebar-options-spec
options-def))
(gc (create-gc dpy window '()))
(tb (make-titlebar in-channel dpy window "test" 'normal))
(button-channel out-channel)
(button-size 13) ;; TODO has to be calculated from window-height
(button-size (- height 4))
(button-options
(build-options
(options:dpy options) (options:colormap options)
button-options-spec
`((up-colors . ,(get-option-value options 'button-up-colors))
(down-colors . ,(get-option-value options 'button-down-colors))
(font . ,(get-option-value options 'font))
(initial-content . "<unnamed>")
(type . standard)
(initial-state . up))))
;; TODO: border-style -> colors
(buttons (map (lambda (id)
(create-button dpy window colormap
(make-rectangle 0 0 1 1)
button-channel id
;; TODO: border-style -> colors
`((content . ,id))))
(let ((b (create-button dpy window
(make-rectangle 0 0 1 1)
button-channel id
button-options)))
(button-set-content! b id)
b))
(get-option-value options 'buttons)))
;; icon-window...
)
@ -89,9 +103,7 @@
(draw-titlebar tb options gc))))))))
)
(loop))))))
(free-gc dpy gc)
;; colormap might not exists anymore...
(free-options options #t)))
(free-gc dpy gc)))
tb))
(define (destroy-titlebar tb)
@ -103,6 +115,7 @@
(define (unmap-titlebar tb)
(unmap-window (titlebar:dpy tb) (titlebar:window tb)))
;; TODO: height must stay the same, or change buttons
(define (move-resize-titlebar tb rect)
(move-resize-window* (titlebar:dpy tb) (titlebar:window tb) rect))

30
src/utils.scm
View File

@ -80,6 +80,18 @@
(type-alist options:type-alist set-options:type-alist!)
(default-alist options:default-alist))
;; create new options structure out of existing (allocated) values
;; TODO: remember which options were specified and don't have to be
;; freed, and those that are allocated later.
;; TODO: the options are taken out of the spec, but that mustn't match
;; the given values
(define (build-options dpy colormap spec option-values)
(make-options dpy colormap
(options-spec-defaults spec)
option-values ;; TODO check this alist
(options-spec-types spec)
(options-spec-defaults spec)))
(define (create-options dpy colormap spec options)
(let ((option-alist (map (lambda (s)
(let* ((n (first s))
@ -87,12 +99,8 @@
(cons n (if op (cdr op) (third s)))))
spec))
(value-alist '())
(type-alist (map (lambda (s)
(cons (first s) (second s)))
spec))
(default-alist (map (lambda (s)
(cons (first s) (third s)))
spec)))
(type-alist (options-spec-types spec))
(default-alist (options-spec-defaults spec)))
(for-each (lambda (name.option name.type)
(allocate-option dpy colormap (car name.option)
(cdr name.type) (cdr name.option)))
@ -184,6 +192,16 @@
(define (options-spec-union spec1 spec2)
(append spec1 spec2))
(define (options-spec-types spec)
(map (lambda (s)
(cons (first s) (second s)))
spec))
(define (options-spec-defaults spec)
(map (lambda (s)
(cons (first s) (third s)))
spec))
(define (allocate-option dpy colormap name type def)
(let ((check (lambda (value pred)
(if (not (pred value))