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