← Back to branch summary

~ubuntu-branches/ubuntu/lucid/sawfish/lucid-updates

« back to all changes in this revision

Viewing changes to lisp/sawfish/ui/widgets/match-window.jl

  • Committer: Bazaar Package Importer
  • Author(s): Christian Marillat
  • Date: 2002-01-20 17:42:28 UTC
  • Revision ID: james.westby@ubuntu.com-20020120174228-4q1ydztbkvfq1ht2
Tags: upstream-1.0.1.20020116
Import upstream version 1.0.1.20020116

Show diffs side-by-side

added added

removed removed

Lines of Context:
lisp/sawfish/ui/widgets/match-window.jl
 
1
#| nokogiri-widgets/match-window.jl -- match-window widget
 
2
 
 
3
   $Id: match-window.jl,v 1.9 2001/08/24 02:43:40 jsh Exp $
 
4
 
 
5
   Copyright (C) 2000 John Harper <john@dcs.warwick.ac.uk>
 
6
 
 
7
   This file is part of sawfish.
 
8
 
 
9
   sawfish is free software; you can redistribute it and/or modify it
 
10
   under the terms of the GNU General Public License as published by
 
11
   the Free Software Foundation; either version 2, or (at your option)
 
12
   any later version.
 
13
 
 
14
   sawfish is distributed in the hope that it will be useful, but
 
15
   WITHOUT ANY WARRANTY; without even the implied warranty of
 
16
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 
17
   GNU General Public License for more details.
 
18
 
 
19
   You should have received a copy of the GNU General Public License
 
20
   along with sawfish; see the file COPYING.  If not, write to
 
21
   the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
 
22
|#
 
23
 
 
24
(define-structure sawfish.ui.widgets.match-window ()
 
25
 
 
26
    (open rep
 
27
          gui.gtk
 
28
          rep.regexp
 
29
          sawfish.gtk.widget
 
30
          sawfish.gtk.stock
 
31
          sawfish.ui.wm)
 
32
 
 
33
  (defconst matcher-count 3)
 
34
 
 
35
 
 
36
;;; the widget representing the `matchers' frame
 
37
 
 
38
  ;; (match-window:matchers x-properties)
 
39
 
 
40
  (define (make-match-window:matchers changed-callback x-properties)
 
41
    (declare (unused changed-callback))
 
42
 
 
43
    (let ((frame (gtk-frame-new (_ "Matchers")))
 
44
          (table (gtk-table-new matcher-count 3 nil))
 
45
          (l10n-x-properties (mapcar (lambda (x)
 
46
                                       (cons (car x) (_ (cdr x))))
 
47
                                     x-properties))
 
48
          (widgets '()))
 
49
 
 
50
      (do ((i 0 (1+ i)))
 
51
          ((= i matcher-count))
 
52
        (let ((combo (gtk-combo-new))
 
53
              (entry (gtk-entry-new))
 
54
              (button (gtk-button-new-with-label (_ "Grab..."))))
 
55
          (gtk-combo-set-popdown-strings
 
56
           combo (cons "" (mapcar cdr l10n-x-properties)))
 
57
          (gtk-table-attach-defaults table combo 0 1 i (1+ i))
 
58
          (gtk-table-attach-defaults table entry 1 2 i (1+ i))
 
59
          (gtk-table-attach-defaults table button 2 3 i (1+ i))
 
60
          (gtk-signal-connect button "clicked"
 
61
           (lambda ()
 
62
             (let* ((string (gtk-entry-get-text (gtk-combo-entry combo)))
 
63
                    (x-prop (and string (car (rassoc string
 
64
                                                     l10n-x-properties)))))
 
65
               (when string
 
66
                 (let ((prop (wm-grab-x-property (or x-prop (intern string)))))
 
67
                   (gtk-entry-set-text entry (if (stringp prop)
 
68
                                                 prop
 
69
                                               "")))))))
 
70
          (setq widgets (nconc widgets (list (cons combo entry))))))
 
71
      (gtk-container-add frame table)
 
72
      (gtk-container-border-width table box-border)
 
73
      (gtk-table-set-row-spacings table box-spacing)
 
74
      (gtk-table-set-col-spacings table box-spacing)
 
75
      (gtk-widget-show-all frame)
 
76
 
 
77
      (lambda (op)
 
78
        (case op
 
79
          ((gtk-widget) frame)
 
80
          ((clear)
 
81
           (lambda ()
 
82
             (mapc (lambda (cell)
 
83
                     (gtk-entry-set-text (gtk-combo-entry (car cell)) "")
 
84
                     (gtk-entry-set-text (cdr cell) "")) widgets)))
 
85
          ((set)
 
86
           (lambda (x)
 
87
             (do ((cells widgets (cdr cells))
 
88
                  (rest x (cdr rest)))
 
89
                 ((or (null cells) (null rest)))
 
90
               (gtk-entry-set-text
 
91
                (gtk-combo-entry (caar cells))
 
92
                (or (cdr (assq (caar rest) l10n-x-properties)) (caar rest)))
 
93
               (gtk-entry-set-text (cdar cells) (cdar rest)))))
 
94
          ((ref)
 
95
           (lambda ()
 
96
             (let loop ((cells widgets)
 
97
                        (out '()))
 
98
               (if (null cells)
 
99
                   (nreverse out)
 
100
                 (let ((name (gtk-entry-get-text
 
101
                              (gtk-combo-entry (caar cells))))
 
102
                       (value (gtk-entry-get-text (cdar cells))))
 
103
                   (if (or (string= name "") (string= value ""))
 
104
                       (loop (cdr cells) out)
 
105
                     (let ((prop (rassoc name l10n-x-properties)))
 
106
                       (if prop
 
107
                           (setq name (car prop))
 
108
                         (setq name (intern name))))
 
109
                     (loop (cdr cells)
 
110
                           (cons (cons name value) out))))))))
 
111
          ((validp) listp)))))
 
112
 
 
113
  (define-widget-type 'match-window:matchers make-match-window:matchers)
 
114
 
 
115
 
 
116
;;; the widget representing the `Actions' frame
 
117
 
 
118
  (define (make-match-window:actions changed-callback properties)
 
119
    (declare (unused changed-callback))
 
120
 
 
121
    (let ((frame (gtk-frame-new (_ "Actions")))
 
122
          (book (gtk-notebook-new))
 
123
          (widgets '()))
 
124
 
 
125
      (mapc
 
126
       (lambda (sub)
 
127
         (let ((title (car sub))
 
128
               (table (gtk-table-new (length (cdr sub)) 2 nil))
 
129
               (vbox (gtk-vbox-new nil box-spacing)))
 
130
           (do ((i 0 (1+ i))
 
131
                (props (cdr sub) (cdr props)))
 
132
               ((null props))
 
133
             (let* ((prop (car props))
 
134
                    (is-boolean (eq (cadr prop) 'boolean))
 
135
                    (widget (make-widget
 
136
                             (if is-boolean
 
137
                                 `(boolean ,(beautify-symbol-name (car prop)))
 
138
                               `(optional ,(cadr prop))))))
 
139
               (unless is-boolean
 
140
                 (gtk-table-attach-defaults
 
141
                  table (make-left-label (beautify-symbol-name (car prop)))
 
142
                  0 1 i (1+ i)))
 
143
               (gtk-table-attach-defaults
 
144
                table (widget-gtk-widget widget) 1 2 i (1+ i))
 
145
               (setq widgets (cons (cons (car prop) widget) widgets))))
 
146
           (gtk-table-set-row-spacings table box-spacing)
 
147
           (gtk-table-set-col-spacings table box-spacing)
 
148
           (gtk-box-pack-start vbox table)
 
149
           (gtk-notebook-append-page book vbox (gtk-label-new title))))
 
150
       properties)
 
151
 
 
152
      (setq widgets (nreverse widgets))
 
153
      (gtk-container-border-width book box-border)
 
154
      (gtk-container-add frame book)
 
155
      (gtk-widget-show-all frame)
 
156
 
 
157
      (lambda (op)
 
158
        (case op
 
159
          ((gtk-widget) frame)
 
160
          ((clear) (lambda ()
 
161
                     (mapc (lambda (x) (widget-clear (cdr x))) widgets)))
 
162
          ((set)
 
163
           (lambda (x)
 
164
             (mapc (lambda (cell)
 
165
                     (let ((widget (cdr (assq (car cell) widgets))))
 
166
                       (when widget
 
167
                         (widget-set widget (cdr cell))))) x)))
 
168
          ((ref)
 
169
           (lambda ()
 
170
             (let loop ((rest widgets)
 
171
                        (out '()))
 
172
               (if (null rest)
 
173
                   (nreverse out)
 
174
                 (let ((value (widget-ref (cdar rest))))
 
175
                   (if value
 
176
                       (loop (cdr rest) (cons (cons (caar rest) value) out))
 
177
                     (loop (cdr rest) out)))))))))))
 
178
                     
 
179
  (define-widget-type 'match-window:actions make-match-window:actions)
 
180
 
 
181
  (define (make-left-label string)
 
182
    (let ((hbox (gtk-hbox-new nil 0)))
 
183
      (gtk-box-pack-end hbox (gtk-label-new string))
 
184
      hbox))
 
185
  
 
186
  ;; also in sawfish-xgettext
 
187
  (define (beautify-symbol-name symbol)
 
188
    (cond ((stringp symbol) symbol)
 
189
          ((not (symbolp symbol)) (format "%s" symbol))
 
190
          (t
 
191
           (let ((name (copy-sequence (symbol-name symbol))))
 
192
             (while (string-match "[-:]" name)
 
193
               (setq name (concat (substring name 0 (match-start))
 
194
                                  ?  (substring name (match-end)))))
 
195
             (aset name 0 (char-upcase (aref name 0)))
 
196
             (_ name)))))
 
197
 
 
198
 
 
199
;;; the main widget
 
200
                     
 
201
  ;; (match-window ...)
 
202
 
 
203
  (define (make-match-window-item changed-callback properties x-properties)
 
204
 
 
205
    (define (print-matcher match)
 
206
      (if (stringp (cdr match)) (cdr match) "?"))
 
207
 
 
208
    (define (print-action action)
 
209
      (if (eq (cdr action) t)
 
210
          (format nil "%s" (car action))
 
211
        (format nil "%s=%s" (car action) (cdr action))))
 
212
 
 
213
    (define (print x)
 
214
      (list (mapconcat print-matcher (car x) ", ")
 
215
            (mapconcat print-action (cdr x) ", ")))
 
216
 
 
217
    (define (dialog title callback #!key for value)
 
218
      (declare (unused title))
 
219
      (let ((vbox (gtk-vbox-new nil box-spacing))
 
220
            (matcher-widget (make-widget
 
221
                             `(match-window:matchers ,x-properties)))
 
222
            (action-widget (make-widget
 
223
                            `(match-window:actions ,properties))))
 
224
        (gtk-container-add vbox (widget-gtk-widget matcher-widget))
 
225
        (gtk-container-add vbox (widget-gtk-widget action-widget))
 
226
        (when value
 
227
          (widget-set matcher-widget (car value))
 
228
          (widget-set action-widget (cdr value)))
 
229
        (gtk-widget-show vbox)
 
230
 
 
231
        (simple-dialog (_ "Match window properties") vbox
 
232
                       (lambda ()
 
233
                         (callback (cons (widget-ref matcher-widget)
 
234
                                         (widget-ref action-widget))))
 
235
                       for)))
 
236
 
 
237
    (define (validp x) (and (consp x) (listp (car x)) (listp (cdr x))))
 
238
 
 
239
    (define (type op)
 
240
      (case op
 
241
        ((print) print)
 
242
        ((dialog) dialog)
 
243
        ((validp) validp)))
 
244
 
 
245
    (make-widget `(list ,type (,(_ "Matchers") ,(_ "Actions")))
 
246
                 changed-callback))
 
247
 
 
248
  (define-widget-type 'match-window make-match-window-item))