/[mcclim]/mcclim/presentation-defs.lisp
ViewVC logotype

Contents of /mcclim/presentation-defs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.80 - (show annotations)
Wed Jan 21 06:48:08 2009 UTC (5 years, 3 months ago) by rstrandh
Branch: MAIN
CVS Tags: HEAD
Changes since 1.79: +2 -4 lines
Another fix from Mike Watters.
1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2
3 ;;; (c) copyright 2001,2002 by Tim Moore (moore@bricoworks.com)
4 ;;; This library is free software; you can redistribute it and/or
5 ;;; modify it under the terms of the GNU Library General Public
6 ;;; License as published by the Free Software Foundation; either
7 ;;; version 2 of the License, or (at your option) any later version.
8 ;;;
9 ;;; This library is distributed in the hope that it will be useful,
10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 ;;; Library General Public License for more details.
13 ;;;
14 ;;; You should have received a copy of the GNU Library General Public
15 ;;; License along with this library; if not, write to the
16 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
17 ;;; Boston, MA 02111-1307 USA.
18
19 ;;; Definitions for the standard presentation types and generic functions
20
21 (in-package :clim-internals)
22
23 ;;; The presentation type for T is the built-in type T. The correspondence is
24 ;;; established by hand in presentations.lisp.
25 ;(define-presentation-type t ())
26
27 ;;; auto-activate is described in the Franz user guide; it controls whether an
28 ;;; accepting an expression returns immediately after typing the closing
29 ;;; delimiter -- a la Genera et Mac Lisp -- or if an activation gesture is
30 ;;; required.
31 ;;; preserve-whitespace controls whether the accept method uses read or
32 ;;; read-preserving-whitespace. This is used in our redefinitions of read and
33 ;;; read-preserving-whitespace that accept forms.
34
35 (define-presentation-type expression ()
36 :options (auto-activate (preserve-whitespace t) (subform-read nil))
37 :inherit-from t)
38
39
40 (define-presentation-type form ()
41 :options (auto-activate (preserve-whitespace t) (subform-read nil))
42 :inherit-from `((expression) :auto-activate ,auto-activate
43 :preserve-whitespace ,preserve-whitespace
44 :subform-read ,subform-read ))
45
46 ;;; Actual definitions of presentation methods and types. They've
47 ;;; been separated from the macro and presentation class definitions and
48 ;;; helper functions in order to avoid putting all of presentations.lisp
49 ;;; inside a (eval-when (compile) ...).
50
51 (define-presentation-generic-function %presentation-typep presentation-typep
52 (type-key parameters object type))
53
54 (define-default-presentation-method presentation-typep (object type)
55 (declare (ignore object type))
56 nil)
57
58 (defun presentation-typep (object type)
59 (with-presentation-type-decoded (name parameters)
60 type
61 (when (null parameters)
62 (let ((clos-class (find-class name nil))) ; Don't error out.
63 (when (and clos-class (typep clos-class 'standard-class))
64 (return-from presentation-typep (typep object name)))))
65 (funcall-presentation-generic-function presentation-typep object type)))
66
67 ;;; Not defined as a generic function, but what the hell.
68
69 (defgeneric presentation-type-of (object))
70
71 (defmethod presentation-type-of (object)
72 (declare (ignore object))
73 'expression)
74
75 (defun get-ptype-from-class-of (object)
76 (let* ((name (class-name (class-of object)))
77 (ptype-entry (gethash name *presentation-type-table*)))
78 (unless ptype-entry
79 (return-from get-ptype-from-class-of nil))
80 ;; Does the type have required parameters? If so, we can't use it...
81 (let ((parameter-ll (parameters-lambda-list ptype-entry)))
82 (values name
83 (if (eq (car parameter-ll) '&whole)
84 (cddr parameter-ll)
85 parameter-ll)))))
86
87 (defmethod presentation-type-of ((object standard-object))
88 (multiple-value-bind (name lambda-list)
89 (get-ptype-from-class-of object)
90 (cond ((and name
91 (or (null lambda-list)
92 (member (first lambda-list) lambda-list-keywords)))
93 name)
94 (name
95 'standard-object)
96 (t (let* ((class (class-of object))
97 (class-name (class-name class)))
98 (or class-name class))))))
99
100 (defmethod presentation-type-of ((object structure-object))
101 (multiple-value-bind (name lambda-list)
102 (get-ptype-from-class-of object)
103 (if (and name
104 (or (null lambda-list)
105 (member lambda-list lambda-list-keywords)))
106 name
107 (call-next-method))))
108
109 (define-presentation-generic-function
110 %map-over-presentation-type-supertypes
111 map-over-presentation-type-supertypes
112 (type-key function type))
113
114 ;;; Define the method for presentation and clos types
115 (define-default-presentation-method map-over-presentation-type-supertypes
116 (function type)
117 (let ((type-name (presentation-type-name type)))
118 (map-over-ptype-superclasses
119 #'(lambda (super)
120 (let ((super-name (type-name super)))
121 (funcall function
122 super-name
123 (funcall (expansion-function super)
124 (translate-specifier-for-type type-name
125 super-name
126 type)))))
127 type-name)))
128
129 (defun map-over-presentation-type-supertypes (function type)
130 (funcall-presentation-generic-function map-over-presentation-type-supertypes
131 function
132 type))
133
134 (define-presentation-generic-function
135 %presentation-subtypep
136 presentation-subtypep
137 (type-key type putative-supertype))
138
139 ;;; The semantics of the presentation method presentation-subtypep are truly
140 ;;; weird; method combination is in effect disabled. So, the methods have to
141 ;;; be eql methods.
142
143 (defmacro define-subtypep-method (&rest args)
144 (let ((gf (gethash 'presentation-subtypep *presentation-gf-table*)))
145 (multiple-value-bind (qualifiers lambda-list decls body)
146 (parse-method-body args)
147 (let ((type-arg (nth (1- (type-arg-position gf)) lambda-list)))
148
149 (unless (consp type-arg)
150 (error "Type argument in presentation method must be specialized"))
151 (unless (eq (car type-arg) 'type)
152 (error "Type argument mismatch with presentation generic function
153 definition"))
154 (destructuring-bind (type-var type-name) type-arg
155 (let ((method-ll `((,(type-key-arg gf)
156 (eql (prototype-or-error ',type-name)))
157 ,@(copy-list lambda-list))))
158 (setf (nth (type-arg-position gf) method-ll) type-var)
159 `(defmethod %presentation-subtypep ,@qualifiers ,method-ll
160 (declare (ignorable ,(type-key-arg gf))
161 ,@(cdr decls))
162 (block presentation-subtypep
163 ,@body))))))))
164
165 ;;; PRESENTATION-SUBTYPEP suffers from some of the same problems as
166 ;;; CL:SUBTYPEP, most (but sadly not all) of which were solved in
167 ;;; H. Baker "A Decision Procedure for SUBTYPEP"; additionally, it
168 ;;; suffers from the behaviour being underspecified, as CLIM
169 ;;; documentation did not have the years of polish that CLtS did.
170 ;;;
171 ;;; So you might wonder why, instead of copying or using directly some
172 ;;; decent Public Domain subtype code (such as that found in SBCL,
173 ;;; implementing CL:SUBTYPEP), there's this slightly wonky
174 ;;; implementation here. Well, some of the answer lies in the fact
175 ;;; that the subtype relationships answered by this predicate are not
176 ;;; in fact analogous to CL's type system. The major use of
177 ;;; PRESENTATION-SUBTYPEP seems to be for determining whether a
178 ;;; presentation is applicable as input to a translator (including the
179 ;;; default translator, transforming an object to itself); actually,
180 ;;; the first step is taken by STUPID-SUBTYPEP, but that I believe is
181 ;;; simply intended to be a short-circuiting conservative version of
182 ;;; PRESENTATION-SUBTYPEP.
183 ;;;
184 ;;; Most presentation types in CLIM are hierarchically arranged by
185 ;;; single-inheritance, and SUBTYPEP relations on the hierarchy are
186 ;;; easy to determine: simply walk up the hierarchy until you find the
187 ;;; putative supertype (in which case the answer is T, T unless the
188 ;;; type's parameters are wrong) or you find the universal supertype
189 ;;; (in which case the answer is NIL, T. There are numerous wrinkles,
190 ;;; however...
191 ;;;
192 ;;; (1) the NIL presentation type is the universal subtype, breaking
193 ;;; the single-inheritance of the hierarchy. This isn't too bad,
194 ;;; because it can be special-cased.
195 ;;;
196 ;;; (2) union types can be constructed, destroying the
197 ;;; single-inheritance hierarchy (when used as a subtype).
198 ;;;
199 ;;; (3) union types can give rise to ambiguity. For example, is the
200 ;;; NUMBER presentation type subtypep (OR REAL COMPLEX)? What
201 ;;; about (INTEGER 3 6) subtypep (OR (INTEGER 3 4) (INTEGER 5 6))?
202 ;;; Is (OR A B) subtypep (OR B A)? The answer to this last
203 ;;; question is not obvious, as the two types have different
204 ;;; ACCEPT behaviour if A and B have any Lisp objects in common,
205 ;;; even if the presentation types are hierarchically unrelated...
206 ;;;
207 ;;; (4) intersection types can be constructed, destroying the
208 ;;; single-inheritance hierarchy (when used as a supertype). This
209 ;;; is partially mitigated by the explicit documentation that the
210 ;;; first type in the AND type's parameters is privileged and
211 ;;; treated specially by ACCEPT.
212 ;;;
213 ;;; Given these difficulties, I'm aiming for roughly expected
214 ;;; behaviour from STUPID- and PRESENTATION-SUBTYPEP, rather than
215 ;;; something which has a comprehensive understanding of presentation
216 ;;; types and the Lisp object universe (as this would be unachievable
217 ;;; anyway: the user can write arbitrary PRESENTATION-TYPEP
218 ;;; functions); PRESENTATION-SUBTYPEP should not be thought of as a
219 ;;; predicate over sets of Lisp objects, but simply a formal predicate
220 ;;; over a graph of names. This gives rise to the implementation
221 ;;; below for OR and AND types, and the hierarchical walk for all
222 ;;; other types. CSR, 2007-01-10
223 (defun presentation-subtypep (type maybe-supertype)
224 ;; special shortcuts: the universal subtype is privileged (and
225 ;; doesn't in fact fit into a hierarchical lattice); the universal
226 ;; supertype is easy to identify.
227 (when (or (eql type nil) (eql maybe-supertype t))
228 (return-from presentation-subtypep (values t t)))
229 (when (eql type maybe-supertype)
230 (return-from presentation-subtypep (values t t)))
231 (with-presentation-type-decoded (super-name super-parameters)
232 maybe-supertype
233 (with-presentation-type-decoded (type-name type-parameters)
234 type
235 (cond
236 ;; DO NOT BE TEMPTED TO REARRANGE THESE CLAUSES
237 ((eq type-name 'or)
238 (dolist (or-type type-parameters
239 (return-from presentation-subtypep (values t t)))
240 (multiple-value-bind (yesp surep)
241 (presentation-subtypep or-type maybe-supertype)
242 (unless yesp
243 (return-from presentation-subtypep (values yesp surep))))))
244 ((eq super-name 'and)
245 (let ((result t))
246 (dolist (and-type super-parameters
247 (return-from presentation-subtypep (values result result)))
248 (cond
249 ((and (consp and-type) (eq (car and-type) 'satisfies))
250 (setq result nil))
251 ((and (consp and-type) (eq (car and-type) 'not))
252 (multiple-value-bind (yp sp)
253 (presentation-subtypep type (cadr and-type))
254 (if yp
255 (return-from presentation-subtypep (values nil t))
256 (setq result nil))))
257 (t (multiple-value-bind (yp sp)
258 (presentation-subtypep type and-type)
259 (unless yp
260 (if sp
261 (return-from presentation-subtypep (values nil t))
262 (setq result nil)))))))))
263 ((eq super-name 'or)
264 (assert (not (eq type-name 'or)))
265 ;; FIXME: this would be the right method were it not for the
266 ;; fact that there can be unions 'in disguise' in the
267 ;; subtype; examples:
268 ;; (PRESENTATION-SUBTYPEP 'NUMBER '(OR REAL COMPLEX))
269 ;; (PRESENTATION-SUBTYPEP '(INTEGER 3 6)
270 ;; '(OR (INTEGER 2 5) (INTEGER 4 7)))
271 ;; Sorry about that.
272 (let ((surep t))
273 (dolist (or-type super-parameters
274 (return-from presentation-subtypep (values nil surep)))
275 (multiple-value-bind (yp sp)
276 (presentation-subtypep type or-type)
277 (cond
278 (yp (return-from presentation-subtypep (values t t)))
279 ((not sp) (setq surep nil)))))))
280 ((eq type-name 'and)
281 (assert (not (eq super-name 'and)))
282 (multiple-value-bind (yp sp)
283 (presentation-subtypep (car type-parameters) maybe-supertype)
284 (return-from presentation-subtypep (values yp yp))))))
285 (map-over-presentation-type-supertypes
286 #'(lambda (name massaged)
287 (when (eq name super-name)
288 (return-from presentation-subtypep
289 (funcall-presentation-generic-function presentation-subtypep
290 massaged
291 maybe-supertype))))
292 type))
293 (values nil t))
294
295 (define-default-presentation-method presentation-subtypep
296 (type maybe-supertype)
297 (with-presentation-type-decoded (name params)
298 type
299 (declare (ignore name))
300 (with-presentation-type-decoded (super-name super-params)
301 maybe-supertype
302 (declare (ignore super-name))
303 (if (equal params super-params)
304 (values t t)
305 (values nil nil)))))
306
307 (define-presentation-generic-function
308 %presentation-type-specifier-p
309 presentation-type-specifier-p
310 (type-class type))
311
312 (define-default-presentation-method presentation-type-specifier-p (type)
313 t)
314
315 (defun presentation-type-specifier-p (object)
316 "Return true if `object' is a valid presentation type specifier,
317 otherwise return false."
318 ;; Apparently, this funtion has to handle arbitrary objects.
319 (let ((name (presentation-type-name object)))
320 (when (and (typep name '(or symbol class))
321 (get-ptype-metaclass name))
322 (funcall-presentation-generic-function presentation-type-specifier-p object))))
323
324 (defun default-describe-presentation-type (description stream plural-count)
325 (if (symbolp description)
326 (setq description (make-default-description (symbol-name description))))
327 (cond ((eql 1 plural-count)
328 (format stream "~:[a~;an~] ~A"
329 (find (char description 0) "aeiouAEIOU")
330 description))
331 ((numberp plural-count)
332 (format stream "~D ~A~P" plural-count description plural-count))
333 (plural-count
334 (format stream "~As" description))
335 (t (write-string description stream))))
336
337 (define-presentation-generic-function %describe-presentation-type
338 describe-presentation-type
339 (type-key parameters options type stream plural-count ))
340
341 ;;; Support for the default method on describe-presentation-type: if a CLOS
342 ;;; class has been defined as a presentation type, get description out of the
343 ;;; presentation type.
344
345 (defmethod description ((class standard-class))
346 (let* ((name (class-name class))
347 (ptype-entry (gethash name *presentation-type-table*)))
348 (if ptype-entry
349 (description ptype-entry)
350 (make-default-description name))))
351
352 (define-default-presentation-method describe-presentation-type
353 (type stream plural-count)
354 (with-presentation-type-decoded (name parameters options)
355 type
356 (declare (ignore name parameters))
357 (let ((description (or (getf options :description)
358 (description (class-of type-key)))))
359 (default-describe-presentation-type description
360 stream
361 plural-count))))
362
363 (defun describe-presentation-type (type
364 &optional
365 (stream *standard-output*)
366 (plural-count 1))
367 (flet ((describe-it (stream)
368 (funcall-presentation-generic-function describe-presentation-type
369 type
370 stream
371 plural-count)))
372 (if stream
373 (describe-it stream)
374 (with-output-to-string (s)
375 (describe-it s)))))
376
377 (define-presentation-generic-function %presentation-default-processor
378 presentation-default-processor
379 (type-key parameters default type &key default-type))
380
381 (define-default-presentation-method presentation-default-processor
382 (default type &key (default-type nil default-type-p))
383 (values default (if default-type-p
384 default-type
385 type)))
386
387 ;;; XXX The spec calls out that the presentation generic function has keyword
388 ;;; arguments acceptably and for-context-type, but the examples I've seen don't
389 ;;; mention them at all in the methods defined for present. So, leave them out
390 ;;; of the generic function lambda list...
391 (define-presentation-generic-function %present present
392 (type-key parameters options object type stream view
393 &key &allow-other-keys))
394
395 (defun present (object &optional (type (presentation-type-of object))
396 &key
397 (stream *standard-output*)
398 (view (stream-default-view stream))
399 modifier
400 acceptably
401 (for-context-type type)
402 single-box
403 (allow-sensitive-inferiors t)
404 (sensitive t)
405 (record-type 'standard-presentation))
406 (let* ((real-type (expand-presentation-type-abbreviation type))
407 (context-type (if (eq for-context-type type)
408 real-type
409 (expand-presentation-type-abbreviation
410 for-context-type))))
411 (stream-present stream object real-type
412 :view view :modifier modifier :acceptably acceptably
413 :for-context-type context-type :single-box single-box
414 :allow-sensitive-inferiors allow-sensitive-inferiors
415 :sensitive sensitive
416 :record-type record-type)))
417
418 (defgeneric stream-present (stream object type
419 &key view modifier acceptably for-context-type
420 single-box allow-sensitive-inferiors sensitive
421 record-type))
422
423 (defmethod stream-present ((stream output-recording-stream) object type
424 &key
425 (view (stream-default-view stream))
426 modifier
427 acceptably
428 (for-context-type type)
429 single-box
430 (allow-sensitive-inferiors t)
431 (sensitive t)
432 (record-type 'standard-presentation))
433 ;; *allow-sensitive-inferiors* controls whether or not
434 ;; with-output-as-presentation will emit a presentation
435 (let ((*allow-sensitive-inferiors* (and *allow-sensitive-inferiors*
436 sensitive)))
437 (with-output-as-presentation (stream object type
438 :view view
439 :modifier modifier
440 :single-box single-box
441 :allow-sensitive-inferiors
442 allow-sensitive-inferiors
443 :record-type record-type)
444 (funcall-presentation-generic-function
445 present object type stream view
446 :acceptably acceptably :for-context-type for-context-type))))
447
448 ;;; Should work well enough on non-CLIM streams...
449 (defmethod stream-present (stream object type
450 &key
451 (view +textual-view+)
452 modifier
453 acceptably
454 (for-context-type type)
455 single-box
456 (allow-sensitive-inferiors t)
457 (sensitive t)
458 (record-type 'standard-presentation))
459 (declare (ignore modifier single-box allow-sensitive-inferiors sensitive
460 record-type))
461 (funcall-presentation-generic-function
462 present object type stream view
463 :acceptably acceptably :for-context-type for-context-type)
464 nil)
465
466 (defun present-to-string (object &optional (type (presentation-type-of object))
467 &key (view +textual-view+)
468 acceptably
469 (for-context-type type)
470 (string nil stringp)
471 (index 0 indexp))
472 (let* ((real-type (expand-presentation-type-abbreviation type))
473 (context-type (if (eq for-context-type type)
474 real-type
475 (expand-presentation-type-abbreviation
476 for-context-type))))
477 (when (and stringp indexp)
478 (setf (fill-pointer string) index))
479 (flet ((do-present (s)
480 (stream-present s object real-type
481 :view view :acceptably acceptably
482 :for-context-type context-type)))
483 (declare (dynamic-extent #'do-present))
484 (let ((result (if stringp
485 (with-output-to-string (stream string)
486 (do-present stream))
487 (with-output-to-string (stream)
488 (do-present stream)))))
489 (if stringp
490 (values string (fill-pointer string))
491 result)))))
492
493 ;;; I believe this obsolete... --moore
494 (defmethod presentation-replace-input
495 ((stream input-editing-stream) object type view
496 &key (buffer-start nil buffer-start-supplied-p)
497 (rescan nil rescan-supplied-p)
498 query-identifier
499 (for-context-type type))
500 (declare (ignore query-identifier))
501 (let ((result (present-to-string object type
502 :view view :acceptably nil
503 :for-context-type for-context-type)))
504 (apply #'replace-input stream result `(,@(and buffer-start-supplied-p
505 `(:buffer-start
506 ,buffer-start))
507 ,@(and rescan-supplied-p
508 `(:rescan ,rescan))))))
509
510 ;;; Presentation histories.
511
512 ;;; This allocates a hash table even if the frame doesn't support
513 ;;; histories! I'm over it already. -- moore
514 (defclass presentation-history-mixin ()
515 ((presentation-history :accessor frame-presentation-history
516 :initform (make-hash-table :test #'eq)))
517 (:documentation "Mixin class for frames that implements presentation
518 type histories"))
519
520 (define-presentation-generic-function %presentation-type-history
521 presentation-type-history
522 (type-key parameters type))
523
524 ;;; This function should exist for convenience even if not mentioned in the
525 ;;; spec.
526
527 (defun presentation-type-history (type)
528 (funcall-presentation-generic-function presentation-type-history type))
529
530 (defclass presentation-history ()
531 ((stack :accessor presentation-history-array
532 :initform (make-array 1 :fill-pointer 0
533 :adjustable t)
534 :documentation "The history, with the newest objects at
535 the end of the array. Should contain conses with the car being
536 the object and the cdr being the type.")
537 (pointer :accessor presentation-history-pointer
538 :initform nil
539 :documentation "The index of the \"current\" object,
540 used when navigating the history. If NIL, means that no
541 navigation has yet been performed."))
542 (:documentation "Class for objects that contain the history for
543 a specific type."))
544
545 (define-default-presentation-method presentation-type-history (type)
546 (if (and *application-frame*
547 (frame-maintain-presentation-histories *application-frame*))
548 (with-presentation-type-decoded (name)
549 type
550 (let* ((ptype (get-ptype-metaclass name))
551 (history (history ptype)))
552 (case history
553 ((t)
554 (let* ((history-table (frame-presentation-history
555 *application-frame*))
556 (history-object (gethash name history-table)))
557 (unless history-object
558 (setf history-object
559 (make-instance 'presentation-history)
560 (gethash name history-table)
561 history-object))
562 history-object))
563 (nil
564 nil)
565 (otherwise
566 (funcall-presentation-generic-function presentation-type-history
567 type)))))))
568
569 ;;; Not in the spec, but I think this is necessary (or at any rate, the easiest
570 ;;; way) to control whether or not to use histories in a given context.
571 (define-presentation-generic-function %presentation-type-history-for-stream
572 presentation-type-history-for-stream
573 (type-key parameters type stream)
574 (:documentation "Returns a type history or nil for a presentation TYPE and
575 STREAM. This is used by McCLIM to decide whether or not to use histories in a
576 given situation. A primary method specialized on just the type should
577 call-next-method to get the \"real\" answer based on the stream type."))
578
579 (define-default-presentation-method presentation-type-history-for-stream
580 (type stream)
581 (declare (ignore stream))
582 nil)
583
584 ;;; method for clim-stream-pane in panes.lisp
585
586 (define-presentation-method presentation-type-history-for-stream
587 ((type t) (stream input-editing-stream))
588 ;; What is the purpose of this? Makes stuff harder to do, so
589 ;; commented out...
590 ;;(if (not (stream-rescanning-p stream))
591 ;; (funcall-presentation-generic-function presentation-type-history type)
592 ;; nil)
593 (funcall-presentation-generic-function presentation-type-history type))
594
595 (defun presentation-history-insert (history object ptype)
596 "Unconditionally insert `object' as an input of presentation
597 type `type' at the top of the presentation history `history', as
598 the most recently added object."
599 (vector-push-extend (cons object ptype)
600 (presentation-history-array history)))
601
602 (defun presentation-history-top (history ptype)
603 "Find the topmost (most recently added object) of `history'
604 that is of the presentation type `ptype' or a subtype. Two values
605 will be returned, the object and the presentation type of the
606 object. If no applicable object can be found, these values will
607 both be NIL."
608 (loop
609 with array = (presentation-history-array history)
610 for index from (1- (fill-pointer array)) downto 0
611 for (object . object-ptype) = (aref array index)
612 do
613 (when (presentation-subtypep object-ptype ptype)
614 (return (aref array index)))
615 finally (return (values nil nil))))
616
617 (defun presentation-history-reset-pointer (history)
618 "Set the pointer to point at the object most recently added
619 object."
620 (setf (presentation-history-pointer history) nil))
621
622 (defun presentation-history-next (history ptype)
623 "Go to the next input (forward in time) in `history' that is a
624 presentation-subtype of `ptype', respective to the pointer in
625 `history'. Returns two values: the found object and its
626 presentation type, both of which will be NIL if no applicable
627 object can be found."
628 (with-accessors ((pointer presentation-history-pointer)
629 (array presentation-history-array)) history
630 ;; If no navigation has been performed, we have no object to go
631 ;; forwards to.
632 (if (or (null pointer) (>= (1+ pointer) (length array)))
633 (values nil nil)
634 (progn
635 (incf pointer)
636 (destructuring-bind (object . object-ptype)
637 (aref array pointer)
638 (if object-ptype
639 (if (presentation-subtypep object-ptype ptype)
640 (values object object-ptype)
641 (presentation-history-next history ptype))
642 (values nil nil)))))))
643
644 (defun presentation-history-previous (history ptype)
645 "Go to the previous input (backward in time) in `history' that
646 is a presentation-subtype of `ptype', respective to the pointer
647 in `history'. Returns two values: the found object and its
648 presentation type, both of which will be NIL if no applicable
649 object can be found."
650 (with-accessors ((pointer presentation-history-pointer)
651 (array presentation-history-array)) history
652 (if (and (numberp pointer) (zerop pointer))
653 (values nil nil)
654 (progn
655 (cond ((and (numberp pointer) (plusp pointer))
656 (decf pointer))
657 ((plusp (length array))
658 (setf pointer (1- (fill-pointer array)))))
659 (if (and (numberp pointer) (array-in-bounds-p array pointer))
660 (destructuring-bind (object . object-ptype)
661 (aref array pointer)
662 (if object-ptype
663 (if (presentation-subtypep object-ptype ptype)
664 (values object object-ptype)
665 (progn (presentation-history-previous history ptype)))
666 (values nil nil)))
667 (values nil nil))))))
668
669 (defmacro with-object-on-history ((history object ptype) &body body)
670 "Evaluate `body' with `object' as `ptype' as the head (most
671 recently added object) on `history', and remove it again after
672 `body' has run. If `body' as `ptype' is already the head, the
673 history will be unchanged."
674 (with-gensyms (added)
675 `(let ((,added (presentation-history-add ,history ,object ,ptype)))
676 (unwind-protect (progn ,@body)
677 (when ,added
678 (decf (fill-pointer (presentation-history-array ,history))))))))
679
680 (defun presentation-history-add (history object ptype)
681 "Add OBJECT and PTYPE to the HISTORY unless they are already at the head of
682 HISTORY"
683 (multiple-value-bind (top-object top-ptype)
684 (presentation-history-top history ptype)
685 (unless (and top-ptype (eql object top-object) (equal ptype top-ptype))
686 (presentation-history-insert history object ptype))))
687
688 (define-presentation-generic-function %accept accept
689 (type-key parameters options type stream view &key))
690
691 (defvar *recursive-accept-p* nil)
692 (defvar *recursive-accept-1-p* nil)
693 (defvar *active-history-type* nil)
694
695 ;;; The spec says "default-type most be a presentation type specifier", but the
696 ;;; examples we have imply that default-type is optional, so we'll be liberal
697 ;;; in what we accept.
698
699 (defun accept (type &rest rest-args &key
700 (stream *standard-input*)
701 (view nil viewp)
702 (default nil defaultp)
703 (default-type nil default-type-p)
704 provide-default insert-default replace-input
705 (history nil historyp) ; true default supplied below
706 active-p ; Don't think this will be used
707 prompt prompt-mode display-default
708 query-identifier
709 activation-gestures additional-activation-gestures
710 delimiter-gestures additional-delimiter-gestures)
711 (declare (ignore insert-default replace-input active-p prompt prompt-mode
712 display-default query-identifier
713 activation-gestures additional-activation-gestures
714 delimiter-gestures additional-delimiter-gestures))
715 (handler-bind ((abort-gesture (lambda (condition)
716 (signal condition) ;; to give outer handlers a chance to say "I know how to handle this"
717 (abort condition))))
718 (let* ((real-type (expand-presentation-type-abbreviation type))
719 (real-default-type (cond (default-type-p
720 (expand-presentation-type-abbreviation
721 default-type))
722 ((or defaultp provide-default)
723 real-type)
724 (t nil)))
725 (real-history-type (cond ((null historyp) real-type)
726 ((null history) nil)
727 (t (expand-presentation-type-abbreviation
728 history))))
729 (*recursive-accept-p* *recursive-accept-1-p*)
730 (*recursive-accept-1-p* t))
731 (with-keywords-removed (rest-args (:stream))
732 (when (or default-type-p defaultp)
733 (setf rest-args
734 (list* :default-type real-default-type rest-args)))
735 (when historyp
736 (setf rest-args (list* :history real-history-type rest-args)))
737 (cond ((and viewp (symbolp view))
738 (setf rest-args
739 (list* :view (funcall #'make-instance view) rest-args)))
740 ((consp view)
741 (setf rest-args
742 (list* :view (apply #'make-instance view) rest-args))))
743 ;; Presentation type history interaction. According to the spec,
744 ;; if provide-default is true, we take the default from the
745 ;; presentation history. In addition, we'll implement the Genera
746 ;; behavior of temporarily putting the default on the history
747 ;; stack so the user can conveniently suck it in.
748 (labels ((get-history ()
749 (when real-history-type
750 (funcall-presentation-generic-function
751 presentation-type-history-for-stream
752 real-history-type stream)))
753 (do-accept (args)
754 (apply #'stream-accept stream real-type args)))
755 (let* ((default-from-history (and (not defaultp) provide-default))
756 (history (get-history))
757 (results
758 (multiple-value-list
759 (if history
760 (unwind-protect
761 (let ((*active-history-type* real-history-type))
762 (cond (defaultp
763 (with-object-on-history
764 (history default real-default-type)
765 (do-accept rest-args)))
766 (default-from-history
767 (multiple-value-bind
768 (history-default history-type)
769 (presentation-history-top history
770 real-default-type)
771 (do-accept (if history-type
772 (list* :default history-default
773 :default-type history-type
774 rest-args)
775 rest-args))))
776 (t (do-accept rest-args))))
777 (unless *recursive-accept-p*
778 (presentation-history-reset-pointer (get-history))))
779 (do-accept rest-args))))
780 (results-history (get-history)))
781 (when results-history
782 (presentation-history-add results-history
783 (car results)
784 real-type))
785 (values-list results)))))))
786
787 (defmethod stream-accept ((stream standard-extended-input-stream) type
788 &rest args
789 &key (view (stream-default-view stream))
790 &allow-other-keys)
791 (apply #'prompt-for-accept stream type view args)
792 (apply #'accept-1 stream type args))
793
794 (defmethod stream-accept ((stream #.*string-input-stream-class*) type
795 &key (view (stream-default-view stream))
796 (default nil defaultp)
797 (default-type nil default-type-p)
798 (activation-gestures nil activationsp)
799 (additional-activation-gestures
800 nil additional-activations-p)
801 (delimiter-gestures nil delimitersp)
802 (additional-delimiter-gestures
803 nil additional-delimiters-p)
804 &allow-other-keys)
805 (with-activation-gestures ((if additional-activations-p
806 additional-activation-gestures
807 activation-gestures)
808 :override activationsp)
809 (with-delimiter-gestures ((if additional-delimiters-p
810 additional-delimiter-gestures
811 delimiter-gestures)
812 :override delimitersp)
813 (multiple-value-bind (object object-type)
814 (apply-presentation-generic-function
815 accept
816 type stream view
817 `(,@(and defaultp `(:default ,default))
818 ,@(and default-type-p `(:default-type ,default-type))))
819 (values object (or object-type type))))))
820
821 (defun accept-1 (stream type &key
822 (view (stream-default-view stream))
823 (default nil defaultp)
824 (default-type nil default-type-p)
825 provide-default
826 insert-default
827 (replace-input t)
828 history
829 active-p
830 prompt
831 prompt-mode
832 display-default
833 query-identifier
834 (activation-gestures nil activationsp)
835 (additional-activation-gestures nil additional-activations-p)
836 (delimiter-gestures nil delimitersp)
837 (additional-delimiter-gestures nil additional-delimiters-p))
838 (declare (ignore provide-default history active-p
839 prompt prompt-mode
840 display-default query-identifier))
841 (when (and defaultp (not default-type-p))
842 (error ":default specified without :default-type"))
843 (when (and activationsp additional-activations-p)
844 (error "only one of :activation-gestures or ~
845 :additional-activation-gestures may be passed to accept."))
846 (unless (or activationsp additional-activations-p *activation-gestures*)
847 (setq activation-gestures *standard-activation-gestures*))
848 (let ((sensitizer-object nil)
849 (sensitizer-type nil))
850 (with-input-editing
851 (stream
852 :input-sensitizer #'(lambda (stream cont)
853 (with-output-as-presentation
854 (stream sensitizer-object sensitizer-type)
855 (declare (ignore stream))
856 (funcall cont))))
857 (with-input-position (stream) ; support for calls to replace-input
858 (when (and insert-default
859 (not (stream-rescanning-p stream)))
860 ;; Insert the default value to the input stream. It should
861 ;; become fully keyboard-editable. We do not want to insert
862 ;; the default if we're rescanning, only during initial
863 ;; setup.
864 (presentation-replace-input stream default default-type view))
865 (setf (values sensitizer-object sensitizer-type)
866 (with-input-context (type)
867 (object object-type event options)
868 (with-activation-gestures ((if additional-activations-p
869 additional-activation-gestures
870 activation-gestures)
871 :override activationsp)
872 (with-delimiter-gestures ((if additional-delimiters-p
873 additional-delimiter-gestures
874 delimiter-gestures)
875 :override delimitersp)
876 (let ((accept-results nil))
877 (handle-empty-input (stream)
878 (setq accept-results
879 (multiple-value-list
880 (if defaultp
881 (funcall-presentation-generic-function
882 accept type stream view
883 :default default
884 :default-type default-type)
885 (funcall-presentation-generic-function
886 accept type stream view))))
887 ;; User entered activation or delimiter
888 ;; gesture without any input.
889 (if defaultp
890 (progn
891 (presentation-replace-input
892 stream default default-type view :rescan nil))
893 (simple-parse-error
894 "Empty input for type ~S with no supplied default"
895 type))
896 (setq accept-results (list default default-type)))
897 ;; Eat trailing activation gesture
898 ;; XXX what about pointer gestures?
899 ;; XXX and delimiter gestures?
900 (unless *recursive-accept-p*
901 (let ((ag (read-char-no-hang stream nil stream t)))
902 (unless (or (null ag) (eq ag stream))
903 (unless (activation-gesture-p ag)
904 (unread-char ag stream)))))
905 (values (car accept-results) (if (cdr accept-results)
906 (cadr accept-results)
907 type)))))
908 ;; A presentation was clicked on, or something
909 (t
910 (when (and replace-input
911 (getf options :echo t)
912 (not (stream-rescanning-p stream)))
913 (presentation-replace-input stream object object-type view
914 :rescan nil))
915 (values object object-type))))
916 ;; Just to make it clear that we're returning values
917 (values sensitizer-object sensitizer-type)))))
918
919 (defmethod prompt-for-accept ((stream t)
920 type view
921 &rest accept-args
922 &key &allow-other-keys)
923 (declare (ignore view))
924 (apply #'prompt-for-accept-1 stream type accept-args))
925
926 (defun prompt-for-accept-1 (stream type
927 &key
928 (default nil defaultp)
929 (default-type type)
930 (insert-default nil)
931 (prompt t)
932 (prompt-mode :normal)
933 (display-default prompt)
934 &allow-other-keys)
935 (flet ((display-using-mode (stream prompt default)
936 (ecase prompt-mode
937 (:normal
938 (if *recursive-accept-p*
939 (input-editor-format stream "(~A~@[[~A]~]) " prompt default)
940 (input-editor-format stream "~A~@[[~A]~]: " prompt default)))
941 (:raw
942 (input-editor-format stream "~A" prompt)))))
943 (let ((prompt-string (if (eq prompt t)
944 (format nil "~:[Enter ~;~]~A"
945 *recursive-accept-p*
946 (describe-presentation-type type nil nil))
947 prompt))
948 ;; Don't display the default in the prompt if it is to be
949 ;; inserted into the input stream.
950 (default-string (and defaultp
951 (not insert-default)
952 display-default
953 (present-to-string default default-type))))
954 (cond ((null prompt)
955 nil)
956 (t
957 (display-using-mode stream prompt-string default-string))))))
958
959 (defmethod prompt-for-accept ((stream #.*string-input-stream-class*)
960 type view
961 &rest other-args
962 &key &allow-other-keys)
963
964 (declare (ignore type view other-args))
965 nil)
966
967 ;;; For ACCEPT-FROM-STRING, use this barebones input-editing-stream.
968 (defclass string-input-editing-stream (input-editing-stream fundamental-character-input-stream)
969 ((input-buffer :accessor stream-input-buffer)
970 (insertion-pointer :accessor stream-insertion-pointer
971 :initform 0
972 :documentation "This is not used for anything at any point.")
973 (scan-pointer :accessor stream-scan-pointer
974 :initform 0
975 :documentation "This is not used for anything at any point."))
976 (:documentation "An implementation of the input-editing stream
977 protocol retrieving gestures from a provided string."))
978
979 (defmethod initialize-instance :after ((stream string-input-editing-stream)
980 &key (string (error "A string must be provided"))
981 (start 0) (end (length string))
982 &allow-other-keys)
983 (setf (stream-input-buffer stream)
984 (replace (make-array (- end start) :fill-pointer (- end start))
985 string :start2 start :end2 end)))
986
987 (defmethod stream-element-type ((stream string-input-editing-stream))
988 'character)
989
990 (defmethod close ((stream string-input-editing-stream) &key abort)
991 (declare (ignore abort)))
992
993 (defmethod stream-peek-char ((stream string-input-editing-stream))
994 (or (stream-read-gesture stream :peek-p t)
995 :eof))
996
997 (defmethod stream-read-char-no-hang ((stream string-input-editing-stream))
998 (if (> (stream-scan-pointer stream) (length (stream-input-buffer stream)))
999 :eof
1000 (stream-read-gesture stream)))
1001
1002 (defmethod stream-read-char ((stream string-input-editing-stream))
1003 (stream-read-gesture stream))
1004
1005 (defmethod stream-listen ((stream string-input-editing-stream))
1006 (< (stream-scan-pointer stream) (length (stream-input-buffer stream))))
1007
1008 (defmethod stream-unread-char ((stream string-input-editing-stream) char)
1009 (stream-unread-gesture stream char))
1010
1011 (defmethod invoke-with-input-editor-typeout ((stream string-input-editing-stream) continuation
1012 &key erase)
1013 (declare (ignore erase)))
1014
1015 (defmethod input-editor-format ((stream string-input-editing-stream) format-string
1016 &rest args)
1017 (declare (ignore args)))
1018
1019 (defmethod stream-rescanning-p ((stream string-input-editing-stream))
1020 t)
1021
1022 (defmethod reset-scan-pointer ((stream string-input-editing-stream)
1023 &optional scan-pointer)
1024 (declare (ignore scan-pointer)))
1025
1026 (defmethod immediate-rescan ((stream string-input-editing-stream)))
1027
1028 (defmethod queue-rescan ((stream string-input-editing-stream)))
1029
1030 (defmethod rescan-if-necessary ((stream string-input-editing-stream)
1031 &optional inhibit-activation)
1032 (declare (ignore inhibit-activation)))
1033
1034 (defmethod erase-input-buffer ((stream string-input-editing-stream)
1035 &optional start-position)
1036 (declare (ignore start-position)))
1037
1038 (defmethod redraw-input-buffer ((stream string-input-editing-stream)
1039 &optional start-position)
1040 (declare (ignore start-position)))
1041
1042 (defmethod stream-process-gesture ((stream string-input-editing-stream) gesture type)
1043 (when (characterp gesture)
1044 (values gesture type)))
1045
1046 (defmethod stream-read-gesture ((stream string-input-editing-stream)
1047 &key peek-p &allow-other-keys)
1048 (unless (> (stream-scan-pointer stream) (length (stream-input-buffer stream)))
1049 (prog1 (if (= (stream-scan-pointer stream) (length (stream-input-buffer stream)))
1050 (second (first (gethash (first *activation-gestures*)
1051 climi::*gesture-names*))) ; XXX - will always be non-NIL?
1052 (aref (stream-input-buffer stream) (stream-scan-pointer stream)))
1053 (unless peek-p
1054 (incf (stream-scan-pointer stream))))))
1055
1056 (defmethod stream-unread-gesture ((stream string-input-editing-stream) gesture)
1057 (decf (stream-scan-pointer stream)))
1058
1059 (defmethod stream-accept ((stream string-input-editing-stream) type &rest args)
1060 (apply #'accept-1 stream type args))
1061
1062 ;;; XXX This needs work! It needs to do everything that accept does for
1063 ;;; expanding ptypes and setting up recursive call procesusing
1064 (defun accept-from-string (type string
1065 &rest args
1066 &key view
1067 (default nil defaultp)
1068 (default-type nil default-type-p)
1069 (activation-gestures nil activationsp)
1070 (additional-activation-gestures
1071 nil
1072 additional-activations-p)
1073 (delimiter-gestures nil delimitersp)
1074 (additional-delimiter-gestures
1075 nil
1076 additional-delimiters-p)
1077 (start 0)
1078 (end (length string)))
1079 (declare (ignore view))
1080 ;; XXX work in progress here.
1081 (with-activation-gestures ((if additional-activations-p
1082 additional-activation-gestures
1083 activation-gestures)
1084 :override activationsp)
1085 (with-delimiter-gestures ((if additional-delimiters-p
1086 additional-delimiter-gestures
1087 delimiter-gestures)
1088 :override delimitersp)))
1089 (when (zerop (- end start))
1090 (if defaultp
1091 (return-from accept-from-string (values default
1092 (if default-type-p
1093 default-type
1094 type)
1095 0))
1096 (simple-parse-error "Empty string")))
1097 (let ((stream (make-instance 'string-input-editing-stream
1098 :string string :start start :end end)))
1099 (multiple-value-bind (val ptype)
1100 (with-keywords-removed (args (:start :end))
1101 (apply #'stream-accept stream type :history nil :view +textual-view+ args))
1102 (values val ptype (+ (stream-scan-pointer stream) start)))))
1103
1104 (define-presentation-generic-function %presentation-refined-position-test
1105 presentation-refined-position-test
1106 (type-key parameters options type record x y))
1107
1108 (define-default-presentation-method presentation-refined-position-test
1109 (type record x y)
1110 (declare (ignore type))
1111 ;;; output-record-hit-detection-rectangle* has already been called
1112 (let ((single-box (presentation-single-box record)))
1113 (if (or (eq single-box t) (eq single-box :position))
1114 t
1115 (labels ((tester (record)
1116 (typecase record
1117 (displayed-output-record
1118 (return-from presentation-refined-position-test t))
1119 (compound-output-record
1120 (map-over-output-records-containing-position
1121 #'tester record x y))
1122 (t nil))))
1123 (tester record)
1124 nil))))
1125
1126 (defun presentation-contains-position (record x y)
1127 (let ((single-box (presentation-single-box record)))
1128 (multiple-value-bind (min-x min-y max-x max-y)
1129 (output-record-hit-detection-rectangle* record)
1130 (if (and (<= min-x x max-x) (<= min-y y max-y))
1131 (if (or (null single-box) (eq single-box :highlighting))
1132 (funcall-presentation-generic-function
1133 presentation-refined-position-test
1134 (presentation-type record) record x y)
1135 t)
1136 nil))))
1137
1138 (define-presentation-generic-function %highlight-presentation
1139 highlight-presentation
1140 (type-key parameters options type record stream state))
1141
1142 ;;; Internal function to highlight just one presentation
1143
1144 (defun highlight-presentation-1 (presentation stream state)
1145 (with-output-recording-options (stream :record nil)
1146 (funcall-presentation-generic-function highlight-presentation
1147 (presentation-type presentation)
1148 presentation
1149 stream
1150 state)))
1151
1152 (defgeneric highlight-output-record-tree (record stream state))
1153
1154 (defmethod highlight-output-record-tree (record stream state)
1155 (declare (ignore record stream state))
1156 (values))
1157
1158 (defmethod highlight-output-record-tree ((record compound-output-record) stream state)
1159 (map-over-output-records
1160 (lambda (record)
1161 (highlight-output-record-tree record stream state))
1162 record))
1163
1164 (defmethod highlight-output-record-tree ((record displayed-output-record) stream state)
1165 (highlight-output-record record stream state))
1166
1167 (define-default-presentation-method highlight-presentation
1168 (type record stream state)
1169 (declare (ignore type))
1170 (if (or (eq (presentation-single-box record) t)
1171 (eq (presentation-single-box record) :highlighting))
1172 (highlight-output-record record stream state)
1173 (highlight-output-record-tree record stream state)))
1174
1175 (define-default-presentation-method present
1176 (object type stream (view textual-view) &key acceptably for-context-type)
1177 (declare (ignore for-context-type type))
1178 (if acceptably
1179 (let ((*print-readably* t))
1180 (prin1 object stream))
1181 (princ object stream)))
1182
1183
1184 (defun accept-using-read (stream ptype &key ((:read-eval *read-eval*) nil))
1185 (let* ((token (read-token stream)))
1186 (let ((result (handler-case (read-from-string token)
1187 (error (c)
1188 (declare (ignore c))
1189 (simple-parse-error "Error parsing ~S for presentation type ~S"
1190 token
1191 ptype)))))
1192 (if (presentation-typep result ptype)
1193 (values result ptype)
1194 (input-not-of-required-type result ptype)))))
1195
1196 (defun accept-using-completion (type stream func
1197 &rest complete-with-input-key-args)
1198 "A wrapper around complete-with-input that returns the presentation type with
1199 the completed object."
1200 (multiple-value-bind (object success input)
1201 (apply #'complete-input stream func complete-with-input-key-args)
1202 (if success
1203 (values object type)
1204 (simple-parse-error "Error parsing ~S for presentation type ~S"
1205 input
1206 type))))
1207
1208 ;;; When no accept method has been defined for a type, allow some kind of
1209 ;;; input. The accept can be satisfied with pointer input, of course, and this
1210 ;;; allows the clever user a way to input the type at the keyboard, using #. or
1211 ;;; some other printed representation.
1212 ;;;
1213 ;;; XXX Once we "go live" we probably want to disable this, probably with a
1214 ;;; beep and warning that input must be clicked on.
1215
1216 (define-default-presentation-method accept
1217 (type stream (view textual-view) &key default default-type)
1218 (declare (ignore default default-type))
1219 (accept-using-read stream type :read-eval t))
1220
1221 ;;; The presentation types
1222
1223 (define-presentation-method presentation-typep (object (type t))
1224 (declare (ignore object))
1225 t)
1226
1227 (define-presentation-method present (object (type t)
1228 stream
1229 (view textual-view)
1230 &key acceptably for-context-type)
1231 (declare (ignore for-context-type))
1232 (let ((*print-readably* acceptably))
1233 (if acceptably
1234 (prin1 object stream)
1235 (princ object stream))))
1236
1237 (define-presentation-type nil ())
1238
1239 (define-presentation-method presentation-typep (object (type nil))
1240 (declare (ignore object))
1241 nil)
1242
1243 (define-presentation-type null ()
1244 :inherit-from t)
1245
1246 (define-presentation-method presentation-typep (object (type null))
1247 (eq object nil))
1248
1249 (define-presentation-method present (object (type null)
1250 stream
1251 (view textual-view)
1252 &key acceptably for-context-type)
1253 (declare (ignore object acceptably for-context-type))
1254 (write-string "None" stream))
1255
1256 (define-presentation-method accept ((type null) stream (view textual-view)
1257 &key)
1258 (values (completing-from-suggestions (stream)
1259 (suggest "None" nil)
1260 (suggest "" nil))))
1261
1262 (define-presentation-type boolean ()
1263 :inherit-from t)
1264
1265 (define-presentation-method presentation-typep (object (type boolean))
1266 (or (eq object t) (eq object nil)))
1267
1268 (define-presentation-method present (object (type boolean) stream
1269 (view textual-view)
1270 &key acceptably for-context-type)
1271 (declare (ignore acceptably for-context-type))
1272 (if object
1273 (write-string "Yes" stream)
1274 (write-string "No" stream)))
1275
1276 (define-presentation-method accept ((type boolean) stream (view textual-view)
1277 &key)
1278 (accept-using-completion 'boolean
1279 stream
1280 #'(lambda (input-string mode)
1281 (complete-from-possibilities
1282 input-string
1283 '(("yes" t) ("no" nil))
1284 nil
1285 :action mode))))
1286
1287 (define-presentation-type symbol ()
1288 :inherit-from 't)
1289
1290 (define-presentation-method presentation-typep (object (type symbol))
1291 (symbolp object))
1292
1293 (define-presentation-method present (object (type symbol) stream
1294 (view textual-view)
1295 &key acceptably for-context-type)
1296 (declare (ignore for-context-type))
1297 (if acceptably
1298 (prin1 object stream)
1299 (princ object stream)))
1300
1301 (define-presentation-method accept ((type symbol) stream (view textual-view)
1302 &key)
1303 (accept-using-read stream type))
1304
1305 (define-presentation-type keyword () :inherit-from 'symbol)
1306
1307 (define-presentation-method presentation-typep (object (type keyword))
1308 (keywordp object))
1309
1310 (define-presentation-method present (object (type keyword) stream
1311 (view textual-view)
1312 &key acceptably for-context-type)
1313 (declare (ignore acceptably for-context-type))
1314 (prin1 object stream))
1315
1316 (defmethod presentation-type-of ((object symbol))
1317 (if (eq (symbol-package object) (find-package :keyword))
1318 'keyword
1319 'symbol))
1320
1321 (define-presentation-type blank-area ()
1322 :inherit-from t)
1323
1324 (define-presentation-method highlight-presentation ((type blank-area)
1325 record
1326 stream
1327 state)
1328 (declare (ignore record stream state))
1329 nil)
1330
1331 ;;; Do other slots of this have to be bound in order for this to be useful?
1332 ;;; Guess we'll see.
1333 (defparameter *null-presentation* (make-instance 'standard-presentation
1334 :object nil
1335 :type 'blank-area
1336 :view +textual-view+))
1337
1338 (define-presentation-type number ()
1339 :inherit-from 't)
1340
1341 (define-presentation-method presentation-typep (object (type number))
1342 (numberp object))
1343
1344 (defmethod presentation-type-of ((object number))
1345 'number)
1346
1347 (define-presentation-type complex (&optional (type 'real))
1348 :inherit-from 'number)
1349
1350 (define-presentation-method presentation-typep (object (type complex))
1351 (and (complexp object)
1352 (typep (realpart object) type)
1353 (typep (imagpart object) type)))
1354
1355 (define-presentation-method presentation-subtypep ((type complex)
1356 maybe-supertype)
1357 (with-presentation-type-parameters (complex type)
1358 (let ((component-type type)) ;i.e., the parameter named "type"
1359 (with-presentation-type-parameters (complex maybe-supertype)
1360 (let ((super-component-type type))
1361 (presentation-subtypep component-type super-component-type))))))
1362
1363
1364 (defmethod presentation-type-of ((object complex))
1365 'complex)
1366
1367 (define-presentation-method present (object (type complex) stream
1368 (view textual-view)
1369 &key acceptably for-context-type)
1370 (declare (ignore acceptably for-context-type))
1371 (present (realpart object) (presentation-type-of (realpart object))
1372 :stream stream :view view :sensitive nil)
1373 (write-char #\Space stream)
1374 (present (imagpart object) (presentation-type-of (imagpart object))
1375 :stream stream :view view :sensitive nil))
1376
1377 (define-presentation-type real (&optional low high) :options ((base 10) radix)
1378 :inherit-from 'number)
1379
1380 (define-presentation-method presentation-typep (object (type real))
1381 (and (realp object)
1382 (or (eq low '*)
1383 (<= low object))
1384 (or (eq high '*)
1385 (<= object high))))
1386
1387 (defmethod presentation-type-of ((object real))
1388 'real)
1389
1390 (define-presentation-method present (object (type real) stream
1391 (view textual-view)
1392 &key acceptably for-context-type)
1393 (declare (ignore acceptably for-context-type))
1394 (let ((*print-base* base)
1395 (*print-radix* radix))
1396 (princ object stream)))
1397
1398 (define-presentation-method accept ((type real) stream (view textual-view)
1399 &key)
1400 (let ((*read-base* base))
1401 (accept-using-read stream type)))
1402
1403 ;;; Define a method that will do the comparision for all real types. It's
1404 ;;; already determined that that the numeric class of type is a subtype of
1405 ;;;supertype.
1406
1407 (defun number-subtypep (low high super-low super-high)
1408 (if (eq low '*)
1409 (unless (eq super-low '*)
1410 (return-from number-subtypep nil))
1411 (unless (or (eq super-low '*) (>= low super-low))
1412 (return-from number-subtypep nil)))
1413 (if (eq high '*)
1414 (unless (eq super-high '*)
1415 (return-from number-subtypep nil))
1416 (unless (or (eq super-high '*) (<= high super-high))
1417 (return-from number-subtypep nil)))
1418 t)
1419
1420 (define-presentation-type rational (&optional low high)
1421 :options ((base 10) radix)
1422 :inherit-from `((real ,low ,high) :base ,base :radix ,radix))
1423
1424 (define-presentation-method presentation-typep (object (type rational))
1425 (and (rationalp object)
1426 (or (eq low '*)
1427 (<= low object))
1428 (or (eq high '*)
1429 (<= object high))))
1430
1431 (defmethod presentation-type-of ((object rational))
1432 'rational)
1433
1434 (define-presentation-method present (object (type rational) stream
1435 (view textual-view)
1436 &key acceptably for-context-type)
1437 (declare (ignore acceptably for-context-type))
1438 (let ((*print-base* base)
1439 (*print-radix* radix))
1440 (princ object stream)))
1441
1442 (define-presentation-type integer (&optional low high)
1443 :options ((base 10) radix)
1444 :inherit-from `((rational ,low ,high) :base ,base :radix ,radix))
1445
1446 (define-presentation-method presentation-typep (object (type integer))
1447 (and (integerp object)
1448 (or (eq low '*)
1449 (<= low object))
1450 (or (eq high '*)
1451 (<= object high))))
1452
1453 (defmethod presentation-type-of ((object integer))
1454 'integer)
1455
1456 (define-presentation-method present (object (type integer) stream
1457 (view textual-view)
1458 &key acceptably for-context-type)
1459 (declare (ignore acceptably for-context-type))
1460 (let ((*print-base* base)
1461 (*print-radix* radix))
1462 (princ object stream)))
1463
1464 (define-presentation-type ratio (&optional low high)
1465 :options ((base 10) radix)
1466 :inherit-from `((rational ,low ,high) :base ,base :radix ,radix))
1467
1468 (define-presentation-method presentation-typep (object (type ratio))
1469 (and (not (integerp object))
1470 (rationalp object)
1471 (or (eq low '*)
1472 (<= low object))
1473 (or (eq high '*)
1474 (<= object high))))
1475
1476 (defmethod presentation-type-of ((object ratio))
1477 'ratio)
1478
1479 (define-presentation-method present (object (type ratio) stream
1480 (view textual-view)
1481 &key acceptably for-context-type)
1482 (declare (ignore acceptably for-context-type))
1483 (let ((*print-base* base)
1484 (*print-radix* radix))
1485 (princ object stream)))
1486
1487 (define-presentation-type float (&optional low high)
1488 :options ((base 10) radix)
1489 :inherit-from `((real ,low ,high) :base ,base :radix ,radix))
1490
1491 (define-presentation-method presentation-typep (object (type float))
1492 (and (floatp object)
1493 (or (eq low '*)
1494 (<= low object))
1495 (or (eq high '*)
1496 (<= object high))))
1497
1498 (defmethod presentation-type-of ((object float))
1499 'float)
1500
1501 (define-presentation-method present (object (type float) stream
1502 (view textual-view)
1503 &key acceptably for-context-type)
1504 (declare (ignore acceptably for-context-type))
1505 (let ((*print-base* base)
1506 (*print-radix* radix))
1507 (princ object stream)))
1508
1509 (macrolet ((frob (num-type)
1510 `(define-presentation-method presentation-subtypep ((type
1511 ,num-type)
1512 maybe-supertype)
1513 (with-presentation-type-parameters (,num-type maybe-supertype)
1514 (let ((super-low low)
1515 (super-high high))
1516 (with-presentation-type-parameters (,num-type type)
1517 (values (number-subtypep low high super-low super-high)
1518 t)))))))
1519 (frob real)
1520 (frob rational)
1521 (frob ratio)
1522 (frob float))
1523
1524 (define-presentation-type character ()
1525 :inherit-from 't)
1526
1527 (define-presentation-method presentation-typep (object (type character))
1528 (characterp object))
1529
1530 (defmethod presentation-type-of ((object character))
1531 'character)
1532
1533 (define-presentation-method present (object (type character) stream
1534 (view textual-view)
1535 &key acceptably for-context-type)
1536 (declare (ignore acceptably for-context-type))
1537 (princ object stream))
1538
1539 (define-presentation-type string (&optional length)
1540 :inherit-from 't)
1541
1542 (define-presentation-method presentation-typep (object (type string))
1543 (and (stringp object)
1544 (or (eq length '*) (eql (length object) length))))
1545
1546 (define-presentation-method presentation-subtypep ((type string)
1547 maybe-supertype)
1548 (with-presentation-type-parameters (string maybe-supertype)
1549 (let ((super-length length))
1550 (with-presentation-type-parameters (string type)
1551 (values (or (eq super-length '*)
1552 (eql length super-length))
1553 t)))))
1554
1555 ;;; `(string ,length) would be more specific, but is not "likely to be useful
1556 ;;; to the programmer."
1557
1558 (defmethod presentation-type-of ((object string))
1559 'string)
1560
1561 (define-presentation-method present (object (type string) stream
1562 (view textual-view)
1563 &key acceptably for-context-type)
1564 (declare (ignore for-context-type))
1565 (if acceptably
1566 (prin1 object stream)
1567 (princ object stream)))
1568
1569 (define-presentation-method accept ((type string) stream (view textual-view)
1570 &key (default nil defaultp)
1571 (default-type type))
1572 (let ((result (read-token stream)))
1573 (cond ((numberp length)
1574 (if (eql length (length result))
1575 (values result type)
1576 (input-not-of-required-type result type)))
1577 ((and (zerop (length result)) defaultp)
1578 (values default default-type))
1579 (t (values result type)))))
1580
1581 (define-presentation-type pathname ()
1582 :options ((default-version :newest) default-type (merge-default t))
1583 :inherit-from 't)
1584
1585 (define-presentation-method presentation-typep (object (type pathname))
1586 (pathnamep object))
1587
1588 (define-presentation-method present ((object pathname) (type pathname)
1589 stream (view textual-view) &key)
1590 ;; XXX: We can only visually represent the pathname if it has a name
1591 ;; - making it wild is a compromise. If the pathname is completely
1592 ;; blank, we leave it as-is, though.
1593
1594 ;; The above comment was meant to indicate that if the pathname had
1595 ;; neither a name NOR a directory, then it couldn't be visually
1596 ;; represented. Some discussion has ensued on the possbility of
1597 ;; emitting something like "A pathname of type <foo>"
1598 ;; [2007/01/08:rpg]
1599 (let ((pathname (if (equal object #.(make-pathname))
1600 object
1601 (merge-pathnames object (make-pathname :name :wild)))))
1602 (princ object stream))
1603 )
1604
1605 (define-presentation-method present ((object string) (type pathname)
1606 stream (view textual-view)
1607 &rest args &key)
1608 (apply-presentation-generic-function
1609 present (pathname object) type stream view args))
1610
1611 (defmethod presentation-type-of ((object pathname))
1612 'pathname)
1613
1614 (defun filename-completer (so-far mode)
1615 (let* ((directory-prefix
1616 (if (and (plusp (length so-far)) (eql (aref so-far 0) #\/))
1617 ""
1618 (namestring #+sbcl *default-pathname-defaults*
1619 #+cmu (ext:default-directory)
1620 #-(or sbcl cmu) *default-pathname-defaults*)))
1621 (full-so-far (concatenate 'string directory-prefix so-far))
1622 (pathnames
1623 (loop with length = (length full-so-far)
1624 and wildcard = (format nil "~A*.*"
1625 (loop for start = 0 ; Replace * -> \*
1626 for occurence = (position #\* so-far :start start)
1627 until (= start (length so-far))
1628 until (null occurence)
1629 do (replace so-far "\\*" :start1 occurence)
1630 (setf start (+ occurence 2))
1631 finally (return so-far)))
1632 for path in
1633 #+(or sbcl cmu lispworks) (directory wildcard)
1634 #+openmcl (directory wildcard :directories t)
1635 #+allegro (directory wildcard :directories-are-files nil)
1636 #+cormanlisp (nconc (directory wildcard)
1637 (cl::directory-subdirs dirname))
1638 #-(or sbcl cmu lispworks openmcl allegro cormanlisp)
1639 (directory wildcard)
1640 when (let ((mismatch (mismatch (namestring path) full-so-far)))
1641 (or (null mismatch) (= mismatch length)))
1642 collect path))
1643 (strings (mapcar #'namestring pathnames))
1644 (first-string (car strings))
1645 (length-common-prefix nil)
1646 (completed-string nil)
1647 (full-completed-string nil)
1648 (input-is-directory-p (when (plusp (length so-far))
1649 (char= (aref so-far (1- (length so-far))) #\/))))
1650 (unless (null pathnames)
1651 (setf length-common-prefix
1652 (loop with length = (length first-string)
1653 for string in (cdr strings)
1654 do (setf length (min length (or (mismatch string first-string) length)))
1655 finally (return length))))
1656 (unless (null pathnames)
1657 (setf completed-string
1658 (subseq first-string (length directory-prefix)
1659 (if (null (cdr pathnames)) nil length-common-prefix)))
1660 (setf full-completed-string
1661 (concatenate 'string directory-prefix completed-string)))
1662 (case mode
1663 ((:complete-limited :complete-maximal)
1664 (cond ((null pathnames)
1665 (values so-far nil nil 0 nil))
1666 ((null (cdr pathnames))
1667 (values completed-string (plusp (length so-far)) (car pathnames) 1 nil))
1668 (input-is-directory-p
1669 (values completed-string t (parse-namestring so-far) (length pathnames) nil))
1670 (t
1671 (values completed-string nil nil (length pathnames) nil))))
1672 (:complete
1673 ;; This is reached when input is activated, if we did
1674 ;; completion, that would mean that an input of "foo" would
1675 ;; be expanded to "foobar" if "foobar" exists, even if the
1676 ;; user actually *wants* the "foo" pathname (to create the
1677 ;; file, for example).
1678 (values so-far t so-far 1 nil))
1679 (:possibilities
1680 (values nil nil nil (length pathnames)
1681 (loop with length = (length directory-prefix)
1682 for name in pathnames
1683 collect (list (subseq (namestring name) length nil)
1684 name)))))))
1685
1686 (define-presentation-method accept ((type pathname) stream (view textual-view)
1687 &key (default *default-pathname-defaults* defaultp)
1688 ((:default-type accept-default-type) type))
1689 (multiple-value-bind (pathname success string)
1690 (complete-input stream
1691 #'filename-completer
1692 :allow-any-input t)
1693 (cond ((and pathname success)
1694 (values (if merge-default
1695 (progn
1696 (unless (or (pathname-type pathname)
1697 (null default-type))
1698 (setf pathname (make-pathname :defaults pathname
1699 :type default-type)))
1700 (merge-pathnames pathname default default-version))
1701 pathname)
1702 type))
1703 ((and (zerop (length string))
1704 defaultp)
1705 (values default accept-default-type))
1706 (t (values string 'string)))))
1707
1708 (defmethod presentation-replace-input :around
1709 ((stream input-editing-stream)
1710 (object pathname) (type (eql 'pathname))
1711 view &rest args &key &allow-other-keys)
1712 ;; This is fully valid and compliant, but it still smells slightly
1713 ;; like a hack.
1714 (let ((name (pathname-name object))
1715 (directory (when (pathname-directory object)
1716 (directory-namestring object)))
1717 (type (pathname-type object))
1718 (string "")
1719 (old-insp (stream-insertion-pointer stream)))
1720 (setf string (or directory string))
1721 (setf string (concatenate 'string string
1722 (cond ((and name type)
1723 (file-namestring object))
1724 (name name)
1725 (type (subseq
1726 (namestring
1727 (make-pathname
1728 :name " "
1729 :type type))
1730 1)))))
1731 (apply #'replace-input stream string args)
1732 (when directory
1733 (setf (stream-insertion-pointer stream)
1734 (+ old-insp (if directory (length directory) 0)))
1735 ;; If we moved the insertion pointer, this might be a good idea.
1736 (redraw-input-buffer stream old-insp))))
1737
1738 (defgeneric default-completion-name-key (item))
1739
1740 (defmethod default-completion-name-key ((item string))
1741 item)
1742
1743 (defmethod default-completion-name-key ((item null))
1744 "NIL")
1745
1746 (defmethod default-completion-name-key ((item cons))
1747 (string (car item)))
1748
1749 (defmethod default-completion-name-key ((item symbol))
1750 (string-capitalize (symbol-name item)))
1751
1752 (defmethod default-completion-name-key (item)
1753 (princ-to-string item))
1754
1755 (eval-when (:compile-toplevel :load-toplevel :execute)
1756 (defconstant +completion-options+
1757 '((name-key 'default-completion-name-key)
1758 documentation-key
1759 (partial-completers '(#\Space)))))
1760
1761 (define-presentation-type completion (sequence
1762 &key (test 'eql) (value-key 'identity))
1763 :options #.+completion-options+
1764 :inherit-from t)
1765
1766 (define-presentation-method presentation-typep (object (type completion))
1767 (map nil #'(lambda (obj)
1768 (when (funcall test object (funcall value-key obj))
1769 (return-from presentation-typep t)))
1770 sequence)
1771 nil)
1772
1773 ;;; Useful for subtype comparisons for several of the "member" style types
1774
1775 (defun sequence-subset-p (seq1 test1 value-key1 seq2 test2 value-key2)
1776 (let ((test-fun (if (eq test1 test2)
1777 test1
1778 ;; The object has to pass both type's equality test
1779 #'(lambda (obj1 obj2)
1780 (and (funcall test1 obj1 obj2)
1781 (funcall test2 obj1 obj2))))))
1782 (map nil #'(lambda (type-obj)
1783 (unless (find (funcall value-key1 type-obj)
1784 seq2
1785 :test test-fun :key value-key2)
1786 (return-from sequence-subset-p nil)))
1787 seq1)
1788 t))
1789
1790 (define-presentation-method presentation-subtypep ((type completion)
1791 maybe-supertype)
1792 (with-presentation-type-parameters (completion maybe-supertype)
1793 (let ((super-sequence sequence)
1794 (super-test test)
1795 (super-value-key value-key))
1796 (with-presentation-type-parameters (completion type)
1797 (values (sequence-subset-p sequence test value-key
1798 super-sequence super-test super-value-key)
1799 t)))))
1800
1801 (define-presentation-method present (object (type completion) stream
1802 (view textual-view)
1803 &key acceptably for-context-type)
1804 (declare (ignore acceptably for-context-type))
1805 (let ((obj-pos (position object sequence :test test :key value-key)))
1806 (if obj-pos
1807 (write-string (funcall name-key (elt sequence obj-pos)) stream)
1808 ;; Should define a condition type here.
1809 (error "~S is not of presentation type ~S" object type))))
1810
1811 (define-presentation-method accept ((type completion)
1812 stream
1813 (view textual-view)
1814 &key)
1815 (accept-using-completion (make-presentation-type-specifier
1816 `(completion ,@parameters)
1817 options)
1818 stream
1819 #'(lambda (input-string mode)
1820 (complete-from-possibilities
1821 input-string
1822 sequence
1823 partial-completers
1824 :action mode
1825 :name-key name-key
1826 :value-key value-key))
1827 :partial-completers partial-completers))
1828
1829 (define-presentation-type-abbreviation member (&rest elements)
1830 (make-presentation-type-specifier `(completion ,elements)
1831 :name-key name-key
1832 :documentation-key documentation-key
1833 :partial-completers partial-completers)
1834 :options #.+completion-options+)
1835
1836 (define-presentation-type-abbreviation member-sequence (sequence
1837 &key (test 'eql testp))
1838 (make-presentation-type-specifier
1839 `(completion ,sequence ,@(and testp `(:test ,test)))
1840 :name-key name-key
1841 :documentation-key documentation-key
1842 :partial-completers partial-completers)
1843 :options #.+completion-options+)
1844
1845 (defun member-alist-value-key (element)
1846 (cond ((atom element)
1847 element)
1848 ((atom (cdr element))
1849 (cdr element))
1850 ((null (cddr element))
1851 (cadr element))
1852 (t (getf (cdr element) :value))))
1853
1854 (defun member-alist-doc-key (element)
1855 (if (and (consp element) (consp (cdr element)) (consp (cddr element)))
1856 (getf (cdr element) :documentation)))
1857
1858 (define-presentation-type-abbreviation member-alist (alist
1859 &key (test 'eql testp))
1860 (make-presentation-type-specifier
1861 `(completion ,alist ,@(and testp `(:test ,test))
1862 :value-key member-alist-value-key)
1863 :name-key name-key
1864 :documentation-key documentation-key
1865 :partial-completers partial-completers)
1866 :options ((name-key 'default-completion-name-key)
1867 (documentation-key 'member-alist-doc-key)
1868 (partial-completers '(#\Space))))
1869
1870 (define-presentation-type subset-completion (sequence
1871 &key (test 'eql)
1872 (value-key 'identity))
1873 :options ((name-key 'default-completion-name-key)
1874 documentation-key
1875 (partial-completers '(#\Space))
1876 (separator #\,)
1877 (echo-space t))
1878 :inherit-from t)
1879
1880 (define-presentation-method presentation-typep (object
1881 (type subset-completion))
1882 (map nil #'(lambda (obj)
1883 (unless (find obj sequence :test test :key value-key)
1884 (return-from presentation-typep nil)))
1885 object)
1886 t)
1887
1888 (define-presentation-method presentation-subtypep ((type subset-completion)
1889 maybe-supertype)
1890 (with-presentation-type-parameters (subset-completion maybe-supertype)
1891 (let ((super-sequence sequence)
1892 (super-test test)
1893 (super-value-key value-key))
1894 (with-presentation-type-parameters (subset-completion type)
1895 (values (sequence-subset-p sequence test value-key
1896 super-sequence super-test super-value-key)
1897 t)))))
1898
1899 (define-presentation-method present ((object list) (type subset-completion)
1900 stream
1901 (view textual-view)
1902 &key acceptably for-context-type)
1903 (declare (ignore for-context-type))
1904 (loop for tail on object
1905 for (obj) = tail
1906 do (progn
1907 (present obj (presentation-type-of object)
1908 :stream stream :view view
1909 :acceptably acceptably
1910 :sensitive nil)
1911 (when (cdr tail)
1912 (if acceptably
1913 (princ separator stream)
1914 (terpri stream))))))
1915
1916 (define-presentation-method present ((object vector) (type subset-completion)
1917 stream
1918 (view textual-view)
1919 &key acceptably for-context-type)
1920 (declare (ignore for-context-type))
1921 (loop for i from 0 below (length object)
1922 for obj = (aref object i)
1923 do (progn
1924 (present obj (presentation-type-of object)
1925 :stream stream :view view
1926 :acceptably acceptably
1927 :sensitive nil)
1928 (when (< i (1- (length object)))
1929 (if acceptably
1930 (princ separator stream)
1931 (terpri stream))))))
1932
1933 ;;; XXX is it a typo in the spec that subset, subset-sequence and subset-alist
1934 ;;; have the same options as completion, and not subset-completion?
1935
1936 (define-presentation-type-abbreviation subset (&rest elements)
1937 (make-presentation-type-specifier `(subset-completion ,elements)
1938 :name-key name-key
1939 :documentation-key documentation-key
1940 :partial-completers partial-completers)
1941 :options #.+completion-options+)
1942
1943 (define-presentation-type-abbreviation subset-sequence (sequence
1944 &key (test 'eql testp))
1945 (make-presentation-type-specifier
1946 `(subset-completion ,sequence ,@(and testp `(:test ,test)))
1947 :name-key name-key
1948 :documentation-key documentation-key
1949 :partial-completers partial-completers)
1950 :options #.+completion-options+)
1951
1952 (define-presentation-type-abbreviation subset-alist (alist
1953 &key (test 'eql testp))
1954 (make-presentation-type-specifier
1955 `(subset-completion ,@(and testp `(:test ,test))
1956 :value-key member-alist-value-key)
1957 :name-key name-key
1958 :documentation-key documentation-key
1959 :partial-completers partial-completers)
1960 :options ((name-key 'default-completion-name-key)
1961 (documentation-key 'member-alist-doc-key)
1962 (partial-completers '(#\Space))))
1963
1964 (define-presentation-type sequence (type)
1965 :options ((separator #\,) (echo-space t))
1966 :inherit-from 't
1967 :parameters-are-types t)
1968
1969 (define-presentation-method presentation-type-specifier-p ((type sequence))
1970 (and (listp type)
1971 (consp (rest type))
1972 (presentation-type-specifier-p (second type))))
1973
1974 (define-presentation-method presentation-typep (object (type sequence))
1975 ;; XXX TYPE here is the sequence element type, not the whole type specifier
1976 (unless (or (listp object) (vectorp object))
1977 (return-from presentation-typep nil))
1978 (let ((real-type (expand-presentation-type-abbreviation type)))
1979 (map nil #'(lambda (obj)
1980 (unless (presentation-typep obj real-type)
1981 (return-from presentation-typep nil)))
1982 object)
1983 t))
1984
1985 (define-presentation-method presentation-subtypep ((type sequence)
1986 maybe-supertype)
1987 (with-presentation-type-parameters (sequence type)
1988 ;; now TYPE is bound to the parameter TYPE
1989 (let ((real-type (expand-presentation-type-abbreviation type)))
1990 (with-presentation-type-parameters (sequence maybe-supertype)
1991 (let ((real-super-type (expand-presentation-type-abbreviation type)))
1992 (presentation-subtypep real-type real-super-type))))))
1993
1994 (defmethod presentation-type-of ((object cons))
1995 '(sequence t))
1996
1997 ;;; Do something interesting with the array-element-type
1998 (defmethod presentation-type-of ((object vector))
1999 '(sequence t))
2000
2001 (define-presentation-method present ((object list) (type sequence)
2002 stream
2003 (view textual-view)
2004 &key acceptably for-context-type)
2005 (declare (ignore for-context-type))
2006 (loop for tail on object
2007 for (obj) = tail
2008 do (progn
2009 (present obj type ; i.e., the type parameter
2010 :stream stream :view view
2011 :acceptably acceptably
2012 :sensitive nil)
2013 (when (cdr tail)
2014 (write-char separator stream)))))
2015
2016 (define-presentation-method present ((object vector) (type sequence)
2017 stream
2018 (view textual-view)
2019 &key acceptably for-context-type)
2020 (declare (ignore for-context-type))
2021 (loop for i from 0 below (length object)
2022 for obj = (aref object i)
2023 do (progn
2024 (present obj type ; i.e., the type parameter
2025 :stream stream :view view
2026 :acceptably acceptably
2027 :sensitive nil)
2028 (when (< i (1- (length object)))
2029 (write-char separator stream)))))
2030
2031
2032 (define-presentation-method accept ((type sequence)
2033 stream
2034 (view textual-view)
2035 &key)
2036 (loop
2037 with separators = (list separator)
2038 for element = (accept type ; i.e., the type parameter
2039 :stream stream
2040 :view view
2041 :prompt nil
2042 :additional-delimiter-gestures separators)
2043 collect element
2044 do (progn
2045 (when (not (eql (peek-char nil stream nil nil) separator))
2046 (loop-finish))
2047 (read-char stream)
2048 (when echo-space
2049 ;; Make the space a noise string
2050 (input-editor-format stream " ")))))
2051
2052
2053 (define-presentation-type sequence-enumerated (&rest types)
2054 :options ((separator #\,) (echo-space t))
2055 :inherit-from 't
2056 :parameters-are-types t)
2057
2058 (define-presentation-method presentation-typep (object
2059 (type sequence-enumerated))
2060 (unless (or (listp object) (vectorp object))
2061 (return-from presentation-typep nil))
2062 (map nil #'(lambda (obj type)
2063 (let ((real-type (expand-presentation-type-abbreviation type)))
2064 (unless (presentation-typep obj real-type)
2065 (return-from presentation-typep nil))))
2066 object
2067 types)
2068 t)
2069
2070 (define-presentation-method presentation-subtypep ((type sequence-enumerated)
2071 maybe-supertype)
2072 (with-presentation-type-parameters (sequence-enumerated maybe-supertype)
2073 (let ((supertypes types))
2074 (with-presentation-type-parameters (sequence-enumerated type)
2075 (unless (eql (length supertypes) (length types))
2076 (return-from presentation-subtypep (values nil t)))
2077 (map nil
2078 #'(lambda (element-type element-supertype)
2079 (let ((real-type (expand-presentation-type-abbreviation
2080 element-type))
2081 (real-supertype (expand-presentation-type-abbreviation
2082 element-supertype)))
2083 (multiple-value-bind (subtypep determined)
2084 (presentation-subtypep real-type real-supertype)
2085 (cond ((not determined)
2086 (return-from presentation-subtypep
2087 (values nil nil)))
2088 ((not subtypep)
2089 (return-from presentation-subtypep
2090 (values nil t)))))))
2091 types
2092 supertypes)
2093 (values t t)))))
2094
2095 (define-presentation-method present ((object list) (type sequence-enumerated)
2096 stream
2097 (view textual-view)
2098 &key acceptably for-context-type)
2099 (declare (ignore for-context-type))
2100 (loop for tail on object
2101 for (obj) = tail
2102 for obj-type in types
2103 do (progn
2104 (present obj obj-type
2105 :stream stream :view view
2106 :acceptably acceptably
2107 :sensitive nil)
2108 (when (cdr tail)
2109 (if acceptably
2110 (princ separator stream)
2111 (terpri stream))))))
2112
2113 (define-presentation-method present ((object vector) (type sequence-enumerated)
2114 stream
2115 (view textual-view)
2116 &key acceptably for-context-type)
2117 (declare (ignore for-context-type))
2118 (loop for i from 0 below (length object)
2119 for obj = (aref object i)
2120 for obj-type in types
2121 do (progn
2122 (present obj obj-type
2123 :stream stream :view view
2124 :acceptably acceptably
2125 :sensitive nil)
2126 (when (< i (1- (length object)))
2127 (if acceptably
2128 (princ separator stream)
2129 (terpri stream))))))
2130
2131 (define-presentation-method accept ((type sequence-enumerated)
2132 stream
2133 (view textual-view)
2134 &key)
2135 (loop
2136 with element = nil and element-type = nil
2137 and separators = (list separator)
2138 for type-tail on types
2139 for (this-type) = type-tail
2140 do (setf (values element element-type)
2141 (accept this-type
2142 :stream stream
2143 :view view
2144 :prompt t
2145 :display-default nil
2146 :additional-delimiter-gestures separators))
2147 collect element into sequence-val
2148 do (progn
2149 (when (not (eql (peek-char nil stream nil nil) separator))
2150 (loop-finish))
2151 (read-char stream)
2152 (when echo-space
2153 ;; Make the space a noise string
2154 (input-editor-format stream " ")))
2155 finally (if (cdr type-tail)
2156 (simple-parse-error "Input ~S too short for ~S."
2157 sequence-val
2158 types)
2159 (return sequence-val))))
2160
2161 (define-presentation-type or (&rest types)
2162 :inherit-from t
2163 :parameters-are-types t)
2164
2165 (define-presentation-method presentation-typep (object (type or))
2166 (loop for type in types
2167 for real-type = (expand-presentation-type-abbreviation type)
2168 do (when (presentation-typep object real-type)
2169 (return-from presentation-typep t)))
2170 nil)
2171
2172 (define-presentation-method present (object (type or)
2173 stream
2174 (view textual-view)
2175 &key acceptably for-context-type)
2176 (loop for or-type in types
2177 for expanded-type = (expand-presentation-type-abbreviation or-type)
2178 do (when (presentation-typep object expanded-type)
2179 (present object expanded-type
2180 :stream stream :view view
2181 :acceptably acceptably
2182 :for-context-type for-context-type)
2183 (loop-finish))))
2184
2185 (define-presentation-method accept ((type or)
2186 (stream input-editing-stream)
2187 (view textual-view)
2188 &key)
2189 (let ((scan-begin (stream-scan-pointer stream)))
2190 (loop for or-type in types
2191 do (handler-case (return (accept or-type
2192 :stream stream
2193 :view view
2194 :prompt nil))
2195 (parse-error () (setf (stream-scan-pointer stream) scan-begin)))
2196 finally (simple-parse-error "Input type is not one of ~S" types))))
2197
2198 ;;; What does and inherit from? Maybe we'll punt on that for the moment.
2199 ;;; Unless it inherits from its arguments...
2200
2201 (define-presentation-type and (&rest types)
2202 :parameters-are-types t)
2203
2204 (define-presentation-method presentation-typep (object (type and))
2205 (loop for type in types
2206 for real-type = (expand-presentation-type-abbreviation type)
2207 do (with-presentation-type-decoded (name parameters)
2208 real-type
2209 (cond ((eq name 'satisfies)
2210 (unless (funcall (car parameters) object)
2211 (return-from presentation-typep nil)))
2212 ((eq name 'not)
2213 (unless (not (presentation-typep object (car parameters)))
2214 (return-from presentation-typep nil)))
2215 (t (unless (presentation-typep object real-type)
2216 (return-from presentation-typep nil))))))
2217 t)
2218
2219 (define-presentation-method present (object (type and)
2220 stream
2221 (view textual-view)
2222 &key acceptably for-context-type)
2223 (present object (expand-presentation-type-abbreviation (car types))
2224 :stream stream :view view
2225 :acceptably acceptably
2226 :for-context-type for-context-type))
2227
2228 (define-presentation-method accept
2229 ((type and) (stream input-editing-stream) (view textual-view) &rest args &key)
2230 (let ((subtype (first types)))
2231 (multiple-value-bind (obj ptype)
2232 (apply-presentation-generic-function accept subtype stream view args)
2233 (unless (presentation-typep obj type)
2234 (simple-parse-error "Input object ~S is not of type ~S" obj type))
2235 obj)))
2236
2237 (define-presentation-type-abbreviation token-or-type (tokens type)
2238 `(or (member-alist ,tokens) ,type))
2239
2240 (define-presentation-type-abbreviation null-or-type (type)
2241 `(or null ,type))
2242
2243 (define-presentation-type-abbreviation type-or-string (type)
2244 `(or ,type string))
2245
2246 (define-presentation-method presentation-typep (object (type expression))
2247 (declare (ignore object))
2248 t)
2249
2250 (define-presentation-method present (object (type expression)
2251 stream
2252 (view textual-view)
2253 &key acceptably for-context-type)
2254 (declare (ignore for-context-type))
2255 (let ((*print-readably* acceptably))
2256 (prin1 object stream)))
2257
2258 (define-presentation-generic-function %accept-present-default
2259 accept-present-default
2260 (type-key parameters options type
2261 stream view default default-supplied-p present-p query-identifier))
2262
2263 ;;; All the expression and form reading stuff is in builtin-commands.lisp
2264
2265 ;;; drag-n-drop fun
2266
2267 (defclass drag-n-drop-translator (presentation-translator)
2268 ((destination-ptype :reader destination-ptype :initarg :destination-ptype)
2269 (feedback :reader feedback :initarg :feedback)
2270 (highlighting :reader highlighting :initarg :highlighting)
2271 (destination-translator :reader destination-translator
2272 :initarg :destination-translator)))
2273
2274
2275 (defvar *dragged-presentation* nil
2276 "Bound to the presentation dragged in a drag-and-drop context")
2277 (defvar *dragged-object* nil
2278 "Bound to the object dragged in a drag-and-drop context")
2279
2280 ()
2281 ;;; According to the Franz User's guide, the destination object is
2282 ;;; available in the tester, documentation, and translator function
2283 ;;; as destination-object. Therefore OBJECT is the dragged object. In
2284 ;;; our scheme the tester function, translator function etc. is
2285 ;;; really called on the destination object. So, we do a little
2286 ;;; shuffling of arguments here. We don't do that for the destination
2287 ;;; translator because we can call that ourselves in frame-drag-and-drop.
2288 ;;;
2289 ;;; Also, in Classic CLIM the destination presentation is passed as a
2290 ;;; destination-presentation keyword argument; hence the presentation argument
2291 ;;; is the dragged presentation.
2292
2293 (defmethod initialize-instance :after ((obj drag-n-drop-translator)
2294 &key documentation
2295 pointer-documentation
2296 destination-translator)
2297 ;; This is starting to smell...
2298 (flet ((make-adapter (func)
2299 (lambda (object &rest args &key presentation &allow-other-keys)
2300 (if *dragged-presentation*
2301 (apply func
2302 *dragged-object*
2303 :presentation *dragged-presentation*
2304 :destination-object object
2305 :destination-presentation presentation
2306 args)
2307 (apply func object args)))))
2308 (setf (slot-value obj 'documentation) (make-adapter documentation))
2309 (when pointer-documentation
2310 (setf (slot-value obj 'pointer-documentation)
2311 (make-adapter pointer-documentation)))))
2312
2313 (defmacro define-drag-and-drop-translator
2314 (name (from-type to-type destination-type command-table
2315 &rest args &key
2316 (gesture :select)
2317 (tester 'default-translator-tester)
2318 documentation
2319 (pointer-documentation nil pointer-doc-p)
2320 (menu t)
2321 (priority 0)
2322 (feedback 'frame-drag-and-drop-feedback)
2323 (highlighting 'frame-drag-and-drop-highlighting))
2324 arglist
2325 &body body)
2326 (declare (ignore tester gesture documentation pointer-documentation
2327 menu priority))
2328 (let* ((real-dest-type (expand-presentation-type-abbreviation
2329 destination-type))
2330 (name-string (command-name-from-symbol name))
2331 (drag-string (format nil "Drag to ~A" name-string))
2332 (pointer-doc (if pointer-doc-p
2333 nil
2334 `(:pointer-documentation
2335 ((object destination-object stream)
2336 (declare (ignore object))
2337 (write-string (if destination-object
2338 ,name-string
2339 ,drag-string)
2340 stream))))))
2341 (with-keywords-removed (args (:feedback :highlighting))
2342 `(progn
2343 (define-presentation-translator ,name
2344 (,from-type ,to-type ,command-table
2345 :tester-definitive t
2346 ,@args
2347 ,@pointer-doc
2348 :feedback #',feedback :highlighting #',highlighting
2349 :destination-ptype ',real-dest-type
2350 :destination-translator #',(make-translator-fun arglist body)
2351 :translator-class drag-n-drop-translator)
2352 (presentation context-type frame event window x y)
2353 (frame-drag-and-drop ',name ',command-table
2354 presentation context-type
2355 frame event window x y))))))
2356

  ViewVC Help
Powered by ViewVC 1.1.5