/[climacs]/climacs/groups.lisp
ViewVC logotype

Contents of /climacs/groups.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (show annotations)
Sat Dec 8 08:55:06 2007 UTC (6 years, 4 months ago) by thenriksen
Branch: MAIN
CVS Tags: HEAD
Changes since 1.5: +95 -70 lines
Changed Climacs to use a view-paradigm. Somewhat hacky, probably buggy.
1 ;;; -*- Mode: Lisp; Package: CLIMACS-CORE -*-
2
3 ;;; (c) copyright 2006-2007 by
4 ;;; Troels Henriksen (athas@sigkill.dk)
5
6 ;;; This library is free software; you can redistribute it and/or
7 ;;; modify it under the terms of the GNU Library General Public
8 ;;; License as published by the Free Software Foundation; either
9 ;;; version 2 of the License, or (at your option) any later version.
10 ;;;
11 ;;; This library is distributed in the hope that it will be useful,
12 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 ;;; Library General Public License for more details.
15 ;;;
16 ;;; You should have received a copy of the GNU Library General Public
17 ;;; License along with this library; if not, write to the
18 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 ;;; Boston, MA 02111-1307 USA.
20
21 ;;; Implementation of a groups concept.
22
23 (in-package :climacs-core)
24
25 (defvar *persistent-groups* (make-hash-table :test #'equal)
26 "A hash table of groups that are persistent across invocations
27 of the Climacs editor. Typically, these do not designate concrete
28 pathnames, but contain more abstract designations such as \"all
29 files in the current directory\".")
30
31 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
32 ;;;
33 ;;; File/View group classes.
34
35 (defclass group (name-mixin)
36 ())
37
38 (defclass group-element (group)
39 ((%element :initarg :element :initform nil :reader element))
40 (:documentation "Group class denoting a single element"))
41
42 (defclass standard-group (group)
43 ((%elements :initarg :elements :initform nil :reader elements))
44 (:documentation "Group class denoting a sequence of elements."))
45
46 (defclass current-view-group (group)
47 ()
48 (:documentation "Group class denoting the currently active
49 view."))
50
51 (defclass synonym-group (group)
52 ((%other-name :initarg :other-name
53 :initform (error "The name of another group must be provided")
54 :reader other-name))
55 (:documentation "Group class that forwards all methods to a
56 group with a specific name."))
57
58 (defclass custom-group (group)
59 ((%list-pathnames-lambda
60 :initarg :pathname-lister
61 :initform (error "A custom group must have code for retrieving a list of pathnames")
62 :reader pathname-lister)
63 (%select-group-lambda
64 :initarg :select-response
65 :initform #'(lambda (&rest a)
66 (declare (ignore a)))
67 :reader select-response)
68 (%value-plist
69 :initform nil
70 :accessor value-plist))
71 (:documentation "A group that will call a provided function
72 when it is selected or asked for pathnames."))
73
74 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
75 ;;;
76 ;;; The group protocol.
77
78 (defgeneric group-views (group)
79 (:documentation "Get a list of views in `group'. Only already
80 existing views will be returned, use `ensure-group-views' if
81 you want all views defined by the group."))
82
83 (defgeneric ensure-group-views (group)
84 (:documentation "For each pathname in `group' that does not
85 have a corresponding view, open a view for that pathname."))
86
87 (defgeneric select-group (group)
88 (:documentation "Tell the group object `group' that the user
89 has selected it. This method is responsible for setting the
90 active group. If `group' needs additional information, it should
91 query the user when this method is invoked. The standard method
92 should be sufficient for most group classes.")
93 (:method ((group group))
94 ;; Use a synonym group so that changes to the group of this name
95 ;; will be reflected in the active group.
96 (setf (active-group *application-frame*)
97 (make-synonym-group group))))
98
99 (defgeneric display-group-contents (group stream)
100 (:documentation "Display the contents of `group' to
101 `stream'. Basically, this should describe which views or files
102 would be affected by group-aware commands if `group' was the
103 active group. There is no standard format for the output, but it
104 is intended for displaying to the user."))
105
106 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
107 ;;;
108 ;;; Protocol implementation.
109
110 ;; Display helper functions.
111 (defun normalise-group-element (element)
112 "Turn `element' into either a pathname, an existing view or
113 NIL. If a pathname is returned, it is assumed to be safe to find
114 the file with that name."
115 (typecase element
116 (drei-view
117 (find element (views *application-frame*)))
118 ((or pathname string)
119 (or (find-view-with-pathname (pathname element))
120 (when (findablep element)
121 element)))
122 (group-element
123 (normalise-group-element (element element)))))
124
125 (defun display-group-element (element stream)
126 (let ((norm-element (normalise-group-element element)))
127 (typecase norm-element
128 (drei-view
129 (present norm-element 'view stream))
130 ((or pathname string)
131 (present norm-element 'pathname stream)))))
132
133 ;; Singular group elements.
134 (defmethod group-views ((group group-element))
135 (let ((element (element group)))
136 (cond ((and (typep element 'drei-view)
137 (find element (views *application-frame*)))
138 (list element))
139 ((or (pathnamep element)
140 (stringp element))
141 (let ((view (find-view-with-pathname (pathname element))))
142 (when view (list view))))
143 (t '()))))
144
145 (defmethod ensure-group-views ((group group-element))
146 (typecase (element group)
147 (drei-view
148 (unless (find (element group) (views *application-frame*))
149 (ensure-open-file (pathname (filepath (element group))))))
150 (pathname
151 (ensure-open-file (element group)))
152 (string
153 (ensure-open-file (pathname (element group))))))
154
155 (defmethod display-group-contents ((group group-element) (stream extended-output-stream))
156 (display-group-element (element group) stream))
157
158 ;; Standard sequence groups.
159 (defmethod group-views ((group standard-group))
160 (apply #'append (mapcar #'group-views (elements group))))
161
162 (defmethod ensure-group-views ((group standard-group))
163 (mapcar #'ensure-group-views (elements group)))
164
165 (defmethod display-group-contents ((group standard-group) (stream extended-output-stream))
166 (present (remove-if #'null (mapcar #'normalise-group-element (elements group)))
167 '(sequence (or pathname view)) :stream stream))
168
169 ;; The current view group (default).
170 (defmethod group-views ((group current-view-group))
171 (list (current-view)))
172
173 (defmethod ensure-group-views ((group current-view-group))
174 nil)
175
176 (defmethod display-group-contents ((group current-view-group) (stream extended-output-stream))
177 (display-group-element (current-view) stream))
178
179 ;; Custom groups.
180 (defmethod group-views ((group custom-group))
181 (remove-if #'null (mapcar #'find-view-with-pathname (funcall (pathname-lister group) group))))
182
183 (defmethod ensure-group-views ((group custom-group))
184 (mapcar #'ensure-open-file (funcall (pathname-lister group) group)))
185
186 (defmethod select-group ((group custom-group))
187 (funcall (select-response group) group)
188 (setf (active-group *application-frame*) group))
189
190 (defmethod display-group-contents ((group custom-group) (stream extended-output-stream))
191 (present (remove-if #'null (mapcar #'normalise-group-element (funcall (pathname-lister group) group)))
192 '(sequence (or pathname view)) :stream stream))
193
194 ;; Synonym groups.
195
196 (define-condition group-not-found (simple-error)
197 ((%group-name :reader group-name
198 :initarg :group-name
199 :initform (error "A name for the group must be provided")))
200 (:report (lambda (condition stream)
201 (format stream "Group named ~a not found" (group-name condition))))
202 (:documentation "This condition is signaled whenever a synonym
203 group is unable to find the group that it is supposed to
204 forward method invocations to."))
205
206 (defmethod group-views ((group synonym-group))
207 (if (get-group (other-name group))
208 (group-views (get-group (other-name group)))
209 (error 'group-not-found :group-name (other-name group))))
210
211 (defmethod ensure-group-views ((group synonym-group))
212 (if (get-group (other-name group))
213 (ensure-group-views (get-group (other-name group)))
214 (error 'group-not-found :group-name (other-name group))))
215
216 (defmethod select-group ((group synonym-group))
217 (if (get-group (other-name group))
218 (select-group (get-group (other-name group)))
219 (error 'group-not-found :group-name (other-name group))))
220
221 (defmethod display-group-contents ((group synonym-group) stream)
222 (if (get-group (other-name group))
223 (display-group-contents (get-group (other-name group)) stream)
224 (error 'group-not-found :group-name (other-name group))))
225
226 ;; Util stuff.
227 (defun make-synonym-group (group)
228 "Create and return a synonym group that refers to `group'. All
229 group protocol-specified methods called on the synonym group will
230 be forwarded to a group with the same name as `group'."
231 (make-instance 'synonym-group
232 :other-name (name group)
233 :name (name group)))
234
235 (defun make-group-element (object)
236 "Make a `group-element' object containg `object' as element."
237 (make-instance 'group-element :element object))
238
239 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
240 ;;;
241 ;;; Interface
242
243 (defun add-group (name elements)
244 "Define a group called `name' (a string) containing the elements `elements',
245 which must be a list of pathnames and/or views, and add it to
246 the list of defined groups."
247 (setf (gethash name (groups *application-frame*))
248 (make-instance
249 'standard-group
250 :name name
251 :elements (mapcar #'make-group-element elements))))
252
253 (defun get-group (name)
254 "Return the group with the name `name'."
255 (or (gethash name (groups *application-frame*))
256 (gethash name *persistent-groups*)))
257
258 (defun get-active-group ()
259 "Return the currently active group."
260 (or (active-group *application-frame*)
261 (deselect-group)))
262
263 (defun deselect-group ()
264 "Deselect the currently active group."
265 (setf (active-group *application-frame*)
266 (make-instance 'current-view-group
267 :name "none")))
268
269 (defmacro with-group-views ((views group &key keep) &body body)
270 "Make sure that all files designated by `group' are open in
271 views during the evaluation of `body'. If `keep' is NIL, all
272 views created by this macro will be saved and killed after
273 `body' has run. Also, `views' will be bound to a list of the
274 views containing the files designated by `group' while `body'
275 is run."
276 (with-gensyms (views-before views-after view-diff)
277 (once-only (group keep)
278 `(let ((,views-before (views *application-frame*))
279 (,group ,group))
280 (ensure-group-views ,group)
281 (let* ((,views-after (views *application-frame*))
282 (,view-diff (set-difference ,views-after
283 ,views-before))
284 (,views (group-views ,group)))
285 (unwind-protect (progn ,@body)
286 (unless ,keep
287 (loop for view in ,view-diff
288 do (save-view view)
289 do (kill-view view)))))))))
290
291 (defmacro define-group (name (group-arg &rest args) &body body)
292 "Define a persistent group named `name'. `Body' should return a
293 list of pathnames and will be used to calculate which files are
294 designated by the group. `Args' should be two-element lists, with
295 the first element bound to the result of evaluating the second
296 element. The second element will be evaluated when the group is
297 selected to be the active group by the user."
298 (with-gensyms (group)
299 (once-only (name)
300 `(let ((,name ,name))
301 (assert (stringp ,name))
302 (setf (gethash ,name *persistent-groups*)
303 (make-instance 'custom-group
304 :name ,name
305 :pathname-lister #'(lambda (,group)
306 (destructuring-bind
307 (&key ,@(mapcar #'(lambda (arg)
308 `((,arg ,arg)))
309 (mapcar #'first args)))
310 (value-plist ,group)
311 (let ((,group-arg ,group))
312 ,@body)))
313 :select-response #'(lambda (group)
314 (declare (ignorable group))
315 ,@(loop for (name form) in args
316 collect `(setf (getf (value-plist group) ',name) ,form)))))))))
317
318 (define-group "Current Directory Files" (group)
319 (declare (ignore group))
320 (directory (make-pathname :directory (pathname-directory (filepath (current-view)))
321 :name :wild
322 :type :wild)))
323
324 (define-group "Directory Files" (group (directory (accept 'pathname
325 :prompt "Directory"
326 :default (directory-of-buffer (buffer (current-view)))
327 :insert-default t)))
328 (declare (ignore group))
329 (directory (make-pathname :directory (pathname-directory directory)
330 :name :wild
331 :type :wild)))
332
333 (define-group "Directory Lisp Files" (group (directory (accept 'pathname
334 :prompt "Directory"
335 :default (directory-of-buffer (buffer (current-view)))
336 :insert-default t)))
337 (declare (ignore group))
338 (directory (make-pathname :directory (pathname-directory directory)
339 :name :wild
340 :type "lisp")))
341
342 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
343 ;;;
344 ;;; CLIM interface stuff.
345
346 (define-presentation-method accept
347 ((type group) stream view &key (default nil defaultp)
348 (default-type type))
349 (multiple-value-bind (object success string)
350 (complete-input stream
351 (lambda (so-far action)
352 (complete-from-possibilities
353 so-far
354 (append (loop for key being the hash-keys of (groups *application-frame*)
355 collecting key)
356 (loop for key being the hash-keys of *persistent-groups*
357 collecting key))
358 '(#\Space)
359 :action action
360 :name-key #'identity
361 :value-key #'identity))
362 :partial-completers '(#\Space)
363 :allow-any-input nil)
364 (cond (success
365 (values (get-group object) type))
366 ((and (zerop (length string)) defaultp)
367 (values default default-type))
368 (t (values string 'string)))))
369
370 (define-presentation-method present (object (type group) stream view &key)
371 (let ((name (name object)))
372 (princ name stream)))
373
374 (define-presentation-method present ((object synonym-group) (type group) stream view &key)
375 (if (get-group (other-name object))
376 (present (get-group (other-name object)) type :stream stream :view view)
377 (error 'group-not-found :group-name (other-name object))))
378
379 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
380 ;;;
381 ;;; Now hook it all up.
382
383 (defclass group-target-specification (view-list-target-specification)
384 ((%group :initarg :group
385 :reader group
386 :initform (error "A group must be provided for a group target specification")))
387 (:documentation "The target-specification class used for groups
388 in Climacs."))
389
390 (defmethod activate-target-specification ((spec group-target-specification))
391 (ensure-group-views (group spec))
392 (setf (views spec) (group-views (group spec)))
393 (call-next-method))
394
395 (defmethod next-target :around ((spec group-target-specification))
396 (handler-bind ((view-already-displayed
397 #'(lambda (c)
398 (declare (ignore c))
399 (invoke-restart 'remove-other-use))))
400 (call-next-method)))
401
402 (defmethod previous-target :around ((spec group-target-specification))
403 (handler-bind ((view-already-displayed
404 #'(lambda (c)
405 (declare (ignore c))
406 (invoke-restart 'remove-other-use))))
407 (call-next-method)))
408
409 (setf *climacs-target-creator*
410 #'(lambda (drei)
411 (make-instance 'group-target-specification
412 :group (get-active-group)
413 :drei-instance drei)))

  ViewVC Help
Powered by ViewVC 1.1.5