File: command.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 (183 lines) | stat: -rw-r--r-- 6,094 bytes parent folder | download | duplicates (4)
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
#| nokogiri-widgets/command.jl

   $Id: command.jl,v 1.9 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.command ()

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

  (define all-commands)

  (define (command-name command) (or (car command) command))

  (define (command-type command)
    (and (listp command) (cadr (memq #:type command))))

  (define (get-command name)
    (or (memq name all-commands) (assq name all-commands)))

  (define (filter-command-list) all-commands)

  (define (command-item x) (list (beautify-symbol-name (command-name x))))

  (define (make-command-item changed)

    (unless all-commands
      (setq all-commands (wm-command-list)))
    
    (let ((commands (filter-command-list))
	  (clist (gtk-clist-new-with-titles (list (_ "Command"))))
	  (text-view (gtk-text-view-new))
	  (vbox (gtk-vbox-new nil box-spacing))
	  (scroller (gtk-scrolled-window-new))
	  (scroller-2 (gtk-scrolled-window-new))
	  (params-hbox (gtk-hbox-new nil box-spacing))
	  (selection 0)
	  (params-spec nil)
	  (params-widget nil))

      (define (update-doc)
	(let ((doc (remove-newlines
		    (or (wm-documentation
			 (command-name (nth selection commands)))
			(_ "Undocumented"))))
	      (buffer (gtk-text-view-get-buffer text-view))
	      (iter (gtk-text-iter-new)))
	  (gtk-text-buffer-set-text buffer doc (length doc))
	  (gtk-text-buffer-get-start-iter buffer iter)
	  (gtk-text-buffer-place-cursor buffer iter)))

      (define (update-params)
	(let ((new-spec (command-type (nth selection commands))))
	  (unless (equal new-spec params-spec)
	    (when params-widget
	      (gtk-container-remove params-hbox (widget-gtk-widget
						 params-widget))
	      (setq params-widget nil))
	    (setq params-spec new-spec)
	    (if (null params-spec)
		(gtk-widget-hide params-hbox)
	      (setq params-widget (make-widget params-spec changed))
	      (gtk-container-add params-hbox (widget-gtk-widget params-widget))
	      (gtk-widget-show params-hbox)))))

      (mapc (lambda (c)
	      (gtk-clist-append clist (command-item c))) commands)

      (g-signal-connect clist "select_row"
			  (lambda (w row col)
			    (declare (unused w col))
			    (setq selection row)
			    (update-params)
			    (update-doc)
			    (call-callback changed)))

      ;; seems you have to `moveto' _after_ the widget is realized..
      (g-signal-connect clist "map"
			  (lambda ()
			    (gtk-clist-moveto clist selection 0)))

      (gtk-text-view-set-wrap-mode text-view 'word)
      (gtk-text-view-set-editable text-view nil)
      (gtk-widget-set-size-request text-view -1 50)
      (gtk-clist-set-selection-mode clist 'browse)
      (gtk-scrolled-window-set-policy scroller 'automatic 'automatic)
      (gtk-scrolled-window-set-policy scroller-2 'automatic 'automatic)
      (gtk-container-add scroller clist)
      (gtk-container-add scroller-2 text-view)
      (gtk-box-pack-end vbox scroller-2)
      (gtk-container-add vbox scroller)
      (gtk-box-pack-end vbox params-hbox)
      (gtk-widget-show-all vbox)
      (unless params-widget
	(gtk-widget-hide params-hbox))
      (gtk-widget-set-size-request vbox 350 350)
      (update-doc)

      (lambda (op)
	(case op
	  ((gtk-widget) vbox)
	  ((clear) (lambda ()
		     (when params-widget
		       (widget-clear params-widget))
		     (gtk-clist-select-row 0 0)
		     (gtk-clist-moveto clist 0 0)))
	  ((set) (lambda (x)
		   (let ((index (command-index commands (command-name x))))
		     (unless index
		       ;; scan in all-commands
		       (setq index (command-index
				    all-commands (command-name x)))
		       (if index
			   ;; yes, add it to the list
			   (let ((command (nth index all-commands)))
			     (setq commands (nconc commands (list command)))
			     (gtk-clist-append clist (command-item command))
			     (setq index (1- (length commands))))
			 (setq index 0)))
		     (setq selection index)
		     (gtk-clist-select-row clist index 0)
		     (gtk-clist-moveto clist index 0)
		     (when (cdr x)
		       (update-params)
		       (widget-set params-widget (cdr x))))))
	  ((ref) (lambda ()
		   (if params-widget
		       (cons (command-name (nth selection commands))
			     (widget-ref params-widget))
		     (command-name (nth selection commands)))))
	  ((validp) (lambda (x)
		      ;; XXX check params
		      (memq (command-name (car x)) commands)))))))

  (define-widget-type 'command make-command-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))))

  (define (remove-newlines string)
    (let loop ((point 0)
	       (out '()))
      (if (string-match "\n" string point)
	  (loop (match-end)
		(list* #\space (substring string point (match-start)) out))
	(apply concat (nreverse (cons (substring string point) out))))))

  (define (command-index lst x)
    (let loop ((i 0) (rest lst))
      (cond ((null rest) nil)
	    ((eq (or (caar rest) (car rest)) x) i)
	    (t (loop (1+ i) (cdr rest)))))))