File: match-window.jl

package info (click to toggle)
sawfish 1%3A1.3.5.2-2
  • links: PTS, VCS
  • area: main
  • in suites: squeeze
  • size: 11,636 kB
  • ctags: 1,327
  • sloc: lisp: 22,765; ansic: 15,810; sh: 10,203; makefile: 675; perl: 19
file content (245 lines) | stat: -rw-r--r-- 7,918 bytes parent folder | download | duplicates (3)
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
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
#| nokogiri-widgets/match-window.jl -- match-window widget

   $Id: match-window.jl,v 1.11 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.match-window ()

    (open rep
	  gui.gtk-2.gtk
	  rep.regexp
	  sawfish.gtk.widget
	  sawfish.gtk.stock
	  sawfish.ui.wm)

  (defconst matcher-count 3)

;;; the widget representing the `matchers' frame

  ;; (match-window:matchers x-properties)

  (define (make-match-window:matchers changed-callback x-properties)
    (declare (unused changed-callback))

    (let ((frame (gtk-frame-new (_ "Matchers")))
	  (table (gtk-table-new matcher-count 3 nil))
	  (l10n-x-properties (mapcar (lambda (x)
				       (cons (car x) (_ (cdr x))))
				     x-properties))
	  (widgets '()))

      (do ((i 0 (1+ i)))
	  ((= i matcher-count))
	(let ((combo (gtk-combo-new))
	      (entry (gtk-entry-new))
	      (button (gtk-button-new-with-label (_ "Grab..."))))
	  (gtk-combo-set-popdown-strings
	   combo (cons "" (mapcar cdr l10n-x-properties)))
	  (gtk-table-attach-defaults table combo 0 1 i (1+ i))
	  (gtk-table-attach-defaults table entry 1 2 i (1+ i))
	  (gtk-table-attach-defaults table button 2 3 i (1+ i))
	  (g-signal-connect button "clicked"
	   (lambda ()
	     (let* ((string (gtk-entry-get-text (gtk-combo-entry combo)))
		    (x-prop (and string (car (rassoc string
						     l10n-x-properties)))))
	       (when string
		 (let ((prop (wm-grab-x-property (or x-prop (intern string)))))
		   (gtk-entry-set-text entry (if (stringp prop)
						 prop
					       "")))))))
	  (setq widgets (nconc widgets (list (cons combo entry))))))
      (gtk-container-add frame table)
      (gtk-container-set-border-width table box-border)
      (gtk-table-set-row-spacings table box-spacing)
      (gtk-table-set-col-spacings table box-spacing)
      (gtk-widget-show-all frame)

      (lambda (op)
	(case op
	  ((gtk-widget) frame)
	  ((clear)
	   (lambda ()
	     (mapc (lambda (cell)
		     (gtk-entry-set-text (gtk-combo-entry (car cell)) "")
		     (gtk-entry-set-text (cdr cell) "")) widgets)))
	  ((set)
	   (lambda (x)
	     (do ((cells widgets (cdr cells))
		  (rest x (cdr rest)))
		 ((or (null cells) (null rest)))
	       (gtk-entry-set-text
		(gtk-combo-entry (caar cells))
		(or (cdr (assq (caar rest) l10n-x-properties)) (caar rest)))
	       (gtk-entry-set-text (cdar cells) (cdar rest)))))
	  ((ref)
	   (lambda ()
	     (let loop ((cells widgets)
			(out '()))
	       (if (null cells)
		   (nreverse out)
		 (let ((name (gtk-entry-get-text
			      (gtk-combo-entry (caar cells))))
		       (value (gtk-entry-get-text (cdar cells))))
		   (if (or (string= name "") (string= value ""))
		       (loop (cdr cells) out)
		     (let ((prop (rassoc name l10n-x-properties)))
		       (if prop
			   (setq name (car prop))
			 (setq name (intern name))))
		     (loop (cdr cells)
			   (cons (cons name value) out))))))))
	  ((validp) listp)))))

  (define-widget-type 'match-window:matchers make-match-window:matchers)

;;; the widget representing the `Actions' frame

  (define (make-match-window:actions changed-callback properties)
    (declare (unused changed-callback))

    (let ((frame (gtk-frame-new (_ "Actions")))
	  (book (gtk-notebook-new))
	  (widgets '()))

      (mapc
       (lambda (sub)
	 (let ((title (car sub))
	       (table (gtk-table-new (length (cdr sub)) 2 nil))
	       (vbox (gtk-vbox-new nil box-spacing)))
	   (do ((i 0 (1+ i))
		(props (cdr sub) (cdr props)))
	       ((null props))
	     (let* ((prop (car props))
		    (widget (make-widget
			     (if (eq (cadr prop) 'boolean)
				 `(optional scheme-boolean)
			       `(optional ,(cadr prop))))))
	       (gtk-table-attach-defaults
		table (make-left-label (beautify-symbol-name (car prop)))
		0 1 i (1+ i))
	       (gtk-table-attach-defaults
		table (widget-gtk-widget widget) 1 2 i (1+ i))
	       (setq widgets (cons (cons (car prop) widget) widgets))))
	   (gtk-table-set-row-spacings table box-spacing)
	   (gtk-table-set-col-spacings table box-spacing)
	   (gtk-box-pack-start vbox table)
	   (gtk-notebook-append-page book vbox (gtk-label-new title))))
       properties)

      (setq widgets (nreverse widgets))
      (gtk-container-set-border-width book box-border)
      (gtk-container-add frame book)
      (gtk-widget-show-all frame)

      (lambda (op)
	(case op
	  ((gtk-widget) frame)
	  ((clear) (lambda ()
		     (mapc (lambda (x) (widget-clear (cdr x))) widgets)))
	  ((set)
	   (lambda (x)
	     (mapc (lambda (cell)
		     (let ((widget (cdr (assq (car cell) widgets))))
		       (when widget
			 (widget-set widget (cdr cell))))) x)))
	  ((ref)
	   (lambda ()
	     (let loop ((rest widgets)
			(out '()))
	       (if (null rest)
		   (nreverse out)
		 (let ((value (widget-ref (cdar rest))))
		   (if value
		       (loop (cdr rest) (cons (cons (caar rest) value) out))
		     (loop (cdr rest) out)))))))))))
		     
  (define-widget-type 'match-window:actions make-match-window:actions)

  (define (make-left-label string)
    (let ((hbox (gtk-hbox-new nil 0)))
      (gtk-box-pack-end hbox (gtk-label-new string))
      hbox))
  
  ;; also in sawfish-xgettext
  (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)))))

;;; the main widget
		     
  ;; (match-window ...)

  (define (make-match-window-item changed-callback properties x-properties)

    (define (print-matcher match)
      (if (stringp (cdr match)) (cdr match) "?"))

    (define (print-action action)
      (cond ((memq (cdr action) '(t #t))
	     (format nil "%s" (car action)))
	    ((eq (cdr action) '#f)
	     (format nil "%s %s" (_ "not") (car action)))
	    (t (format nil "%s=%s" (car action) (cdr action)))))

    (define (print x)
      (list (mapconcat print-matcher (car x) ", ")
	    (mapconcat print-action (cdr x) ", ")))

    (define (dialog title callback #!key for value)
      (declare (unused title))
      (let ((vbox (gtk-vbox-new nil box-spacing))
	    (matcher-widget (make-widget
			     `(match-window:matchers ,x-properties)))
	    (action-widget (make-widget
			    `(match-window:actions ,properties))))
	(gtk-container-add vbox (widget-gtk-widget matcher-widget))
	(gtk-container-add vbox (widget-gtk-widget action-widget))
	(when value
	  (widget-set matcher-widget (car value))
	  (widget-set action-widget (cdr value)))
	(gtk-widget-show vbox)

	(simple-dialog (_ "Match Window Properties") vbox
		       (lambda ()
			 (callback (cons (widget-ref matcher-widget)
					 (widget-ref action-widget))))
		       for)))

    (define (validp x) (and (consp x) (listp (car x)) (listp (cdr x))))

    (define (type op)
      (case op
	((print) print)
	((dialog) dialog)
	((validp) validp)))

    (make-widget `(list ,type (,(_ "Matchers") ,(_ "Actions")))
		 changed-callback))

  (define-widget-type 'match-window make-match-window-item))