1
;; custom.jl -- Emacs-like ``customizing'' (but more simple)
2
;; $Id: custom.jl,v 1.61 2001/04/11 21:48:37 jsh Exp $
4
;; Copyright (C) 1999 John Harper <john@dcs.warwick.ac.uk>
6
;; This file is part of sawmill.
8
;; sawmill is free software; you can redistribute it and/or modify it
9
;; under the terms of the GNU General Public License as published by
10
;; the Free Software Foundation; either version 2, or (at your option)
13
;; sawmill is distributed in the hope that it will be useful, but
14
;; WITHOUT ANY WARRANTY; without even the implied warranty of
15
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16
;; GNU General Public License for more details.
18
;; You should have received a copy of the GNU General Public License
19
;; along with sawmill; see the file COPYING. If not, write to
20
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
22
(define-structure sawfish.wm.custom
26
custom-group-option-alist
29
custom-declare-variable
34
custom-set-group-property
35
custom-get-group-property
41
custom-set-typed-variable
44
variable-default-value
50
define-custom-serializer
51
define-custom-deserializer
52
custom-load-user-file)
65
(define-structure-alias custom sawfish.wm.custom)
67
;; list associating groups with the list of variables in that group
68
(define custom-groups (list 'root "Sawfish"))
70
(defvar custom-user-file "~/.sawfish/custom"
71
"File used to store user's configuration settings.")
73
(defvar custom-default-file (expand-file-name "sawfish/wm/custom-defaults.jl"
74
sawfish-lisp-lib-directory)
75
"Lisp library storing default customization settings.")
77
(define custom-quoted-keys
78
'(:group :require :type :options :range :depends :user-level
79
:layout :widget-flags)
80
"defcustom keys whose values are quoted by the macro expansion.")
82
(define custom-option-alist '((:group . custom-group)
83
(:require . custom-require)
85
(:type* . custom-type)
86
(:options . custom-options)
87
(:depends . custom-depends)
88
(:user-level . custom-user-level)
91
(:widget . custom-widget)
92
(:after-set . custom-after-set)
93
(:before-set . custom-before-set)
94
(:range . custom-range)
95
(:widget-flags . custom-widget-flags)))
97
(define custom-group-option-alist '((:layout . custom-group-layout)
98
(:require . custom-group-require)))
100
;; hash group names (lists of symbols) to alist of options
101
(define custom-group-table (make-table equal-hash equal))
104
;;; defining custom variables and groups
106
(defmacro defcustom (symbol value doc #!rest keys)
107
"Define a new customization variable SYMBOL which initially has value
108
VALUE (unless SYMBOL is already bound, in which case its value is not
109
altered), and documentations string DOC.
111
KEYS is a property-list containing any of the following:
118
:user-level LEVEL novice, intermediate, expert
119
:range (MIN . MAX) for `number' type
126
TYPE may be `boolean', `number', `string', `symbol', `file-name',
127
`program-name', `font', `color'.
129
Note that the values of the `:group', `:require', `:type', `:options',
130
`:depends', `:user-level' and `:range' keys are not evaluated. All
131
other key values are evaluated.
133
Each defcustom'd symbol may have several special properties
135
custom-set (FUNCTION SYMBOL VALUE)
136
custom-get (FUNCTION SYMBOL)
137
custom-widget (FUNCTION SYMBOL)
139
These functions are used while constructing and responding to the
140
customisation dialog. If not set in the symbol itself they may be
141
inherited from the plist of the type of the variable.
143
custom-set and custom-get may be used to translate data types to the
144
string representation required by some widget types. custom-widget may
145
construct the widget definition passed to the ui backend."
147
(let* ((cell (memq ':tooltip keys))
148
(tooltip (cadr cell))
151
(setq keys (delq (car cell) (delq (cadr cell) keys))))
152
`(let ((,tem ,value))
153
(defvar ,symbol ,tem ,(if tooltip (concat doc "\n\n" tooltip) doc))
154
(custom-declare-variable ',symbol ,(custom-quote-keys keys) ,tem))))
156
(defmacro defgroup (symbol doc #!rest keys)
157
"Declare a new custom group called SYMBOL, with English name DOC. The
158
property list KEYS may contain the following key-value items:
163
Note that the value of the `:group' key is not evaluated."
165
`(custom-declare-group ',symbol ,doc ,(custom-quote-keys keys)))
167
(define (custom-declare-variable symbol keys #!optional default-value)
170
(setq prop (cdr (assq (car keys) custom-option-alist)))
171
(setq keys (cdr keys))
173
(put symbol prop (car keys)))
174
(setq keys (cdr keys)))
175
(custom-add-to-group symbol (get symbol 'custom-group))
176
(setq type (get symbol 'custom-type))
177
(when (eq (car type) 'set)
178
;; backwards compatibility
179
(put symbol 'custom-options (cdr type))
181
(put symbol 'custom-type type))
182
(when (and type (symbolp type))
183
(when (and (not (get symbol 'custom-get)) (get type 'custom-get))
184
(put symbol 'custom-get (get type 'custom-get)))
185
(when (and (not (get symbol 'custom-set)) (get type 'custom-set))
186
(put symbol 'custom-set (get type 'custom-set)))
187
(when (and (not (get symbol 'custom-widget)) (get type 'custom-widget))
188
(put symbol 'custom-widget (get type 'custom-widget))))
189
(put symbol 'custom-default-value default-value)
192
(define (custom-declare-group group #!optional doc keys)
197
(setq container (nth 1 keys))
198
(unless (listp container)
199
(setq container (list container))))
201
(custom-group-requires (append container (list group)) (cadr keys)))
203
(custom-set-group-property (append container (list group))
204
(car keys) (cadr keys))))
205
(setq keys (cddr keys)))
206
(custom-add-to-group (list group doc) container)
208
;; declare a command to customize this group
209
(define-command (intern (concat "customize:" (symbol-name group)))
211
(require 'sawfish.wm.customize)
212
(customize group))))))
214
(define (custom-quote-keys keys)
216
(while (and keys (cdr keys))
217
(if (memq (car keys) custom-quoted-keys)
218
(setq out (cons (list 'quote (nth 1 keys))
219
(cons (list 'quote (car keys)) out)))
220
(setq out (cons (nth 1 keys) (cons (list 'quote (car keys)) out))))
221
(setq keys (nthcdr 2 keys)))
222
(cons 'list (nreverse out))))
225
;;; general management
227
(define custom-setter-table (make-table symbol-hash eq))
229
(define (define-custom-setter name def)
230
(table-set custom-setter-table name def))
232
(define (custom-setter name)
233
(or (table-ref custom-setter-table name)
234
(error "No such custom setter: %s" name)))
236
(defmacro custom-set-property (sym prop value)
237
"Set the custom key PROP for defcustom'd symbol SYM to value."
238
(let ((tem (gensym)))
239
`(let ((,tem (cdr (assq ,prop custom-option-alist))))
241
(put ,sym ,tem ,value)))))
243
(define (custom-set-group-property group prop value)
244
"Set the custom key PROP for defgroup'd symbol SYM to value."
245
(unless (listp group)
246
(setq group (list group)))
247
(let* ((alist (table-ref custom-group-table group))
248
(cell (and alist (assq prop alist))))
251
(setq alist (cons (cons prop value) alist))
252
(table-set custom-group-table group alist))))
254
(define (custom-get-group-property group prop)
255
(unless (listp group)
256
(setq group (list group)))
257
(let ((alist (table-ref custom-group-table group)))
258
(cdr (assq prop alist))))
260
(define (custom-group-requires group feature)
261
(unless (listp group)
262
(setq group (list group)))
263
(custom-set-group-property
265
(cons feature (delq feature
266
(custom-get-group-property ':require group)))))
268
(defmacro custom-add-option (sym option)
269
"Assuming that defcustom'd symbol SYM is of type `symbol', add the
270
symbol OPTION to the list of choices."
271
`(put ,sym 'custom-options
272
(nconc (get ,sym 'custom-options) (list ,option))))
274
(defmacro custom-get-options (sym)
275
"Assuming that defcustom'd symbol SYM is of type `symbol', return the
277
`(get ,sym 'custom-options))
279
(define (custom-find-group full-group)
280
(when (and (symbolp full-group) (not (null full-group)))
281
(setq full-group (list full-group)))
282
(let loop ((group full-group)
283
(parent custom-groups))
287
(or (assq (car group) (cddr parent))
288
(error "No such group: %S" full-group))))))
290
(define (custom-add-to-group cell full-group)
291
(when (and (symbolp full-group) (not (null full-group)))
292
(setq full-group (list full-group)))
293
(let loop ((group full-group)
294
(parent custom-groups))
296
(unless (or (memq cell (cddr parent))
297
(assq (car cell) (cddr parent)))
298
;; reached the bottom most group
299
(rplacd (cdr parent) (nconc (cddr parent) (list cell))))
302
(or (assq (car group) (cddr parent))
303
(error "Unknown group %s" full-group)))
305
(rplacd (cdr custom-groups)
306
(nconc (sort (filter consp (cddr custom-groups))
308
(string-lessp (cadr x) (cadr y))))
309
(filter atom (cddr custom-groups))))))))
314
(define (custom-set setter symbol)
315
(when (get symbol 'custom-before-set)
316
((get symbol 'custom-before-set) symbol))
317
(make-variable-special symbol)
319
(put symbol 'custom-user-value t)
320
(when (get symbol 'custom-after-set)
321
((get symbol 'custom-after-set) symbol)))
323
(define (custom-set-symbol setter symbol)
324
(let* ((was-bound (boundp symbol))
325
(old-value (and was-bound (symbol-value symbol))))
326
(call-with-exception-handler
328
(custom-set setter symbol))
330
;; error while setting SYMBOL; revert to its old state
332
(set symbol old-value)
334
(raise-exception ex)))))
336
(define (custom-set-variable symbol value #!optional req)
337
;; XXX kludge for old custom files..
338
(when (eq value 'nil) (setq value nil))
339
(when (and req value)
340
;; load in the user module in case it's a file of bare code
342
(custom-set-symbol (lambda ()
343
(make-variable-special symbol)
344
(set symbol value)) symbol))
346
(define (custom-set-typed-variable symbol value type #!optional req)
347
;; XXX kludge for old custom files..
348
(when (eq value 'nil) (setq value nil))
349
(when (and req value)
351
(custom-set-symbol (lambda ()
352
(make-variable-special symbol)
353
(set symbol (custom-deserialize value type)))
356
(define (variable-customized-p symbol)
357
"Returns `t' if the variable named SYMBOL has been customized by the user."
358
(get symbol 'custom-user-value))
360
(define (variable-type symbol)
361
"Returns the customizable type of the variable named SYMBOL."
362
(get symbol 'custom-type))
364
(define (variable-default-value symbol)
365
"Returns the default value of SYMBOL."
366
(get symbol 'custom-default-value))
368
;; if the custom variable has been declared, then it will always
369
;; have a default-value property
370
(define (variable-declared-p symbol)
371
(memq 'custom-default-value (symbol-plist symbol)))
373
(define (make-custom-form symbol value)
374
(let ((fun (or (get symbol 'custom-set) 'custom-set-typed-variable))
375
(custom-value (custom-serialize value (variable-type symbol))))
376
`(,fun ',symbol ',custom-value
377
,@(and (eq fun 'custom-set-typed-variable)
378
(list (list 'quote (variable-type symbol))))
379
,@(and (get symbol 'custom-require)
380
(list (list 'quote (get symbol 'custom-require)))))))
382
(define (custom-eval form)
383
(apply (custom-setter (car form))
385
(if (eq (car x) 'quote)
387
;; XXX alternatives to user-eval
388
(user-eval x))) (cdr form))))
391
;;; serializing unreadable types
393
;; property name (symbol) to find type converters on during custom-convert
394
(define custom-converter-property (make-fluid))
396
;; convert VALUE of TYPE to or from a printable object
397
(define (custom-convert value type)
398
(case (or (car type) type)
400
(custom-convert value (cadr type)))
403
(custom-convert value (caddr type)))
406
`(quote ,(custom-convert (cadr value) (cadr type))))
409
(cons (custom-convert (car value) (cadr type))
410
(custom-convert (cdr value) (caddr type))))
413
(mapcar (lambda (x) (custom-convert x (cadr type))) value))
416
(let ((k-type (or (car (cadr type)) (cadr type)))
417
(v-type (or (car (caddr type)) (caddr type))))
419
(cons (custom-convert (car x) k-type)
420
(custom-convert (cdr x) v-type))) value)))
423
(do ((values value (cdr values))
424
(types (cdr type) (cdr types))
425
(out '() (cons (custom-convert (car values) (car types)) out)))
426
((or (null types) (null values))
429
;; XXX handle `or' (needs type predicates)
431
(t (let ((converter (get (or (car type) type)
432
(fluid custom-converter-property))))
434
(converter value type)
437
(define (custom-serialize value type)
438
"Convert VALUE of TYPE to a printable value."
439
(let-fluids ((custom-converter-property 'custom-serializer))
440
(custom-convert value type)))
442
(define (custom-deserialize value type)
443
"Convert VALUE of TYPE back from a printable value."
444
(let-fluids ((custom-converter-property 'custom-deserializer))
445
(custom-convert value type)))
447
(define (define-custom-serializer type fun)
448
(put type 'custom-serializer fun))
450
(define (define-custom-deserializer type fun)
451
(put type 'custom-deserializer fun))
454
;;; support for font and color primitive types
456
(define-custom-serializer 'font (lambda (value)
461
(define-custom-deserializer 'font (lambda (value)
466
(define-custom-serializer 'color (lambda (value)
471
(define-custom-deserializer 'color (lambda (value)
479
(defgroup focus "Focus" :require sawfish.wm.ext.auto-raise)
480
(defgroup move "Move/Resize" :require sawfish.wm.commands.move-resize)
481
(defgroup placement "Placement")
482
(defgroup appearance "Appearance")
483
(defgroup workspace "Workspaces")
484
(defgroup bindings "Bindings")
485
(defgroup min-max "Minimizing/Maximizing")
486
(defgroup iconify "Minimizing" :group min-max)
487
(defgroup maximize "Maximizing" :group min-max)
488
(defgroup misc "Miscellaneous")
491
;;; loading user's customisations
493
(define (custom-load filename)
494
(let ((file (open-file filename 'read)))
498
(let ((form (read file)))
499
(call-with-error-handler
500
(lambda () (custom-eval form)))))
504
(define (custom-load-user-file)
505
"Load the user's customization file, or the custom-default-file."
506
(cond ((file-exists-p custom-user-file)
507
(custom-load custom-user-file))
509
(custom-load custom-default-file))))
514
(let ((tem (get-command-line-option "--custom-file" t)))
516
(setq custom-user-file tem)))
518
(define-custom-setter 'custom-set-variable custom-set-variable)
519
(define-custom-setter 'custom-set-typed-variable custom-set-typed-variable)
521
(gaol-add defcustom defgroup custom-declare-variable custom-declare-group
522
custom-quote-keys custom-set-property custom-set-group-property
523
custom-option-alist custom-group-option-alist))
added
removed
lisp/sawfish/wm/custom.jl
