File: group.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 (263 lines) | stat: -rw-r--r-- 8,675 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
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
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
#| nokogiri-group.jl -- group management

   $Id: group.jl,v 1.10 2003/01/12 20:30:47 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.group

    (export group-real-name
	    group-slots
	    group-sub-groups
	    group-layout
	    root-group
	    top-group
	    set-top-group
	    get-group
	    fetch-group
	    update-group
	    get-sub-groups
	    refresh-groups-for-slots
	    make-group-tree
	    select-group
	    redisplay-group)

    (open rep
	  gui.gtk-2.gtk
	  rep.system
	  rep.data.records
	  rep.data.tables
	  sawfish.ui.slot
	  sawfish.ui.wm)

  (define-record-type :group
    (make-group name)
    ;; [no predicate]
    (name group-name)					;full name (a list)
    (real-name group-real-name group-real-name-set)	;human-readable name
    (loaded group-loaded-p group-loaded-set)		;t iff members read
    (slots group-slots group-slots-set)			;list of slots
    (sub-groups group-sub-groups group-sub-groups-set)	;((SYMBOL . REAL)..)
    (tree group-tree group-tree-set)			;GtkTree of sub groups
    (layout group-layout group-layout-set))

  (define-record-discloser :group
    (lambda (g) (format nil "#<:group %s>" (group-name g))))

  ;; hash table of all group objects
  (define group-table (make-table equal-hash equal))

  (define root-group '(root))		;XXX should be a constant

  (define top-group root-group)

  (define (set-top-group g) (setq top-group g))

  (define current-group nil)

  (defvar *nokogiri-group-selected-hook* '())
  (defvar *nokogiri-group-deselected-hook* '())

  (define (get-key lst key) (cadr (memq key lst)))

;;; group name manipulation

  ;; return the name of the parent of the group called GROUP, or
  ;; nil if this is the topmost group
  (define (group-name-above group)
    (if (null (cdr group))
	'()
      (let ((name (copy-sequence group)))
	(rplacd (nthcdr (- (length name) 2) name) '())
	name)))

  (define (group-name-local group) (last group))

  ;; return the name of the child called CHILD of the group called GROUP
  (define (group-name-add group child)
    (append group (list child)))

  (define group-name= equal)

;;; group creation and loading

  ;; return the group called NAME
  (define (get-group name)
    (let ((group (table-ref group-table name)))
      (unless group
	(setq group (make-group name))
	(table-set group-table name group))
      group))

  ;; ensure that all data for GROUP has been read
  (define (fetch-group group #!key force)
    (when (or force (not (group-loaded-p group)))
      (update-group group)))

  ;; forcibly reread data for GROUP
  (define (update-group group)
    (let ((data (wm-load-group (group-name group))))
      ;; DATA is (LAST-NAME-COMPONENT "REAL-NAME" (ITEMS...) OPTIONS...)
      ;; ITEMS are CUSTOM-NAME, or (SUB-GROUP-NAME REAL-NAME)
      (let ((real-name (cadr data))
	    (items (caddr data))
	    (layout (get-key (cdddr data) #:layout)))
	(group-real-name-set group real-name)
	(group-slots-set group (fetch-slots (filter atom items)))
	(group-sub-groups-set group (filter consp items))
	(group-layout-set group (or layout 'vbox))
	(group-loaded-set group t)
	(mapc update-dependences (group-slots group)))))

  ;; return a list containing the sub-groups of GROUP
  (define (get-sub-groups group)
    (mapcar (lambda (cell)
	      (get-group (group-name-add (group-name group) (car cell))))
	    (group-sub-groups group)))

  ;; return the parent group of GROUP, or nil
  (define (group-parent group)
    (let ((parent-name (group-name-above (group-name group))))
      (and parent-name (get-group parent-name))))

  ;; if the data for GROUP has been loaded, reload it and resync all state
  (define (refresh-group group)
    (when (group-loaded-p group)
      (let ((old-slots (length (group-slots group))))
	;; reload the group data from the wm
	(fetch-group group #:force t)
	(when (group-tree group)
	  ;; if necessary update the sub-trees of the group
	  (let ((old (gtk-container-get-children (group-tree group))))
	    (populate-branch group)
	    (mapc (lambda (x)
		    (gtk-tree-remove-item (group-tree group) x)) old)))
	;; if this is the currently displayed group, then
	;; make sure the display is consistent with the new state
	(when (and (eq group current-group)
		   (/= (length (group-slots group)) old-slots))
	  (select-group group #:force t)))))
    
  ;; Return the list of (unique) groups containing the list of SLOTS
  (define (locate-groups slots)
    (let ((out '()))
      (table-walk (lambda (name group)
		    (declare (unused name))
		    (when (unionq slots (group-slots group))
		      (setq out (cons group out))))
		  group-table)
      out))

  ;; Reload all groups containing the list of SLOTS
  (define (refresh-groups-for-slots slots)
    (mapc refresh-group (locate-groups slots)))

;;; group widgetry

  ;; creates the top-level tree node
  (define (make-group-tree group)
    (fetch-group group)
    (let ((tree (gtk-tree-new))
	  (item (make-tree-item (group-name-above (group-name group))
				(group-name-local (group-name group))
				(group-real-name group))))
      (gtk-tree-set-selection-mode tree 'browse)
      (gtk-tree-append tree item)
      (gtk-widget-show-all tree)
      tree))

  ;; creates the tree-item for a named group
  (define (make-tree-item parent-name name real-name)
    (let ((item (gtk-tree-item-new-with-label (_ real-name))))
      (g-signal-connect
       item "select" (group-selected parent-name name))
      (g-signal-connect
       item "deselect" (group-deselected parent-name name))
      item))

  ;; fills the contents of the tree associated with GROUP
  (define (populate-branch group)
    ;; check for sub groups
    (fetch-group group)
    (when (group-sub-groups group)
      (mapc (lambda (sub)
	      (let ((sgroup (get-group
			     (group-name-add (group-name group) (car sub))))
		    (item (make-tree-item (group-name group)
					  (car sub) (cadr sub))))
		(gtk-tree-append (group-tree group) item)
		(when (group-tree sgroup)
		  ;; rebuild the sub-tree of this item
		  (make-branch item sgroup))))
	    (group-sub-groups group))
      (gtk-widget-show-all (group-tree group))))

  ;; adds a sub-tree to ITEM representing GROUP
  (define (make-branch item group)
    (fetch-group group)
    (when (group-tree group)
      (group-tree-set group nil))
    (when (group-sub-groups group)
      (group-tree-set group (gtk-tree-new))
      (populate-branch group)
      (gtk-tree-item-set-subtree item (group-tree group))
      (gtk-tree-item-expand item)))

  (define (group-selected parent-name name)
    ;; called when a tree node is selected
    (lambda (item)
      (let ((group (get-group (group-name-add parent-name name))))
	(setq current-group group)

	;; fill the contents of the branch
	(unless (group-tree group)
	  (make-branch item group))

	;; display the slots for this group
	(call-hook '*nokogiri-group-selected-hook* (list group)))))

  (define (group-deselected parent-name name)
    (lambda (item)
      (declare (unused item))
      (let ((group (get-group (group-name-add parent-name name))))
	(call-hook '*nokogiri-group-deselected-hook* (list group))
	(setq current-group nil))))

  (define (select-group group #!key force)
    (when (or force (not (eq current-group group)))
      (when current-group
	(call-hook '*nokogiri-group-deselected-hook* (list current-group)))
      (setq current-group group)
      (call-hook '*nokogiri-group-selected-hook* (list current-group))))

  (define (redisplay-group)
    (when current-group
      (call-hook '*nokogiri-group-deselected-hook* (list current-group))
      (call-hook '*nokogiri-group-selected-hook* (list current-group))))

;;; util

  ;; return the union of lists X and Y, using `eq' for comparisons
  (define (unionq x y)
    (let loop ((rest x)
	       (out '()))
      (cond ((null rest) (nreverse out))
	    ((memq (car rest) y) (loop (cdr rest) (cons (car rest) out)))
	    (t (loop (cdr rest) out))))))