1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
|
#| nokogiri-widgets/keymap.jl
$Id: keymap.jl,v 1.12 2003/01/12 20:30:49 jsh Exp $
Copyright (C) 2000 John Harper <john@dcs.warwick.ac.uk>
This file is part of sawfish.
sawfish is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
sawfish is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with sawfish; see the file COPYING. If not, write to
the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
|#
(define-structure sawfish.ui.widgets.keymap ()
(open rep
gui.gtk-2.gtk
rep.regexp
sawfish.gtk.stock
sawfish.gtk.widget)
;;; widget for representing keymaps
(define (command-name command)
(or (car command) command))
(define (make-keymap-item changed-callback)
(define (print x)
(let ((command (car x)))
(list (cdr x)
(if (consp command)
(concat (beautify-symbol-name (command-name command))
": "
(mapconcat (lambda (x) (format nil "%s" x))
(cdr command) ", "))
(beautify-symbol-name command)))))
(define (dialog title callback #!key for value)
(declare (unused title))
(let ((widget (make-widget `(keymap:binding))))
(when value
(widget-set widget value))
(simple-dialog (_ "Edit Binding") (widget-gtk-widget widget)
(lambda () (callback (widget-ref widget)))
for)))
(define (validp x) (and (consp x) (symbolp (car x)) (stringp (cdr x))))
(define (type op)
(case op
((print) print)
((dialog) dialog)
((validp) validp)))
(let ((base (make-widget `(list ,type (,(_ "Key") ,(_ "Command")))
changed-callback)))
;; mold this to accept (keymap . LIST)
(lambda (op)
(case op
((ref) (lambda ()
(cons 'keymap (widget-ref base))))
((set) (lambda (x)
(widget-set base (cdr x))))
((validp) (lambda (x)
(and (eq (car x) 'keymap)
(widget-valid-p base (cdr x)))))
(t (base op))))))
(define-widget-type 'keymap make-keymap-item)
;;; widget for editing individual bindings
(define (make-keymap:binding-item changed-callback)
(make-widget `(pair command (labelled ,(_ "Key:") event)
t t (start . middle))
changed-callback))
(define-widget-type 'keymap:binding make-keymap:binding-item)
;;; utils
(define (beautify-symbol-name symbol)
(cond ((stringp symbol) symbol)
((not (symbolp symbol)) (format "%s" symbol))
(t
(let ((name (copy-sequence (symbol-name symbol))))
(while (string-match "[-:]" name)
(setq name (concat (substring name 0 (match-start))
? (substring name (match-end)))))
(aset name 0 (char-upcase (aref name 0)))
(_ name))))))
|
