1;; nokogiri-group.jl -- group management
2;;
3;; Copyright (C) 2000 John Harper <john@dcs.warwick.ac.uk>
4;;
5;; This file is part of sawfish.
6;;
7;; sawfish is free software; you can redistribute it and/or modify it
8;; under the terms of the GNU General Public License as published by
9;; the Free Software Foundation; either version 2, or (at your option)
10;; any later version.
11;;
12;; sawfish is distributed in the hope that it will be useful, but
13;; WITHOUT ANY WARRANTY; without even the implied warranty of
14;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15;; GNU General Public License for more details.
16;;
17;; You should have received a copy of the GNU General Public License
18;; along with sawfish; see the file COPYING.  If not, write to
19;; the Free Software Foundation, 51 Franklin Street, Fifth Floor,
20;; Boston, MA 02110-1301 USA.
21
22(define-structure sawfish.cfg.group
23
24    (export group-real-name
25	    group-slots
26	    group-sub-groups
27	    group-layout
28	    root-group
29	    top-group
30	    set-top-group
31	    get-group
32	    fetch-group
33	    update-group
34	    get-sub-groups
35	    refresh-groups-for-slots
36	    make-group-tree
37	    select-group
38	    redisplay-group)
39
40    (open rep
41	  gui.gtk-2.gtk
42	  rep.system
43	  rep.data.records
44	  rep.data.tables
45	  sawfish.cfg.slot
46	  sawfish.cfg.wm)
47
48  (define-record-type :group
49    (make-group name)
50    ;; [no predicate]
51    (name group-name)					;full name (a list)
52    (real-name group-real-name group-real-name-set)	;human-readable name
53    (loaded group-loaded-p group-loaded-set)		;t iff members read
54    (slots group-slots group-slots-set)			;list of slots
55    (sub-groups group-sub-groups group-sub-groups-set)	;((SYMBOL . REAL)..)
56    (tree group-tree group-tree-set)			;GtkTree of sub groups
57    (layout group-layout group-layout-set))
58
59  (define-record-discloser :group
60    (lambda (g) (format nil "#<:group %s>" (group-name g))))
61
62  ;; hash table of all group objects
63  (define group-table (make-table equal-hash equal))
64
65  (define root-group '(root))		;XXX should be a constant
66
67  (define top-group root-group)
68
69  (define (set-top-group g) (setq top-group g))
70
71  (define current-group nil)
72
73  (defvar *nokogiri-group-selected-hook* '())
74  (defvar *nokogiri-group-deselected-hook* '())
75
76  (define (get-key lst key) (cadr (memq key lst)))
77
78;;; group name manipulation
79
80  ;; return the name of the parent of the group called GROUP, or
81  ;; nil if this is the topmost group
82  (define (group-name-above group)
83    (if (null (cdr group))
84	'()
85      (let ((name (copy-sequence group)))
86	(rplacd (nthcdr (- (length name) 2) name) '())
87	name)))
88
89  (define (group-name-local group) (last group))
90
91  ;; return the name of the child called CHILD of the group called GROUP
92  (define (group-name-add group child)
93    (append group (list child)))
94
95  (define group-name= equal)
96
97;;; group creation and loading
98
99  ;; return the group called NAME
100  (define (get-group name)
101    (let ((group (table-ref group-table name)))
102      (unless group
103	(setq group (make-group name))
104	(table-set group-table name group))
105      group))
106
107  ;; ensure that all data for GROUP has been read
108  (define (fetch-group group #!key force)
109    (when (or force (not (group-loaded-p group)))
110      (update-group group)))
111
112  ;; forcibly reread data for GROUP
113  (define (update-group group)
114    (let ((data (wm-load-group (group-name group))))
115      ;; DATA is (LAST-NAME-COMPONENT "REAL-NAME" (ITEMS...) OPTIONS...)
116      ;; ITEMS are CUSTOM-NAME, or (SUB-GROUP-NAME REAL-NAME)
117      (let ((real-name (cadr data))
118	    (items (caddr data))
119	    (layout (get-key (cdddr data) #:layout)))
120	(group-real-name-set group real-name)
121	(group-slots-set group (fetch-slots (filter atom items)))
122	(group-sub-groups-set group (filter consp items))
123	(group-layout-set group (or layout 'vbox))
124	(group-loaded-set group t)
125	(mapc update-dependences (group-slots group)))))
126
127  ;; return a list containing the sub-groups of GROUP
128  (define (get-sub-groups group)
129    (mapcar (lambda (cell)
130	      (get-group (group-name-add (group-name group) (car cell))))
131	    (group-sub-groups group)))
132
133  ;; return the parent group of GROUP, or nil
134  (define (group-parent group)
135    (let ((parent-name (group-name-above (group-name group))))
136      (and parent-name (get-group parent-name))))
137
138  ;; if the data for GROUP has been loaded, reload it and resync all state
139  (define (refresh-group group)
140    (when (group-loaded-p group)
141      (let ((old-slots (length (group-slots group))))
142	;; reload the group data from the wm
143	(fetch-group group #:force t)
144	(when (group-tree group)
145	  ;; if necessary update the sub-trees of the group
146	  (let ((old (gtk-container-get-children (group-tree group))))
147	    (populate-branch group)
148	    (mapc (lambda (x)
149		    (gtk-tree-remove-item (group-tree group) x)) old)))
150	;; if this is the currently displayed group, then
151	;; make sure the display is consistent with the new state
152	(when (and (eq group current-group)
153		   (/= (length (group-slots group)) old-slots))
154	  (select-group group #:force t)))))
155
156  ;; Return the list of (unique) groups containing the list of SLOTS
157  (define (locate-groups slots)
158    (let ((out '()))
159      (table-walk (lambda (name group)
160		    (declare (unused name))
161		    (when (unionq slots (group-slots group))
162		      (setq out (cons group out))))
163		  group-table)
164      out))
165
166  ;; Reload all groups containing the list of SLOTS
167  (define (refresh-groups-for-slots slots)
168    (mapc refresh-group (locate-groups slots)))
169
170;;; group widgetry
171
172  ;; creates the top-level tree node
173  (define (make-group-tree group)
174    (fetch-group group)
175    (let ((tree (gtk-tree-new))
176	  (item (make-tree-item (group-name-above (group-name group))
177				(group-name-local (group-name group))
178				(group-real-name group))))
179      (gtk-tree-set-selection-mode tree 'browse)
180      (gtk-tree-append tree item)
181      (gtk-widget-show-all tree)
182      tree))
183
184  ;; creates the tree-item for a named group
185  (define (make-tree-item parent-name name real-name)
186    (let ((item (gtk-tree-item-new-with-label (_ real-name))))
187      (g-signal-connect
188       item "select" (group-selected parent-name name))
189      (g-signal-connect
190       item "deselect" (group-deselected parent-name name))
191      item))
192
193  ;; fills the contents of the tree associated with GROUP
194  (define (populate-branch group)
195    ;; check for sub groups
196    (fetch-group group)
197    (when (group-sub-groups group)
198      (mapc (lambda (sub)
199	      (let ((sgroup (get-group
200			     (group-name-add (group-name group) (car sub))))
201		    (item (make-tree-item (group-name group)
202					  (car sub) (cadr sub))))
203		(gtk-tree-append (group-tree group) item)
204		(when (group-tree sgroup)
205		  ;; rebuild the sub-tree of this item
206		  (make-branch item sgroup))))
207	    (group-sub-groups group))
208      (gtk-widget-show-all (group-tree group))))
209
210  ;; adds a sub-tree to ITEM representing GROUP
211  (define (make-branch item group)
212    (fetch-group group)
213    (when (group-tree group)
214      (group-tree-set group nil))
215    (when (group-sub-groups group)
216      (group-tree-set group (gtk-tree-new))
217      (populate-branch group)
218      (gtk-tree-item-set-subtree item (group-tree group))
219      (gtk-tree-item-expand item)))
220
221  (define (group-selected parent-name name)
222    ;; called when a tree node is selected
223    (lambda (item)
224      (let ((group (get-group (group-name-add parent-name name))))
225	(setq current-group group)
226
227	;; fill the contents of the branch
228	(unless (group-tree group)
229	  (make-branch item group))
230
231	;; display the slots for this group
232	(call-hook '*nokogiri-group-selected-hook* (list group)))))
233
234  (define (group-deselected parent-name name)
235    (lambda (item)
236      (declare (unused item))
237      (let ((group (get-group (group-name-add parent-name name))))
238	(call-hook '*nokogiri-group-deselected-hook* (list group))
239	(setq current-group nil))))
240
241  (define (select-group group #!key force)
242    (when (or force (not (eq current-group group)))
243      (when current-group
244	(call-hook '*nokogiri-group-deselected-hook* (list current-group)))
245      (setq current-group group)
246      (call-hook '*nokogiri-group-selected-hook* (list current-group))))
247
248  (define (redisplay-group)
249    (when current-group
250      (call-hook '*nokogiri-group-deselected-hook* (list current-group))
251      (call-hook '*nokogiri-group-selected-hook* (list current-group))))
252
253;;; util
254
255  ;; return the union of lists X and Y, using `eq' for comparisons
256  (define (unionq x y)
257    (let loop
258	((rest x)
259	 (out '()))
260      (cond ((null rest) (nreverse out))
261	    ((memq (car rest) y) (loop (cdr rest) (cons (car rest) out)))
262	    (t (loop (cdr rest) out))))))
263